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