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 94290 2002-04-09 17:45:28Z dcs $
7
8\ ** Ficl USER variables
9\ ** See words.c for primitive def'n of USER
10\ #if FICL_WANT_USER
11variable nUser 0 nUser !
12: user \ name ( -- )
13 nUser dup @ user 1 swap +! ;
14
15\ #endif
16
17\ ** ficl extras
--- 11 unchanged lines hidden (view full) ---
29: space ( -- ) bl emit ;
30
31: spaces ( n -- ) 0 ?do space loop ;
32
33: abort"
34 state @ if
35 postpone if
36 postpone ."
37 postpone cr
38 -2
39 postpone literal
40 postpone throw
41 postpone endif
42 else
43 [char] " parse
44 rot if
--- 8 unchanged lines hidden (view full) ---
53
54
55\ ** CORE EXT
560 constant false
57false invert constant true
58: <> = 0= ;
59: 0<> 0= 0= ;
60: compile, , ;
61: convert char+ 65535 >number drop ; \ cribbed from DPANS A.6.2.0970
62: erase ( addr u -- ) 0 fill ;
63variable span
64: expect ( c-addr u1 -- ) accept span ! ;
65\ see marker.fr for MARKER implementation
66: nip ( y x -- x ) swap drop ;
67: tuck ( y x -- x y x) swap over ;
68: within ( test low high -- flag ) over - >r - r> u< ;
69
70
71\ ** LOCAL EXT word set
72\ #if FICL_WANT_LOCALS
73: locals| ( name...name | -- )
--- 91 unchanged lines hidden (view full) ---
165set-current \ stop hiding words
166
167: order ( -- )
168 ." Search:" cr
169 get-order 0 ?do 3 spaces list-wid loop cr
170 ." Compile: " get-current list-wid cr
171;
172
173: debug ' debug-xt ; immediate
174: on-step ." S: " .s cr ;
175
176
177\ Submitted by lch.
178: strdup ( c-addr length -- c-addr2 length2 ior )
179 0 locals| addr2 length c-addr | end-locals
180 length 1 + allocate
181 0= if
182 to addr2
183 c-addr addr2 length move
184 addr2 length 0
185 else
186 0 -1
187 endif
188 ;
189
190: strcat ( 2:a 2:b -- 2:new-a )
191 0 locals| b-length b-u b-addr a-u a-addr | end-locals
192 b-u to b-length
193 b-addr a-addr a-u + b-length move
194 a-addr a-u b-length +
195 ;
196
197: strcpy ( 2:a 2:b -- 2:new-a )
198 locals| b-u b-addr a-u a-addr | end-locals
199 a-addr 0 b-addr b-u strcat
200 ;
201
202
203previous \ lose hidden words from search order
204
205\ ** E N D S O F T C O R E . F R
206
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 94290 2002-04-09 17:45:28Z dcs $
7
8\ ** Ficl USER variables
9\ ** See words.c for primitive def'n of USER
10\ #if FICL_WANT_USER
11variable nUser 0 nUser !
12: user \ name ( -- )
13 nUser dup @ user 1 swap +! ;
14
15\ #endif
16
17\ ** ficl extras
--- 11 unchanged lines hidden (view full) ---
29: space ( -- ) bl emit ;
30
31: spaces ( n -- ) 0 ?do space loop ;
32
33: abort"
34 state @ if
35 postpone if
36 postpone ."
37 postpone cr
38 -2
39 postpone literal
40 postpone throw
41 postpone endif
42 else
43 [char] " parse
44 rot if
--- 8 unchanged lines hidden (view full) ---
53
54
55\ ** CORE EXT
560 constant false
57false invert constant true
58: <> = 0= ;
59: 0<> 0= 0= ;
60: compile, , ;
61: convert char+ 65535 >number drop ; \ cribbed from DPANS A.6.2.0970
62: erase ( addr u -- ) 0 fill ;
63variable span
64: expect ( c-addr u1 -- ) accept span ! ;
65\ see marker.fr for MARKER implementation
66: nip ( y x -- x ) swap drop ;
67: tuck ( y x -- x y x) swap over ;
68: within ( test low high -- flag ) over - >r - r> u< ;
69
70
71\ ** LOCAL EXT word set
72\ #if FICL_WANT_LOCALS
73: locals| ( name...name | -- )
--- 91 unchanged lines hidden (view full) ---
165set-current \ stop hiding words
166
167: order ( -- )
168 ." Search:" cr
169 get-order 0 ?do 3 spaces list-wid loop cr
170 ." Compile: " get-current list-wid cr
171;
172
173: debug ' debug-xt ; immediate
174: on-step ." S: " .s cr ;
175
176
177\ Submitted by lch.
178: strdup ( c-addr length -- c-addr2 length2 ior )
179 0 locals| addr2 length c-addr | end-locals
180 length 1 + allocate
181 0= if
182 to addr2
183 c-addr addr2 length move
184 addr2 length 0
185 else
186 0 -1
187 endif
188 ;
189
190: strcat ( 2:a 2:b -- 2:new-a )
191 0 locals| b-length b-u b-addr a-u a-addr | end-locals
192 b-u to b-length
193 b-addr a-addr a-u + b-length move
194 a-addr a-u b-length +
195 ;
196
197: strcpy ( 2:a 2:b -- 2:new-a )
198 locals| b-u b-addr a-u a-addr | end-locals
199 a-addr 0 b-addr b-u strcat
200 ;
201
202
203previous \ lose hidden words from search order
204
205\ ** E N D S O F T C O R E . F R
206