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 76116 2001-04-29 02:36:36Z dcs $
7
8\ ** Ficl USER variables
9\ ** See words.c for primitive def'n of USER
10
11\ #if FICL_WANT_USER
12variable nUser 0 nUser !
13: user \ name ( -- )
14 nUser dup @ user 1 swap +! ;
15
16\ #endif
17
18\ ** ficl extras
19\ EMPTY cleans the parameter stack
20: empty ( xn..x1 -- ) depth 0 ?do drop loop ;
21\ CELL- undoes CELL+
22: cell- ( addr -- addr ) [ 1 cells ] literal - ;
23: -rot ( a b c -- c a b ) 2 -roll ;
24
25\ ** CORE
26: abs ( x -- x )
27 dup 0< if negate endif ;
28decimal 32 constant bl
29
30: space ( -- ) bl emit ;
31
32: spaces ( n -- ) 0 ?do space loop ;
33
34: abort"
35 state @ if
36 postpone if
37 postpone ."
38\ postpone type
39 postpone cr
40 -2
41 postpone literal
42 postpone throw
43 postpone endif
44 else
45 [char] " parse
46 rot if
47 type
48 cr
49 -2 throw
50 else
51 2drop
52 endif
53 endif
54; immediate
55
56
57\ ** CORE EXT
580 constant false
59false invert constant true
60: <> = 0= ;
61: 0<> 0= 0= ;
62: compile, , ;
63: erase ( addr u -- ) 0 fill ;
64: nip ( y x -- x ) swap drop ;
65: tuck ( y x -- x y x) swap over ;
66: within ( test low high -- flag ) over - >r - r> u< ;
67
68
69\ ** LOCAL EXT word set
70\ #if FICL_WANT_LOCALS
71: locals| ( name...name | -- )
72 begin
73 bl word count
74 dup 0= abort" where's the delimiter??"
75 over c@
76 [char] | - over 1- or
77 while
78 (local)
79 repeat 2drop 0 0 (local)
80; immediate
81
82: local ( name -- ) bl word count (local) ; immediate
83
84: 2local ( name -- ) bl word count (2local) ; immediate
85
86: end-locals ( -- ) 0 0 (local) ; immediate
87
88\ #endif
89
90\ ** TOOLS word set...
91: ? ( addr -- ) @ . ;
92: dump ( addr u -- )
93 0 ?do
94 dup c@ . 1+
95 i 7 and 7 = if cr endif
96 loop drop
97;
98
99\ ** SEARCH+EXT words and ficl helpers
100\ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom:
101\ wordlist dup create , brand-wordlist
102\ gets the name of the word made by create and applies it to the wordlist...
103: brand-wordlist ( wid -- ) last-word >name drop wid-set-name ;
104
105: ficl-named-wordlist \ ( hash-size name -- ) run: ( -- wid )
106 ficl-wordlist dup create , brand-wordlist does> @ ;
107
108: wordlist ( -- )
109 1 ficl-wordlist ;
110
111\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
112: ficl-set-current ( wid -- old-wid )
113 get-current swap set-current ;
114
115\ DO_VOCABULARY handles the DOES> part of a VOCABULARY
116\ When executed, new voc replaces top of search stack
117: do-vocabulary ( -- )
118 does> @ search> drop >search ;
119
120: ficl-vocabulary ( nBuckets name -- )
121 ficl-named-wordlist do-vocabulary ;
122
123: vocabulary ( name -- )
124 1 ficl-vocabulary ;
125
126\ PREVIOUS drops the search order stack
127: previous ( -- ) search> drop ;
128
129\ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace
130\ USAGE:
131\ hide
132\ <definitions to hide>
133\ set-current
134\ <words that use hidden defs>
135\ previous ( pop HIDDEN off the search order )
136
1371 ficl-named-wordlist hidden
138: hide hidden dup >search ficl-set-current ;
139
140\ ALSO dups the search stack...
141: also ( -- )
142 search> dup >search >search ;
143
144\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
145: forth ( -- )
146 search> drop
147 forth-wordlist >search ;
148
149\ ONLY sets the search order to a default state
150: only ( -- )
151 -1 set-order ;
152
153\ ORDER displays the compile wid and the search order list
154hide
155: list-wid ( wid -- )
156 dup wid-get-name ( wid c-addr u )
157 ?dup if
158 type drop
159 else
160 drop ." (unnamed wid) " x.
161 endif cr
162;
163set-current \ stop hiding words
164
165: order ( -- )
166 ." Search:" cr
167 get-order 0 ?do 3 spaces list-wid loop cr
168 ." Compile: " get-current list-wid cr
169;
170
171: debug ' debug-xt ;
172
173previous \ lose hidden words from search order
174
175\ ** E N D S O F T C O R E . F R
176
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 76116 2001-04-29 02:36:36Z dcs $
7
8\ ** Ficl USER variables
9\ ** See words.c for primitive def'n of USER
10
11\ #if FICL_WANT_USER
12variable nUser 0 nUser !
13: user \ name ( -- )
14 nUser dup @ user 1 swap +! ;
15
16\ #endif
17
18\ ** ficl extras
19\ EMPTY cleans the parameter stack
20: empty ( xn..x1 -- ) depth 0 ?do drop loop ;
21\ CELL- undoes CELL+
22: cell- ( addr -- addr ) [ 1 cells ] literal - ;
23: -rot ( a b c -- c a b ) 2 -roll ;
24
25\ ** CORE
26: abs ( x -- x )
27 dup 0< if negate endif ;
28decimal 32 constant bl
29
30: space ( -- ) bl emit ;
31
32: spaces ( n -- ) 0 ?do space loop ;
33
34: abort"
35 state @ if
36 postpone if
37 postpone ."
38\ postpone type
39 postpone cr
40 -2
41 postpone literal
42 postpone throw
43 postpone endif
44 else
45 [char] " parse
46 rot if
47 type
48 cr
49 -2 throw
50 else
51 2drop
52 endif
53 endif
54; immediate
55
56
57\ ** CORE EXT
580 constant false
59false invert constant true
60: <> = 0= ;
61: 0<> 0= 0= ;
62: compile, , ;
63: erase ( addr u -- ) 0 fill ;
64: nip ( y x -- x ) swap drop ;
65: tuck ( y x -- x y x) swap over ;
66: within ( test low high -- flag ) over - >r - r> u< ;
67
68
69\ ** LOCAL EXT word set
70\ #if FICL_WANT_LOCALS
71: locals| ( name...name | -- )
72 begin
73 bl word count
74 dup 0= abort" where's the delimiter??"
75 over c@
76 [char] | - over 1- or
77 while
78 (local)
79 repeat 2drop 0 0 (local)
80; immediate
81
82: local ( name -- ) bl word count (local) ; immediate
83
84: 2local ( name -- ) bl word count (2local) ; immediate
85
86: end-locals ( -- ) 0 0 (local) ; immediate
87
88\ #endif
89
90\ ** TOOLS word set...
91: ? ( addr -- ) @ . ;
92: dump ( addr u -- )
93 0 ?do
94 dup c@ . 1+
95 i 7 and 7 = if cr endif
96 loop drop
97;
98
99\ ** SEARCH+EXT words and ficl helpers
100\ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom:
101\ wordlist dup create , brand-wordlist
102\ gets the name of the word made by create and applies it to the wordlist...
103: brand-wordlist ( wid -- ) last-word >name drop wid-set-name ;
104
105: ficl-named-wordlist \ ( hash-size name -- ) run: ( -- wid )
106 ficl-wordlist dup create , brand-wordlist does> @ ;
107
108: wordlist ( -- )
109 1 ficl-wordlist ;
110
111\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
112: ficl-set-current ( wid -- old-wid )
113 get-current swap set-current ;
114
115\ DO_VOCABULARY handles the DOES> part of a VOCABULARY
116\ When executed, new voc replaces top of search stack
117: do-vocabulary ( -- )
118 does> @ search> drop >search ;
119
120: ficl-vocabulary ( nBuckets name -- )
121 ficl-named-wordlist do-vocabulary ;
122
123: vocabulary ( name -- )
124 1 ficl-vocabulary ;
125
126\ PREVIOUS drops the search order stack
127: previous ( -- ) search> drop ;
128
129\ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace
130\ USAGE:
131\ hide
132\ <definitions to hide>
133\ set-current
134\ <words that use hidden defs>
135\ previous ( pop HIDDEN off the search order )
136
1371 ficl-named-wordlist hidden
138: hide hidden dup >search ficl-set-current ;
139
140\ ALSO dups the search stack...
141: also ( -- )
142 search> dup >search >search ;
143
144\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
145: forth ( -- )
146 search> drop
147 forth-wordlist >search ;
148
149\ ONLY sets the search order to a default state
150: only ( -- )
151 -1 set-order ;
152
153\ ORDER displays the compile wid and the search order list
154hide
155: list-wid ( wid -- )
156 dup wid-get-name ( wid c-addr u )
157 ?dup if
158 type drop
159 else
160 drop ." (unnamed wid) " x.
161 endif cr
162;
163set-current \ stop hiding words
164
165: order ( -- )
166 ." Search:" cr
167 get-order 0 ?do 3 spaces list-wid loop cr
168 ." Compile: " get-current list-wid cr
169;
170
171: debug ' debug-xt ;
172
173previous \ lose hidden words from search order
174
175\ ** E N D S O F T C O R E . F R
176