1\ ** ficl/softwords/softcore.fr 2\ ** FICL soft extensions 3\ ** John Sadler (john_sadler@alum.mit.edu) 4\ ** September, 1998 5\ 6 7\ ** Ficl USER variables 8\ ** See words.c for primitive def'n of USER 9\ #if FICL_WANT_USER 10variable nUser 0 nUser ! 11: user \ name ( -- ) 12 nUser dup @ user 1 swap +! ; 13 14\ #endif 15 16\ ** ficl extras 17\ EMPTY cleans the parameter stack 18: empty ( xn..x1 -- ) depth 0 ?do drop loop ; 19\ CELL- undoes CELL+ 20: cell- ( addr -- addr ) [ 1 cells ] literal - ; 21: -rot ( a b c -- c a b ) 2 -roll ; 22 23\ ** CORE 24: abs ( x -- x ) 25 dup 0< if negate endif ; 26decimal 32 constant bl 27 28: space ( -- ) bl emit ; 29 30: spaces ( n -- ) 0 ?do space loop ; 31 32: abort" 33 state @ if 34 postpone if 35 postpone ." 36 postpone cr 37 -2 38 postpone literal 39 postpone throw 40 postpone endif 41 else 42 [char] " parse 43 rot if 44 type 45 cr 46 -2 throw 47 else 48 2drop 49 endif 50 endif 51; immediate 52 53 54\ ** CORE EXT 550 constant false 56false invert constant true 57: <> = 0= ; 58: 0<> 0= 0= ; 59: compile, , ; 60: convert char+ 65535 >number drop ; \ cribbed from DPANS A.6.2.0970 61: erase ( addr u -- ) 0 fill ; 62variable span 63: expect ( c-addr u1 -- ) accept span ! ; 64\ see marker.fr for MARKER implementation 65: nip ( y x -- x ) swap drop ; 66: tuck ( y x -- x y x) swap over ; 67: within ( test low high -- flag ) over - >r - r> u< ; 68 69: u.r ( n +n -- ) 70 swap 0 <# #s #> 71 rot over - dup 0< if 72 drop else spaces 73 then 74 type space ; 75 76\ ** LOCAL EXT word set 77\ #if FICL_WANT_LOCALS 78: locals| ( name...name | -- ) 79 begin 80 bl word count 81 dup 0= abort" where's the delimiter??" 82 over c@ 83 [char] | - over 1- or 84 while 85 (local) 86 repeat 2drop 0 0 (local) 87; immediate 88 89: local ( name -- ) bl word count (local) ; immediate 90 91: 2local ( name -- ) bl word count (2local) ; immediate 92 93: end-locals ( -- ) 0 0 (local) ; immediate 94 95\ #endif 96 97\ ** TOOLS word set... 98: ? ( addr -- ) @ . ; 99 100Variable /dump 101 102: i' ( R:w R:w2 -- R:w R:w2 w ) 103 r> r> r> dup >r swap >r swap >r ; 104 105: .4 ( addr -- addr' ) 106 4 0 DO -1 /dump +! /dump @ 0< 107 IF 3 spaces ELSE dup c@ 0 <# # # #> type space THEN 108 char+ LOOP ; 109 110: .chars ( addr -- ) 111 /dump @ over + swap 112 ?DO I c@ dup 127 bl within 113 IF drop [char] . THEN emit 114 LOOP ; 115 116: .line ( addr -- ) 117 dup .4 space .4 ." - " .4 space .4 drop 16 /dump +! space .chars ; 118 119: dump ( addr u -- ) \ tools dump 120 cr base @ >r hex \ save base on return stack 121 0 ?DO I' I - 16 min /dump ! 122 dup 8 u.r ." : " dup .line cr 16 + 123 16 +LOOP 124 drop r> base ! ; 125 126\ ** SEARCH+EXT words and ficl helpers 127\ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom: 128\ wordlist dup create , brand-wordlist 129\ gets the name of the word made by create and applies it to the wordlist... 130: brand-wordlist ( wid -- ) last-word >name drop wid-set-name ; 131 132: ficl-named-wordlist \ ( hash-size name -- ) run: ( -- wid ) 133 ficl-wordlist dup create , brand-wordlist does> @ ; 134 135: wordlist ( -- ) 136 1 ficl-wordlist ; 137 138\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value 139: ficl-set-current ( wid -- old-wid ) 140 get-current swap set-current ; 141 142\ DO_VOCABULARY handles the DOES> part of a VOCABULARY 143\ When executed, new voc replaces top of search stack 144: do-vocabulary ( -- ) 145 does> @ search> drop >search ; 146 147: ficl-vocabulary ( nBuckets name -- ) 148 ficl-named-wordlist do-vocabulary ; 149 150: vocabulary ( name -- ) 151 1 ficl-vocabulary ; 152 153\ PREVIOUS drops the search order stack 154: previous ( -- ) search> drop ; 155 156\ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace 157\ USAGE: 158\ hide 159\ <definitions to hide> 160\ set-current 161\ <words that use hidden defs> 162\ previous ( pop HIDDEN off the search order ) 163 1641 ficl-named-wordlist hidden 165: hide hidden dup >search ficl-set-current ; 166 167\ ALSO dups the search stack... 168: also ( -- ) 169 search> dup >search >search ; 170 171\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST 172: forth ( -- ) 173 search> drop 174 forth-wordlist >search ; 175 176\ ONLY sets the search order to a default state 177: only ( -- ) 178 -1 set-order ; 179 180\ ORDER displays the compile wid and the search order list 181hide 182: list-wid ( wid -- ) 183 dup wid-get-name ( wid c-addr u ) 184 ?dup if 185 type drop 186 else 187 drop ." (unnamed wid) " x. 188 endif cr 189; 190set-current \ stop hiding words 191 192: order ( -- ) 193 ." Search:" cr 194 get-order 0 ?do 3 spaces list-wid loop cr 195 ." Compile: " get-current list-wid cr 196; 197 198: debug ' debug-xt ; immediate 199: on-step ." S: " .s cr ; 200 201 202\ Submitted by lch. 203: strdup ( c-addr length -- c-addr2 length2 ior ) 204 0 locals| addr2 length c-addr | end-locals 205 length 1 + allocate 206 0= if 207 to addr2 208 c-addr addr2 length move 209 addr2 length 0 210 else 211 0 -1 212 endif 213 ; 214 215: strcat ( 2:a 2:b -- 2:new-a ) 216 0 locals| b-length b-u b-addr a-u a-addr | end-locals 217 b-u to b-length 218 b-addr a-addr a-u + b-length move 219 a-addr a-u b-length + 220 ; 221 222: strcpy ( 2:a 2:b -- 2:new-a ) 223 locals| b-u b-addr a-u a-addr | end-locals 224 a-addr 0 b-addr b-u strcat 225 ; 226 227: xemit ( xchar -- ) 228 dup 0x80 u< if emit exit then \ special case ASCII 229 0 swap 0x3F 230 begin 2dup u> while 231 2/ >r dup 0x3F and 0x80 or swap 6 rshift r> 232 repeat 0x7F xor 2* or 233 begin dup 0x80 u< 0= while emit repeat drop 234 ; 235 236previous \ lose hidden words from search order 237 238\ ** E N D S O F T C O R E . F R 239 240