softcore.fr revision 76116
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 76116 2001-04-29 02:36:36Z dcs $ 751786Sdcs 840843Smsmith\ ** Ficl USER variables 940843Smsmith\ ** See words.c for primitive def'n of USER 1076116Sdcs 1140843Smsmith\ #if FICL_WANT_USER 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 3476116Sdcs: abort" 3561584Sdcs state @ if 3661584Sdcs postpone if 3776116Sdcs postpone ." 3876116Sdcs\ postpone type 3961584Sdcs postpone cr 4061584Sdcs -2 4161584Sdcs postpone literal 4261584Sdcs postpone throw 4361584Sdcs postpone endif 4461584Sdcs else 4576116Sdcs [char] " parse 4661584Sdcs rot if 4761584Sdcs type 4861584Sdcs cr 4961584Sdcs -2 throw 5076116Sdcs else 5176116Sdcs 2drop 5276116Sdcs endif 5376116Sdcs endif 5461584Sdcs; immediate 5540843Smsmith 5640843Smsmith 5740843Smsmith\ ** CORE EXT 5876116Sdcs0 constant false 5976116Sdcsfalse invert constant true 6056718Sdcs: <> = 0= ; 6156718Sdcs: 0<> 0= 0= ; 6240843Smsmith: compile, , ; 6340843Smsmith: erase ( addr u -- ) 0 fill ; 6440843Smsmith: nip ( y x -- x ) swap drop ; 6540843Smsmith: tuck ( y x -- x y x) swap over ; 6651786Sdcs: within ( test low high -- flag ) over - >r - r> u< ; 6740843Smsmith 6851786Sdcs 6940843Smsmith\ ** LOCAL EXT word set 7040843Smsmith\ #if FICL_WANT_LOCALS 7140843Smsmith: locals| ( name...name | -- ) 7240843Smsmith begin 7340843Smsmith bl word count 7440843Smsmith dup 0= abort" where's the delimiter??" 7540843Smsmith over c@ 7640843Smsmith [char] | - over 1- or 7740843Smsmith while 7840843Smsmith (local) 7940843Smsmith repeat 2drop 0 0 (local) 8040843Smsmith; immediate 8140843Smsmith 8240843Smsmith: local ( name -- ) bl word count (local) ; immediate 8340843Smsmith 8460959Sdcs: 2local ( name -- ) bl word count (2local) ; immediate 8560959Sdcs 8640843Smsmith: end-locals ( -- ) 0 0 (local) ; immediate 8740843Smsmith 8840843Smsmith\ #endif 8940843Smsmith 9040843Smsmith\ ** TOOLS word set... 9140843Smsmith: ? ( addr -- ) @ . ; 9240843Smsmith: dump ( addr u -- ) 9340843Smsmith 0 ?do 9440843Smsmith dup c@ . 1+ 9540843Smsmith i 7 and 7 = if cr endif 9640843Smsmith loop drop 9740843Smsmith; 9840843Smsmith 9940843Smsmith\ ** SEARCH+EXT words and ficl helpers 10076116Sdcs\ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom: 10176116Sdcs\ wordlist dup create , brand-wordlist 10276116Sdcs\ gets the name of the word made by create and applies it to the wordlist... 10376116Sdcs: brand-wordlist ( wid -- ) last-word >name drop wid-set-name ; 10476116Sdcs 10576116Sdcs: ficl-named-wordlist \ ( hash-size name -- ) run: ( -- wid ) 10676116Sdcs ficl-wordlist dup create , brand-wordlist does> @ ; 10776116Sdcs 10840843Smsmith: wordlist ( -- ) 10940843Smsmith 1 ficl-wordlist ; 11040843Smsmith 11176116Sdcs\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value 11276116Sdcs: ficl-set-current ( wid -- old-wid ) 11376116Sdcs get-current swap set-current ; 11476116Sdcs 11540843Smsmith\ DO_VOCABULARY handles the DOES> part of a VOCABULARY 11640843Smsmith\ When executed, new voc replaces top of search stack 11740843Smsmith: do-vocabulary ( -- ) 11840843Smsmith does> @ search> drop >search ; 11940843Smsmith 12076116Sdcs: ficl-vocabulary ( nBuckets name -- ) 12176116Sdcs ficl-named-wordlist do-vocabulary ; 12276116Sdcs 12340843Smsmith: vocabulary ( name -- ) 12476116Sdcs 1 ficl-vocabulary ; 12540843Smsmith 12676116Sdcs\ PREVIOUS drops the search order stack 12776116Sdcs: previous ( -- ) search> drop ; 12840843Smsmith 12976116Sdcs\ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace 13076116Sdcs\ USAGE: 13176116Sdcs\ hide 13276116Sdcs\ <definitions to hide> 13376116Sdcs\ set-current 13476116Sdcs\ <words that use hidden defs> 13576116Sdcs\ previous ( pop HIDDEN off the search order ) 13676116Sdcs 13776116Sdcs1 ficl-named-wordlist hidden 13876116Sdcs: hide hidden dup >search ficl-set-current ; 13976116Sdcs 14040843Smsmith\ ALSO dups the search stack... 14140843Smsmith: also ( -- ) 14240843Smsmith search> dup >search >search ; 14340843Smsmith 14440843Smsmith\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST 14540843Smsmith: forth ( -- ) 14640843Smsmith search> drop 14740843Smsmith forth-wordlist >search ; 14840843Smsmith 14940843Smsmith\ ONLY sets the search order to a default state 15040843Smsmith: only ( -- ) 15140843Smsmith -1 set-order ; 15240843Smsmith 15340843Smsmith\ ORDER displays the compile wid and the search order list 15476116Sdcshide 15576116Sdcs: list-wid ( wid -- ) 15676116Sdcs dup wid-get-name ( wid c-addr u ) 15776116Sdcs ?dup if 15876116Sdcs type drop 15976116Sdcs else 16076116Sdcs drop ." (unnamed wid) " x. 16176116Sdcs endif cr 16276116Sdcs; 16376116Sdcsset-current \ stop hiding words 16476116Sdcs 16540843Smsmith: order ( -- ) 16676116Sdcs ." Search:" cr 16776116Sdcs get-order 0 ?do 3 spaces list-wid loop cr 16876116Sdcs ." Compile: " get-current list-wid cr 16976116Sdcs; 17040843Smsmith 17176116Sdcs: debug ' debug-xt ; 17240843Smsmith 17376116Sdcsprevious \ lose hidden words from search order 17440843Smsmith 17540843Smsmith\ ** E N D S O F T C O R E . F R 17640843Smsmith 177