softcore.fr revision 43598 
1\ ** ficl/softwords/softcore.fr
2\ ** FICL soft extensions
3\ ** John Sadler (john_sadler@alum.mit.edu)
4\ ** September, 1998
5
6\ ** Ficl USER variables
7\ ** See words.c for primitive def'n of USER
8\ #if FICL_WANT_USER
9
10variable nUser  0 nUser ! 
11: user   \ name ( -- )  
12    nUser dup @ user 1 swap +! ; 
13
14\ #endif
15
16\ ** ficl extras
17\ EMPTY cleans the parameter stack
18: empty   ( xn..x1 -- ) depth 0 ?do drop loop ;
19\ CELL- undoes CELL+
20: cell-   ( addr -- addr )  [ 1 cells ] literal -  ;
21: -rot   ( a b c -- c a b )  2 -roll ;
22
23\ ** CORE 
24: abs   ( x -- x )
25    dup 0< if negate endif ;
26decimal 32 constant bl
27
28: space   ( -- )     bl emit ;
29
30: spaces  ( n -- )   0 ?do space loop ;
31
32: abort"  
33    postpone if 
34    postpone ." 
35    postpone cr 
36    -2
37    postpone literal
38    postpone throw 
39    postpone endif 
40; immediate 
41
42
43\ ** CORE EXT
440  constant false 
45-1 constant true 
46: <>   = invert ; 
47: 0<>  0= invert ; 
48: compile,  , ; 
49: erase   ( addr u -- )    0 fill ; 
50: nip     ( y x -- x )     swap drop ; 
51: tuck    ( y x -- x y x)  swap over ; 
52
53\ ** LOCAL EXT word set
54\ #if FICL_WANT_LOCALS
55: locals|  ( name...name | -- )
56    begin
57        bl word   count
58        dup 0= abort" where's the delimiter??"
59        over c@
60        [char] | - over 1- or
61    while
62        (local)
63    repeat 2drop   0 0 (local)
64; immediate
65
66: local  ( name -- )  bl word count (local) ;  immediate
67
68: end-locals  ( -- )  0 0 (local) ;  immediate
69
70\ #endif
71
72\ ** TOOLS word set...
73: ?     ( addr -- )  @ . ;
74: dump  ( addr u -- )
75    0 ?do
76        dup c@ . 1+
77        i 7 and 7 = if cr endif
78    loop drop
79;
80
81\ ** Some TOOLS EXT words, straight from the standard
82: [else]  ( -- )
83    1 begin                               \ level
84      begin
85        bl word count  dup  while         \ level adr len
86        2dup  s" [IF]"  compare 0= >r
87	2dup  s" [if]"  compare 0= r> or
88        if                                \ level adr len
89          2drop 1+                        \ level'
90        else                              \ level adr len
91          2dup  s" [ELSE]" compare 0= >r
92	  2dup  s" [else]" compare 0= r> or
93	  if				  \ level adr len
94             2drop 1- dup if 1+ then      \ level'
95          else                            \ level adr len
96	    2dup
97            s" [THEN]"  compare 0= >r	  \ level adr len
98	    s" [then]"  compare 0= r> or
99	    if				  \ level
100              1-                          \ level'
101            then
102          then
103        then ?dup 0=  if exit then        \ level'
104      repeat  2drop                       \ level
105    refill 0= until                       \ level
106    drop
107;  immediate
108
109: [if]  ( flag -- )
1100= if postpone [else] then ;  immediate
111
112: [then]  ( -- )  ;  immediate
113\ ** SEARCH+EXT words and ficl helpers
114\ 
115: wordlist   ( -- )  
116    1 ficl-wordlist ;
117
118\ DO_VOCABULARY handles the DOES> part of a VOCABULARY
119\ When executed, new voc replaces top of search stack
120: do-vocabulary   ( -- ) 
121    does>  @ search> drop >search ;
122
123: vocabulary   ( name -- )  
124    wordlist create ,  do-vocabulary ; 
125
126: ficl-vocabulary   ( nBuckets name -- )  
127    ficl-wordlist create ,  do-vocabulary ; 
128
129\ ALSO dups the search stack...
130: also   ( -- )  
131    search> dup >search >search ; 
132
133\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
134: forth   ( -- )  
135    search> drop  
136    forth-wordlist >search ; 
137
138\ ONLY sets the search order to a default state
139: only   ( -- )  
140    -1 set-order ; 
141
142\ ORDER displays the compile wid and the search order list
143: order   ( -- )  
144    ." Search: " 
145    get-order  0 ?do x. loop cr 
146   ." Compile: " get-current x. cr  ; 
147
148\ PREVIOUS drops the search order stack
149: previous  ( --  )  search> drop ; 
150
151\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
152: ficl-set-current   ( wid -- old-wid )  
153    get-current swap set-current ; 
154
155wordlist constant hidden
156: hide   hidden dup >search ficl-set-current ;
157
158\ ** E N D   S O F T C O R E . F R
159
160