softcore.fr revision 76116
1\ ** ficl/softwords/softcore.fr 2\ ** FICL soft extensions 3\ ** John Sadler (john_sadler@alum.mit.edu) 4\ ** September, 1998 5 6\ $FreeBSD: head/sys/boot/ficl/softwords/softcore.fr 76116 2001-04-29 02:36:36Z dcs $ 7 8\ ** Ficl USER variables 9\ ** See words.c for primitive def'n of USER 10 11\ #if FICL_WANT_USER 12variable nUser 0 nUser ! 13: user \ name ( -- ) 14 nUser dup @ user 1 swap +! ; 15 16\ #endif 17 18\ ** ficl extras 19\ EMPTY cleans the parameter stack 20: empty ( xn..x1 -- ) depth 0 ?do drop loop ; 21\ CELL- undoes CELL+ 22: cell- ( addr -- addr ) [ 1 cells ] literal - ; 23: -rot ( a b c -- c a b ) 2 -roll ; 24 25\ ** CORE 26: abs ( x -- x ) 27 dup 0< if negate endif ; 28decimal 32 constant bl 29 30: space ( -- ) bl emit ; 31 32: spaces ( n -- ) 0 ?do space loop ; 33 34: abort" 35 state @ if 36 postpone if 37 postpone ." 38\ postpone type 39 postpone cr 40 -2 41 postpone literal 42 postpone throw 43 postpone endif 44 else 45 [char] " parse 46 rot if 47 type 48 cr 49 -2 throw 50 else 51 2drop 52 endif 53 endif 54; immediate 55 56 57\ ** CORE EXT 580 constant false 59false invert constant true 60: <> = 0= ; 61: 0<> 0= 0= ; 62: compile, , ; 63: erase ( addr u -- ) 0 fill ; 64: nip ( y x -- x ) swap drop ; 65: tuck ( y x -- x y x) swap over ; 66: within ( test low high -- flag ) over - >r - r> u< ; 67 68 69\ ** LOCAL EXT word set 70\ #if FICL_WANT_LOCALS 71: locals| ( name...name | -- ) 72 begin 73 bl word count 74 dup 0= abort" where's the delimiter??" 75 over c@ 76 [char] | - over 1- or 77 while 78 (local) 79 repeat 2drop 0 0 (local) 80; immediate 81 82: local ( name -- ) bl word count (local) ; immediate 83 84: 2local ( name -- ) bl word count (2local) ; immediate 85 86: end-locals ( -- ) 0 0 (local) ; immediate 87 88\ #endif 89 90\ ** TOOLS word set... 91: ? ( addr -- ) @ . ; 92: dump ( addr u -- ) 93 0 ?do 94 dup c@ . 1+ 95 i 7 and 7 = if cr endif 96 loop drop 97; 98 99\ ** SEARCH+EXT words and ficl helpers 100\ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom: 101\ wordlist dup create , brand-wordlist 102\ gets the name of the word made by create and applies it to the wordlist... 103: brand-wordlist ( wid -- ) last-word >name drop wid-set-name ; 104 105: ficl-named-wordlist \ ( hash-size name -- ) run: ( -- wid ) 106 ficl-wordlist dup create , brand-wordlist does> @ ; 107 108: wordlist ( -- ) 109 1 ficl-wordlist ; 110 111\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value 112: ficl-set-current ( wid -- old-wid ) 113 get-current swap set-current ; 114 115\ DO_VOCABULARY handles the DOES> part of a VOCABULARY 116\ When executed, new voc replaces top of search stack 117: do-vocabulary ( -- ) 118 does> @ search> drop >search ; 119 120: ficl-vocabulary ( nBuckets name -- ) 121 ficl-named-wordlist do-vocabulary ; 122 123: vocabulary ( name -- ) 124 1 ficl-vocabulary ; 125 126\ PREVIOUS drops the search order stack 127: previous ( -- ) search> drop ; 128 129\ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace 130\ USAGE: 131\ hide 132\ <definitions to hide> 133\ set-current 134\ <words that use hidden defs> 135\ previous ( pop HIDDEN off the search order ) 136 1371 ficl-named-wordlist hidden 138: hide hidden dup >search ficl-set-current ; 139 140\ ALSO dups the search stack... 141: also ( -- ) 142 search> dup >search >search ; 143 144\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST 145: forth ( -- ) 146 search> drop 147 forth-wordlist >search ; 148 149\ ONLY sets the search order to a default state 150: only ( -- ) 151 -1 set-order ; 152 153\ ORDER displays the compile wid and the search order list 154hide 155: list-wid ( wid -- ) 156 dup wid-get-name ( wid c-addr u ) 157 ?dup if 158 type drop 159 else 160 drop ." (unnamed wid) " x. 161 endif cr 162; 163set-current \ stop hiding words 164 165: order ( -- ) 166 ." Search:" cr 167 get-order 0 ?do 3 spaces list-wid loop cr 168 ." Compile: " get-current list-wid cr 169; 170 171: debug ' debug-xt ; 172 173previous \ lose hidden words from search order 174 175\ ** E N D S O F T C O R E . F R 176 177