softcore.fr revision 352240 
1\ ** ficl/softwords/softcore.fr
2\ ** FICL soft extensions
3\ ** John Sadler (john_sadler@alum.mit.edu)
4\ ** September, 1998
5\
6\ $FreeBSD: stable/11/stand/ficl/softwords/softcore.fr 352240 2019-09-12 06:20:20Z tsoome $
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
71\ ** LOCAL EXT word set
72\ #if FICL_WANT_LOCALS
73: locals|  ( name...name | -- )
74    begin
75        bl word   count
76        dup 0= abort" where's the delimiter??"
77        over c@
78        [char] | - over 1- or
79    while
80        (local)
81    repeat 2drop   0 0 (local)
82; immediate
83
84: local  ( name -- )  bl word count (local) ;  immediate
85
86: 2local  ( name -- ) bl word count (2local) ; immediate
87
88: end-locals  ( -- )  0 0 (local) ;  immediate
89
90\ #endif
91
92\ ** TOOLS word set...
93: ?     ( addr -- )  @ . ;
94: dump  ( addr u -- )
95    0 ?do
96        dup c@ . 1+
97        i 7 and 7 = if cr endif
98    loop drop
99;
100
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 ;
106
107: ficl-named-wordlist  \ ( hash-size name -- ) run: ( -- wid )
108    ficl-wordlist dup create , brand-wordlist does> @ ;
109
110: wordlist   ( -- )  
111    1 ficl-wordlist ;
112
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 ; 
116
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 ;
121
122: ficl-vocabulary   ( nBuckets name -- )  
123    ficl-named-wordlist do-vocabulary ; 
124
125: vocabulary   ( name -- )  
126    1 ficl-vocabulary ; 
127
128\ PREVIOUS drops the search order stack
129: previous  ( --  )  search> drop ; 
130
131\ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace
132\ USAGE:
133\ hide
134\ <definitions to hide>
135\ set-current
136\ <words that use hidden defs>
137\ previous ( pop HIDDEN off the search order )
138
1391 ficl-named-wordlist hidden
140: hide     hidden dup >search ficl-set-current ;
141
142\ ALSO dups the search stack...
143: also   ( -- )  
144    search> dup >search >search ; 
145
146\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
147: forth   ( -- )  
148    search> drop  
149    forth-wordlist >search ; 
150
151\ ONLY sets the search order to a default state
152: only   ( -- )  
153    -1 set-order ; 
154
155\ ORDER displays the compile wid and the search order list
156hide
157: list-wid ( wid -- )   
158    dup wid-get-name   ( wid c-addr u )
159    ?dup if 
160        type drop 
161    else 
162        drop ." (unnamed wid) " x.
163    endif cr 
164; 
165set-current   \ stop hiding words
166
167: order   ( -- )  
168    ." Search:" cr
169    get-order  0 ?do 3 spaces list-wid loop cr 
170   ." Compile: " get-current list-wid cr  
171; 
172
173: debug  ' debug-xt ; immediate
174: on-step   ." S: " .s cr ;
175
176
177\ Submitted by lch.
178: strdup ( c-addr length -- c-addr2 length2 ior )
179	0 locals| addr2 length c-addr | end-locals
180	length 1 + allocate
181	0= if
182		to addr2
183		c-addr addr2 length move
184		addr2 length 0
185	else
186		0  -1
187	endif
188	;
189
190: strcat ( 2:a 2:b -- 2:new-a )
191	0 locals|  b-length b-u b-addr a-u a-addr | end-locals
192	b-u  to b-length
193	b-addr a-addr a-u + b-length  move
194	a-addr a-u b-length +
195	;
196
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
200	;
201
202: xemit ( xchar -- )
203 	dup 0x80 u< if emit exit then \ special case ASCII
204 	0 swap 0x3F
205 	begin 2dup u> while
206 		2/ >r dup 0x3F and 0x80 or swap 6 rshift r>
207 	repeat 0x7F xor 2* or
208 	begin dup 0x80 u< 0= while emit repeat drop
209 	;
210
211previous   \ lose hidden words from search order
212
213\ ** E N D   S O F T C O R E . F R
214
215