140843Smsmith\ ** ficl/softwords/softcore.fr 240843Smsmith\ ** FICL soft extensions 340843Smsmith\ ** John Sadler (john_sadler@alum.mit.edu) 440843Smsmith\ ** September, 1998 594290Sdcs\ 651786Sdcs\ $FreeBSD: releng/11.0/sys/boot/ficl/softwords/softcore.fr 94290 2002-04-09 17:45:28Z dcs $ 751786Sdcs 840843Smsmith\ ** Ficl USER variables 940843Smsmith\ ** See words.c for primitive def'n of USER 1040843Smsmith\ #if FICL_WANT_USER 1140843Smsmithvariable nUser 0 nUser ! 1240843Smsmith: user \ name ( -- ) 1340843Smsmith nUser dup @ user 1 swap +! ; 1440843Smsmith 1540843Smsmith\ #endif 1640843Smsmith 1740843Smsmith\ ** ficl extras 1840843Smsmith\ EMPTY cleans the parameter stack 1940843Smsmith: empty ( xn..x1 -- ) depth 0 ?do drop loop ; 2040843Smsmith\ CELL- undoes CELL+ 2140843Smsmith: cell- ( addr -- addr ) [ 1 cells ] literal - ; 2240843Smsmith: -rot ( a b c -- c a b ) 2 -roll ; 2340843Smsmith 2440843Smsmith\ ** CORE 2540843Smsmith: abs ( x -- x ) 2640843Smsmith dup 0< if negate endif ; 2740843Smsmithdecimal 32 constant bl 2840843Smsmith 2940843Smsmith: space ( -- ) bl emit ; 3040843Smsmith 3140843Smsmith: spaces ( n -- ) 0 ?do space loop ; 3240843Smsmith 3376116Sdcs: abort" 3461584Sdcs state @ if 3561584Sdcs postpone if 3676116Sdcs postpone ." 3761584Sdcs postpone cr 3861584Sdcs -2 3961584Sdcs postpone literal 4061584Sdcs postpone throw 4161584Sdcs postpone endif 4261584Sdcs else 4376116Sdcs [char] " parse 4461584Sdcs rot if 4561584Sdcs type 4661584Sdcs cr 4761584Sdcs -2 throw 4876116Sdcs else 4976116Sdcs 2drop 5076116Sdcs endif 5176116Sdcs endif 5261584Sdcs; immediate 5340843Smsmith 5440843Smsmith 5540843Smsmith\ ** CORE EXT 5676116Sdcs0 constant false 5776116Sdcsfalse invert constant true 5856718Sdcs: <> = 0= ; 5956718Sdcs: 0<> 0= 0= ; 6040843Smsmith: compile, , ; 6194290Sdcs: convert char+ 65535 >number drop ; \ cribbed from DPANS A.6.2.0970 6240843Smsmith: erase ( addr u -- ) 0 fill ; 6394290Sdcsvariable span 6494290Sdcs: expect ( c-addr u1 -- ) accept span ! ; 6594290Sdcs\ see marker.fr for MARKER implementation 6640843Smsmith: nip ( y x -- x ) swap drop ; 6740843Smsmith: tuck ( y x -- x y x) swap over ; 6851786Sdcs: within ( test low high -- flag ) over - >r - r> u< ; 6940843Smsmith 7051786Sdcs 7140843Smsmith\ ** LOCAL EXT word set 7240843Smsmith\ #if FICL_WANT_LOCALS 7340843Smsmith: locals| ( name...name | -- ) 7440843Smsmith begin 7540843Smsmith bl word count 7640843Smsmith dup 0= abort" where's the delimiter??" 7740843Smsmith over c@ 7840843Smsmith [char] | - over 1- or 7940843Smsmith while 8040843Smsmith (local) 8140843Smsmith repeat 2drop 0 0 (local) 8240843Smsmith; immediate 8340843Smsmith 8440843Smsmith: local ( name -- ) bl word count (local) ; immediate 8540843Smsmith 8660959Sdcs: 2local ( name -- ) bl word count (2local) ; immediate 8760959Sdcs 8840843Smsmith: end-locals ( -- ) 0 0 (local) ; immediate 8940843Smsmith 9040843Smsmith\ #endif 9140843Smsmith 9240843Smsmith\ ** TOOLS word set... 9340843Smsmith: ? ( addr -- ) @ . ; 9440843Smsmith: dump ( addr u -- ) 9540843Smsmith 0 ?do 9640843Smsmith dup c@ . 1+ 9740843Smsmith i 7 and 7 = if cr endif 9840843Smsmith loop drop 9940843Smsmith; 10040843Smsmith 10140843Smsmith\ ** SEARCH+EXT words and ficl helpers 10276116Sdcs\ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom: 10376116Sdcs\ wordlist dup create , brand-wordlist 10476116Sdcs\ gets the name of the word made by create and applies it to the wordlist... 10576116Sdcs: brand-wordlist ( wid -- ) last-word >name drop wid-set-name ; 10676116Sdcs 10776116Sdcs: ficl-named-wordlist \ ( hash-size name -- ) run: ( -- wid ) 10876116Sdcs ficl-wordlist dup create , brand-wordlist does> @ ; 10976116Sdcs 11040843Smsmith: wordlist ( -- ) 11140843Smsmith 1 ficl-wordlist ; 11240843Smsmith 11376116Sdcs\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value 11476116Sdcs: ficl-set-current ( wid -- old-wid ) 11576116Sdcs get-current swap set-current ; 11676116Sdcs 11740843Smsmith\ DO_VOCABULARY handles the DOES> part of a VOCABULARY 11840843Smsmith\ When executed, new voc replaces top of search stack 11940843Smsmith: do-vocabulary ( -- ) 12040843Smsmith does> @ search> drop >search ; 12140843Smsmith 12276116Sdcs: ficl-vocabulary ( nBuckets name -- ) 12376116Sdcs ficl-named-wordlist do-vocabulary ; 12476116Sdcs 12540843Smsmith: vocabulary ( name -- ) 12676116Sdcs 1 ficl-vocabulary ; 12740843Smsmith 12876116Sdcs\ PREVIOUS drops the search order stack 12976116Sdcs: previous ( -- ) search> drop ; 13040843Smsmith 13176116Sdcs\ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace 13276116Sdcs\ USAGE: 13376116Sdcs\ hide 13476116Sdcs\ <definitions to hide> 13576116Sdcs\ set-current 13676116Sdcs\ <words that use hidden defs> 13776116Sdcs\ previous ( pop HIDDEN off the search order ) 13876116Sdcs 13976116Sdcs1 ficl-named-wordlist hidden 14076116Sdcs: hide hidden dup >search ficl-set-current ; 14176116Sdcs 14240843Smsmith\ ALSO dups the search stack... 14340843Smsmith: also ( -- ) 14440843Smsmith search> dup >search >search ; 14540843Smsmith 14640843Smsmith\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST 14740843Smsmith: forth ( -- ) 14840843Smsmith search> drop 14940843Smsmith forth-wordlist >search ; 15040843Smsmith 15140843Smsmith\ ONLY sets the search order to a default state 15240843Smsmith: only ( -- ) 15340843Smsmith -1 set-order ; 15440843Smsmith 15540843Smsmith\ ORDER displays the compile wid and the search order list 15676116Sdcshide 15776116Sdcs: list-wid ( wid -- ) 15876116Sdcs dup wid-get-name ( wid c-addr u ) 15976116Sdcs ?dup if 16076116Sdcs type drop 16176116Sdcs else 16276116Sdcs drop ." (unnamed wid) " x. 16376116Sdcs endif cr 16476116Sdcs; 16576116Sdcsset-current \ stop hiding words 16676116Sdcs 16740843Smsmith: order ( -- ) 16876116Sdcs ." Search:" cr 16976116Sdcs get-order 0 ?do 3 spaces list-wid loop cr 17076116Sdcs ." Compile: " get-current list-wid cr 17176116Sdcs; 17240843Smsmith 17394290Sdcs: debug ' debug-xt ; immediate 17494290Sdcs: on-step ." S: " .s cr ; 17540843Smsmith 17694290Sdcs 17794290Sdcs\ Submitted by lch. 17894290Sdcs: strdup ( c-addr length -- c-addr2 length2 ior ) 17994290Sdcs 0 locals| addr2 length c-addr | end-locals 18094290Sdcs length 1 + allocate 18194290Sdcs 0= if 18294290Sdcs to addr2 18394290Sdcs c-addr addr2 length move 18494290Sdcs addr2 length 0 18594290Sdcs else 18694290Sdcs 0 -1 18794290Sdcs endif 18894290Sdcs ; 18994290Sdcs 19094290Sdcs: strcat ( 2:a 2:b -- 2:new-a ) 19194290Sdcs 0 locals| b-length b-u b-addr a-u a-addr | end-locals 19294290Sdcs b-u to b-length 19394290Sdcs b-addr a-addr a-u + b-length move 19494290Sdcs a-addr a-u b-length + 19594290Sdcs ; 19694290Sdcs 19794290Sdcs: strcpy ( 2:a 2:b -- 2:new-a ) 19894290Sdcs locals| b-u b-addr a-u a-addr | end-locals 19994290Sdcs a-addr 0 b-addr b-u strcat 20094290Sdcs ; 20194290Sdcs 20294290Sdcs 20376116Sdcsprevious \ lose hidden words from search order 20440843Smsmith 20540843Smsmith\ ** E N D S O F T C O R E . F R 20640843Smsmith 207