softcore.fr revision 60959
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 60959 2000-05-26 21:35:08Z 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 4856718Sdcs: <> = 0= ; 4956718Sdcs: 0<> 0= 0= ; 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 7260959Sdcs: 2local ( name -- ) bl word count (2local) ; immediate 7360959Sdcs 7440843Smsmith: end-locals ( -- ) 0 0 (local) ; immediate 7540843Smsmith 7640843Smsmith\ #endif 7740843Smsmith 7840843Smsmith\ ** TOOLS word set... 7940843Smsmith: ? ( addr -- ) @ . ; 8040843Smsmith: dump ( addr u -- ) 8140843Smsmith 0 ?do 8240843Smsmith dup c@ . 1+ 8340843Smsmith i 7 and 7 = if cr endif 8440843Smsmith loop drop 8540843Smsmith; 8640843Smsmith 8740843Smsmith\ ** SEARCH+EXT words and ficl helpers 8840843Smsmith\ 8940843Smsmith: wordlist ( -- ) 9040843Smsmith 1 ficl-wordlist ; 9140843Smsmith 9240843Smsmith\ DO_VOCABULARY handles the DOES> part of a VOCABULARY 9340843Smsmith\ When executed, new voc replaces top of search stack 9440843Smsmith: do-vocabulary ( -- ) 9540843Smsmith does> @ search> drop >search ; 9640843Smsmith 9740843Smsmith: vocabulary ( name -- ) 9840843Smsmith wordlist create , do-vocabulary ; 9940843Smsmith 10040843Smsmith: ficl-vocabulary ( nBuckets name -- ) 10140843Smsmith ficl-wordlist create , do-vocabulary ; 10240843Smsmith 10340843Smsmith\ ALSO dups the search stack... 10440843Smsmith: also ( -- ) 10540843Smsmith search> dup >search >search ; 10640843Smsmith 10740843Smsmith\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST 10840843Smsmith: forth ( -- ) 10940843Smsmith search> drop 11040843Smsmith forth-wordlist >search ; 11140843Smsmith 11240843Smsmith\ ONLY sets the search order to a default state 11340843Smsmith: only ( -- ) 11440843Smsmith -1 set-order ; 11540843Smsmith 11640843Smsmith\ ORDER displays the compile wid and the search order list 11740843Smsmith: order ( -- ) 11840843Smsmith ." Search: " 11940843Smsmith get-order 0 ?do x. loop cr 12040843Smsmith ." Compile: " get-current x. cr ; 12140843Smsmith 12240843Smsmith\ PREVIOUS drops the search order stack 12340843Smsmith: previous ( -- ) search> drop ; 12440843Smsmith 12540843Smsmith\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value 12640843Smsmith: ficl-set-current ( wid -- old-wid ) 12740843Smsmith get-current swap set-current ; 12840843Smsmith 12940843Smsmithwordlist constant hidden 13040843Smsmith: hide hidden dup >search ficl-set-current ; 13140843Smsmith 13240843Smsmith\ ** E N D S O F T C O R E . F R 13340843Smsmith 134