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