| softcore.fr (76116) | softcore.fr (94290) |
|---|---|
| 1\ ** ficl/softwords/softcore.fr 2\ ** FICL soft extensions 3\ ** John Sadler (john_sadler@alum.mit.edu) 4\ ** September, 1998 | 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 $ |
|
| 5 | 7 |
| 6\ $FreeBSD: head/sys/boot/ficl/softwords/softcore.fr 76116 2001-04-29 02:36:36Z dcs $ 7 | |
| 8\ ** Ficl USER variables 9\ ** See words.c for primitive def'n of USER | 8\ ** Ficl USER variables 9\ ** See words.c for primitive def'n of USER |
| 10 | |
| 11\ #if FICL_WANT_USER 12variable nUser 0 nUser ! 13: user \ name ( -- ) 14 nUser dup @ user 1 swap +! ; 15 16\ #endif 17 18\ ** ficl extras --- 11 unchanged lines hidden (view full) --- 30: space ( -- ) bl emit ; 31 32: spaces ( n -- ) 0 ?do space loop ; 33 34: abort" 35 state @ if 36 postpone if 37 postpone ." | 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 ." |
| 38\ postpone type | |
| 39 postpone cr 40 -2 41 postpone literal 42 postpone throw 43 postpone endif 44 else 45 [char] " parse 46 rot if --- 8 unchanged lines hidden (view full) --- 55 56 57\ ** CORE EXT 580 constant false 59false invert constant true 60: <> = 0= ; 61: 0<> 0= 0= ; 62: compile, , ; | 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 |
|
| 63: erase ( addr u -- ) 0 fill ; | 62: erase ( addr u -- ) 0 fill ; |
| 63variable span 64: expect ( c-addr u1 -- ) accept span ! ; 65\ see marker.fr for MARKER implementation |
|
| 64: nip ( y x -- x ) swap drop ; 65: tuck ( y x -- x y x) swap over ; 66: within ( test low high -- flag ) over - >r - r> u< ; 67 68 69\ ** LOCAL EXT word set 70\ #if FICL_WANT_LOCALS 71: locals| ( name...name | -- ) --- 91 unchanged lines hidden (view full) --- 163set-current \ stop hiding words 164 165: order ( -- ) 166 ." Search:" cr 167 get-order 0 ?do 3 spaces list-wid loop cr 168 ." Compile: " get-current list-wid cr 169; 170 | 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 |
| 171: debug ' debug-xt ; | 173: debug ' debug-xt ; immediate 174: on-step ." S: " .s cr ; |
| 172 | 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 |
|
| 173previous \ lose hidden words from search order 174 175\ ** E N D S O F T C O R E . F R 176 | 203previous \ lose hidden words from search order 204 205\ ** E N D S O F T C O R E . F R 206 |