softcore.fr revision 76116 
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
177