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