softcore.fr revision 61584 
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 61584 2000-06-12 16:42:02Z dcs $
7
8\ ** Ficl USER variables
9\ ** See words.c for primitive def'n of USER
10\ #if FICL_WANT_USER
11
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        [char] " parse
38        postpone sliteral
39        postpone type
40        postpone cr
41        -2
42        postpone literal
43        postpone throw
44        postpone endif
45    else
46	[char] " parse
47        rot if
48            type
49            cr
50            -2 throw
51	else
52	    2drop
53        then
54    then
55; immediate
56
57
58\ ** CORE EXT
590 constant false
60false invert constant true
61: <>   = 0= ; 
62: 0<>  0= 0= ; 
63: compile,  , ; 
64: erase   ( addr u -- )    0 fill ; 
65: nip     ( y x -- x )     swap drop ; 
66: tuck    ( y x -- x y x)  swap over ; 
67: within  ( test low high -- flag )   over - >r - r>  u<  ;
68
69
70\ ** LOCAL EXT word set
71\ #if FICL_WANT_LOCALS
72: locals|  ( name...name | -- )
73    begin
74        bl word   count
75        dup 0= abort" where's the delimiter??"
76        over c@
77        [char] | - over 1- or
78    while
79        (local)
80    repeat 2drop   0 0 (local)
81; immediate
82
83: local  ( name -- )  bl word count (local) ;  immediate
84
85: 2local  ( name -- ) bl word count (2local) ; immediate
86
87: end-locals  ( -- )  0 0 (local) ;  immediate
88
89\ #endif
90
91\ ** TOOLS word set...
92: ?     ( addr -- )  @ . ;
93: dump  ( addr u -- )
94    0 ?do
95        dup c@ . 1+
96        i 7 and 7 = if cr endif
97    loop drop
98;
99
100\ ** SEARCH+EXT words and ficl helpers
101\ 
102: wordlist   ( -- )  
103    1 ficl-wordlist ;
104
105\ DO_VOCABULARY handles the DOES> part of a VOCABULARY
106\ When executed, new voc replaces top of search stack
107: do-vocabulary   ( -- ) 
108    does>  @ search> drop >search ;
109
110: vocabulary   ( name -- )  
111    wordlist create ,  do-vocabulary ; 
112
113: ficl-vocabulary   ( nBuckets name -- )  
114    ficl-wordlist create ,  do-vocabulary ; 
115
116\ ALSO dups the search stack...
117: also   ( -- )  
118    search> dup >search >search ; 
119
120\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
121: forth   ( -- )  
122    search> drop  
123    forth-wordlist >search ; 
124
125\ ONLY sets the search order to a default state
126: only   ( -- )  
127    -1 set-order ; 
128
129\ ORDER displays the compile wid and the search order list
130: order   ( -- )  
131    ." Search: " 
132    get-order  0 ?do x. loop cr 
133   ." Compile: " get-current x. cr  ; 
134
135\ PREVIOUS drops the search order stack
136: previous  ( --  )  search> drop ; 
137
138\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
139: ficl-set-current   ( wid -- old-wid )  
140    get-current swap set-current ; 
141
142wordlist constant hidden
143: hide   hidden dup >search ficl-set-current ;
144
145\ ** E N D   S O F T C O R E . F R
146
147