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