160 lines
3.9 KiB
Forth
160 lines
3.9 KiB
Forth
\ ** ficl/softwords/softcore.fr
|
|
\ ** FICL soft extensions
|
|
\ ** John Sadler (john_sadler@alum.mit.edu)
|
|
\ ** September, 1998
|
|
|
|
\ ** Ficl USER variables
|
|
\ ** See words.c for primitive def'n of USER
|
|
\ #if FICL_WANT_USER
|
|
|
|
variable nUser 0 nUser !
|
|
: user \ name ( -- )
|
|
nUser dup @ user 1 swap +! ;
|
|
|
|
\ #endif
|
|
|
|
\ ** ficl extras
|
|
\ EMPTY cleans the parameter stack
|
|
: empty ( xn..x1 -- ) depth 0 ?do drop loop ;
|
|
\ CELL- undoes CELL+
|
|
: cell- ( addr -- addr ) [ 1 cells ] literal - ;
|
|
: -rot ( a b c -- c a b ) 2 -roll ;
|
|
|
|
\ ** CORE
|
|
: abs ( x -- x )
|
|
dup 0< if negate endif ;
|
|
decimal 32 constant bl
|
|
|
|
: space ( -- ) bl emit ;
|
|
|
|
: spaces ( n -- ) 0 ?do space loop ;
|
|
|
|
: abort"
|
|
postpone if
|
|
postpone ."
|
|
postpone cr
|
|
-2
|
|
postpone literal
|
|
postpone throw
|
|
postpone endif
|
|
; immediate
|
|
|
|
|
|
\ ** CORE EXT
|
|
0 constant false
|
|
-1 constant true
|
|
: <> = invert ;
|
|
: 0<> 0= invert ;
|
|
: compile, , ;
|
|
: erase ( addr u -- ) 0 fill ;
|
|
: nip ( y x -- x ) swap drop ;
|
|
: tuck ( y x -- x y x) swap over ;
|
|
|
|
\ ** LOCAL EXT word set
|
|
\ #if FICL_WANT_LOCALS
|
|
: locals| ( name...name | -- )
|
|
begin
|
|
bl word count
|
|
dup 0= abort" where's the delimiter??"
|
|
over c@
|
|
[char] | - over 1- or
|
|
while
|
|
(local)
|
|
repeat 2drop 0 0 (local)
|
|
; immediate
|
|
|
|
: local ( name -- ) bl word count (local) ; immediate
|
|
|
|
: end-locals ( -- ) 0 0 (local) ; immediate
|
|
|
|
\ #endif
|
|
|
|
\ ** TOOLS word set...
|
|
: ? ( addr -- ) @ . ;
|
|
: dump ( addr u -- )
|
|
0 ?do
|
|
dup c@ . 1+
|
|
i 7 and 7 = if cr endif
|
|
loop drop
|
|
;
|
|
|
|
\ ** Some TOOLS EXT words, straight from the standard
|
|
: [else] ( -- )
|
|
1 begin \ level
|
|
begin
|
|
bl word count dup while \ level adr len
|
|
2dup s" [IF]" compare 0= >r
|
|
2dup s" [if]" compare 0= r> or
|
|
if \ level adr len
|
|
2drop 1+ \ level'
|
|
else \ level adr len
|
|
2dup s" [ELSE]" compare 0= >r
|
|
2dup s" [else]" compare 0= r> or
|
|
if \ level adr len
|
|
2drop 1- dup if 1+ then \ level'
|
|
else \ level adr len
|
|
2dup
|
|
s" [THEN]" compare 0= >r \ level adr len
|
|
s" [then]" compare 0= r> or
|
|
if \ level
|
|
1- \ level'
|
|
then
|
|
then
|
|
then ?dup 0= if exit then \ level'
|
|
repeat 2drop \ level
|
|
refill 0= until \ level
|
|
drop
|
|
; immediate
|
|
|
|
: [if] ( flag -- )
|
|
0= if postpone [else] then ; immediate
|
|
|
|
: [then] ( -- ) ; immediate
|
|
\ ** SEARCH+EXT words and ficl helpers
|
|
\
|
|
: wordlist ( -- )
|
|
1 ficl-wordlist ;
|
|
|
|
\ DO_VOCABULARY handles the DOES> part of a VOCABULARY
|
|
\ When executed, new voc replaces top of search stack
|
|
: do-vocabulary ( -- )
|
|
does> @ search> drop >search ;
|
|
|
|
: vocabulary ( name -- )
|
|
wordlist create , do-vocabulary ;
|
|
|
|
: ficl-vocabulary ( nBuckets name -- )
|
|
ficl-wordlist create , do-vocabulary ;
|
|
|
|
\ ALSO dups the search stack...
|
|
: also ( -- )
|
|
search> dup >search >search ;
|
|
|
|
\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
|
|
: forth ( -- )
|
|
search> drop
|
|
forth-wordlist >search ;
|
|
|
|
\ ONLY sets the search order to a default state
|
|
: only ( -- )
|
|
-1 set-order ;
|
|
|
|
\ ORDER displays the compile wid and the search order list
|
|
: order ( -- )
|
|
." Search: "
|
|
get-order 0 ?do x. loop cr
|
|
." Compile: " get-current x. cr ;
|
|
|
|
\ PREVIOUS drops the search order stack
|
|
: previous ( -- ) search> drop ;
|
|
|
|
\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
|
|
: ficl-set-current ( wid -- old-wid )
|
|
get-current swap set-current ;
|
|
|
|
wordlist constant hidden
|
|
: hide hidden dup >search ficl-set-current ;
|
|
|
|
\ ** E N D S O F T C O R E . F R
|
|
|