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