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