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