softcore.fr revision 61584 
141120Sjdp\ ** ficl/softwords/softcore.fr
241120Sjdp\ ** FICL soft extensions
341120Sjdp\ ** John Sadler (john_sadler@alum.mit.edu)
441120Sjdp\ ** September, 1998
541120Sjdp
641120Sjdp\ $FreeBSD: head/sys/boot/ficl/softwords/softcore.fr 61584 2000-06-12 16:42:02Z dcs $
741120Sjdp
841120Sjdp\ ** Ficl USER variables
941120Sjdp\ ** See words.c for primitive def'n of USER
1041120Sjdp\ #if FICL_WANT_USER
1141120Sjdp
1241120Sjdpvariable nUser  0 nUser ! 
1341120Sjdp: user   \ name ( -- )  
1441120Sjdp    nUser dup @ user 1 swap +! ; 
1541120Sjdp
1641120Sjdp\ #endif
1741120Sjdp
1841120Sjdp\ ** ficl extras
1941120Sjdp\ EMPTY cleans the parameter stack
2041120Sjdp: empty   ( xn..x1 -- ) depth 0 ?do drop loop ;
2141120Sjdp\ CELL- undoes CELL+
2241120Sjdp: cell-   ( addr -- addr )  [ 1 cells ] literal -  ;
2341120Sjdp: -rot   ( a b c -- c a b )  2 -roll ;
2441120Sjdp
2541120Sjdp\ ** CORE 
2641120Sjdp: abs   ( x -- x )
2741120Sjdp    dup 0< if negate endif ;
2841120Sjdpdecimal 32 constant bl
2941120Sjdp
3041120Sjdp: space   ( -- )     bl emit ;
3141120Sjdp
3241120Sjdp: spaces  ( n -- )   0 ?do space loop ;
3341120Sjdp
3441120Sjdp: abort"
3541120Sjdp    state @ if
3641120Sjdp        postpone if
3741120Sjdp        [char] " parse
3841120Sjdp        postpone sliteral
3941120Sjdp        postpone type
4041120Sjdp        postpone cr
4141120Sjdp        -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