1\ ** ficl/softwords/softcore.fr
2\ ** FICL soft extensions
3\ ** John Sadler (john_sadler@alum.mit.edu)
4\ ** September, 1998
5\
6\ $FreeBSD: head/sys/boot/ficl/softwords/softcore.fr 94290 2002-04-09 17:45:28Z dcs $
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
203previous \ lose hidden words from search order
204
205\ ** E N D S O F T C O R E . F R
206
2\ ** FICL soft extensions
3\ ** John Sadler (john_sadler@alum.mit.edu)
4\ ** September, 1998
5\
6\ $FreeBSD: head/sys/boot/ficl/softwords/softcore.fr 94290 2002-04-09 17:45:28Z dcs $
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
203previous \ lose hidden words from search order
204
205\ ** E N D S O F T C O R E . F R
206