softcore.fr revision 51786
140843Smsmith\ ** ficl/softwords/softcore.fr 240843Smsmith\ ** FICL soft extensions 340843Smsmith\ ** John Sadler (john_sadler@alum.mit.edu) 440843Smsmith\ ** September, 1998 540843Smsmith 651786Sdcs\ $FreeBSD: head/sys/boot/ficl/softwords/softcore.fr 51786 1999-09-29 04:43:16Z dcs $ 751786Sdcs 840843Smsmith\ ** Ficl USER variables 940843Smsmith\ ** See words.c for primitive def'n of USER 1040843Smsmith\ #if FICL_WANT_USER 1140843Smsmith 1240843Smsmithvariable nUser 0 nUser ! 1340843Smsmith: user \ name ( -- ) 1440843Smsmith nUser dup @ user 1 swap +! ; 1540843Smsmith 1640843Smsmith\ #endif 1740843Smsmith 1840843Smsmith\ ** ficl extras 1940843Smsmith\ EMPTY cleans the parameter stack 2040843Smsmith: empty ( xn..x1 -- ) depth 0 ?do drop loop ; 2140843Smsmith\ CELL- undoes CELL+ 2240843Smsmith: cell- ( addr -- addr ) [ 1 cells ] literal - ; 2340843Smsmith: -rot ( a b c -- c a b ) 2 -roll ; 2440843Smsmith 2540843Smsmith\ ** CORE 2640843Smsmith: abs ( x -- x ) 2740843Smsmith dup 0< if negate endif ; 2840843Smsmithdecimal 32 constant bl 2940843Smsmith 3040843Smsmith: space ( -- ) bl emit ; 3140843Smsmith 3240843Smsmith: spaces ( n -- ) 0 ?do space loop ; 3340843Smsmith 3440843Smsmith: abort" 3540843Smsmith postpone if 3640843Smsmith postpone ." 3740843Smsmith postpone cr 3843078Smsmith -2 3943078Smsmith postpone literal 4043078Smsmith postpone throw 4140843Smsmith postpone endif 4240843Smsmith; immediate 4340843Smsmith 4440843Smsmith 4540843Smsmith\ ** CORE EXT 4640843Smsmith0 constant false 4740843Smsmith-1 constant true 4840843Smsmith: <> = invert ; 4940843Smsmith: 0<> 0= invert ; 5040843Smsmith: compile, , ; 5140843Smsmith: erase ( addr u -- ) 0 fill ; 5240843Smsmith: nip ( y x -- x ) swap drop ; 5340843Smsmith: tuck ( y x -- x y x) swap over ; 5451786Sdcs: within ( test low high -- flag ) over - >r - r> u< ; 5540843Smsmith 5651786Sdcs 5740843Smsmith\ ** LOCAL EXT word set 5840843Smsmith\ #if FICL_WANT_LOCALS 5940843Smsmith: locals| ( name...name | -- ) 6040843Smsmith begin 6140843Smsmith bl word count 6240843Smsmith dup 0= abort" where's the delimiter??" 6340843Smsmith over c@ 6440843Smsmith [char] | - over 1- or 6540843Smsmith while 6640843Smsmith (local) 6740843Smsmith repeat 2drop 0 0 (local) 6840843Smsmith; immediate 6940843Smsmith 7040843Smsmith: local ( name -- ) bl word count (local) ; immediate 7140843Smsmith 7240843Smsmith: end-locals ( -- ) 0 0 (local) ; immediate 7340843Smsmith 7440843Smsmith\ #endif 7540843Smsmith 7640843Smsmith\ ** TOOLS word set... 7740843Smsmith: ? ( addr -- ) @ . ; 7840843Smsmith: dump ( addr u -- ) 7940843Smsmith 0 ?do 8040843Smsmith dup c@ . 1+ 8140843Smsmith i 7 and 7 = if cr endif 8240843Smsmith loop drop 8340843Smsmith; 8440843Smsmith 8540843Smsmith\ ** SEARCH+EXT words and ficl helpers 8640843Smsmith\ 8740843Smsmith: wordlist ( -- ) 8840843Smsmith 1 ficl-wordlist ; 8940843Smsmith 9040843Smsmith\ DO_VOCABULARY handles the DOES> part of a VOCABULARY 9140843Smsmith\ When executed, new voc replaces top of search stack 9240843Smsmith: do-vocabulary ( -- ) 9340843Smsmith does> @ search> drop >search ; 9440843Smsmith 9540843Smsmith: vocabulary ( name -- ) 9640843Smsmith wordlist create , do-vocabulary ; 9740843Smsmith 9840843Smsmith: ficl-vocabulary ( nBuckets name -- ) 9940843Smsmith ficl-wordlist create , do-vocabulary ; 10040843Smsmith 10140843Smsmith\ ALSO dups the search stack... 10240843Smsmith: also ( -- ) 10340843Smsmith search> dup >search >search ; 10440843Smsmith 10540843Smsmith\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST 10640843Smsmith: forth ( -- ) 10740843Smsmith search> drop 10840843Smsmith forth-wordlist >search ; 10940843Smsmith 11040843Smsmith\ ONLY sets the search order to a default state 11140843Smsmith: only ( -- ) 11240843Smsmith -1 set-order ; 11340843Smsmith 11440843Smsmith\ ORDER displays the compile wid and the search order list 11540843Smsmith: order ( -- ) 11640843Smsmith ." Search: " 11740843Smsmith get-order 0 ?do x. loop cr 11840843Smsmith ." Compile: " get-current x. cr ; 11940843Smsmith 12040843Smsmith\ PREVIOUS drops the search order stack 12140843Smsmith: previous ( -- ) search> drop ; 12240843Smsmith 12340843Smsmith\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value 12440843Smsmith: ficl-set-current ( wid -- old-wid ) 12540843Smsmith get-current swap set-current ; 12640843Smsmith 12740843Smsmithwordlist constant hidden 12840843Smsmith: hide hidden dup >search ficl-set-current ; 12940843Smsmith 13040843Smsmith\ ** E N D S O F T C O R E . F R 13140843Smsmith 132