1 \ ** ficl/softwords/softcore.fr
2 \ ** FICL soft extensions
3 \ ** John Sadler (john_sadler@alum.mit.edu)
8 \ ** Ficl USER variables
9 \ ** See words.c for primitive def'n of USER
11 variable nUser 0 nUser !
13 nUser dup @ user 1 swap +! ;
18 \ EMPTY cleans the parameter stack
19 : empty ( xn..x1 -- ) depth 0 ?do drop loop ;
21 : cell- ( addr -- addr ) [ 1 cells ] literal - ;
22 : -rot ( a b c -- c a b ) 2 -roll ;
26 dup 0< if negate endif ;
27 decimal 32 constant bl
29 : space ( -- ) bl emit ;
31 : spaces ( n -- ) 0 ?do space loop ;
57 false invert constant true
61 : convert char+ 65535 >number drop ; \ cribbed from DPANS A.6.2.0970
62 : erase ( addr u -- ) 0 fill ;
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< ;
71 \ ** LOCAL EXT word set
72 \ #if FICL_WANT_LOCALS
73 : locals| ( name...name | -- )
76 dup 0= abort" where's the delimiter??"
81 repeat 2drop 0 0 (local)
84 : local ( name -- ) bl word count (local) ; immediate
86 : 2local ( name -- ) bl word count (2local) ; immediate
88 : end-locals ( -- ) 0 0 (local) ; immediate
92 \ ** TOOLS word set...
97 i 7 and 7 = if cr endif
101 \ ** SEARCH+EXT words and ficl helpers
102 \ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom:
103 \ wordlist dup create , brand-wordlist
104 \ gets the name of the word made by create and applies it to the wordlist...
105 : brand-wordlist ( wid -- ) last-word >name drop wid-set-name ;
107 : ficl-named-wordlist \ ( hash-size name -- ) run: ( -- wid )
108 ficl-wordlist dup create , brand-wordlist does> @ ;
113 \ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
114 : ficl-set-current ( wid -- old-wid )
115 get-current swap set-current ;
117 \ DO_VOCABULARY handles the DOES> part of a VOCABULARY
118 \ When executed, new voc replaces top of search stack
119 : do-vocabulary ( -- )
120 does> @ search> drop >search ;
122 : ficl-vocabulary ( nBuckets name -- )
123 ficl-named-wordlist do-vocabulary ;
125 : vocabulary ( name -- )
128 \ PREVIOUS drops the search order stack
129 : previous ( -- ) search> drop ;
131 \ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace
134 \ <definitions to hide>
136 \ <words that use hidden defs>
137 \ previous ( pop HIDDEN off the search order )
139 1 ficl-named-wordlist hidden
140 : hide hidden dup >search ficl-set-current ;
142 \ ALSO dups the search stack...
144 search> dup >search >search ;
146 \ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
149 forth-wordlist >search ;
151 \ ONLY sets the search order to a default state
155 \ ORDER displays the compile wid and the search order list
157 : list-wid ( wid -- )
158 dup wid-get-name ( wid c-addr u )
162 drop ." (unnamed wid) " x.
165 set-current \ stop hiding words
169 get-order 0 ?do 3 spaces list-wid loop cr
170 ." Compile: " get-current list-wid cr
173 : debug ' debug-xt ; immediate
174 : on-step ." S: " .s cr ;
178 : strdup ( c-addr length -- c-addr2 length2 ior )
179 0 locals| addr2 length c-addr | end-locals
183 c-addr addr2 length move
190 : strcat ( 2:a 2:b -- 2:new-a )
191 0 locals| b-length b-u b-addr a-u a-addr | end-locals
193 b-addr a-addr a-u + b-length move
194 a-addr a-u b-length +
197 : strcpy ( 2:a 2:b -- 2:new-a )
198 locals| b-u b-addr a-u a-addr | end-locals
199 a-addr 0 b-addr b-u strcat
203 previous \ lose hidden words from search order
205 \ ** E N D S O F T C O R E . F R