\ EXTEND.FS CORE-EXT Word not fully tested! 12may93jaw
\ May be cross-compiled
decimal
\ .( 12may93jaw
: .( [char] ) parse type ;
\ VALUE 2>R 2R> 2R@ 17may93jaw
: value ( n -- ) (constant) , ;
: 2>r postpone >r postpone >r ; immediate restrict
: 2r> postpone r> postpone r> ; immediate restrict
: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate restrict
: 2Literal swap postpone Literal postpone Literal ;
immediate restrict
\ CASE OF ENDOF ENDCASE 17may93jaw
\ just as described in dpANS5
0 CONSTANT case immediate
: of
1+ >r
postpone over postpone = postpone if postpone drop
r> ; immediate
: endof
>r postpone else r> ; immediate
: endcase
postpone drop
0 ?do postpone then loop ; immediate
\ C" 17may93jaw
: (c") "lit ;
: CLiteral postpone (c") here over char+ allot place align ;
immediate restrict
: C" [char] " parse postpone CLiteral ; immediate restrict
\ UNUSED 17may93jaw
: unused forthstart dup @ over 2 cells + @ -
512 - \ for stack
+ here - ;
\ [COMPILE] 17may93jaw
: [compile]
' compile, ; immediate
\ MARKER 17may93jaw
\ : marker here last @ create , , DOES> dup @ last ! cell+ @ dp ! ;
\ doesn't work now. vocabularies?
\ CONVERT 17may93jaw
: convert true >number drop ;
\ ERASE 17may93jaw
: erase ( 0 1 chars um/mod nip ) 0 fill ;
: blank ( 0 1 chars um/mod nip ) bl fill ;
\ ROLL 17may93jaw
: roll dup 1+ pick >r
cells sp@ 2 cells + dup cell+ rot move drop r> ;
\ SOURCE-ID SAVE-INPUT RESTORE-INPUT 11jun93jaw
: source-id ( -- 0 | -1 | fileid )
loadfile @ dup 0= IF drop linestart @ THEN ;
: save-input ( -- x1 .. xn n )
>in @
loadfile @ ?dup
IF linestart 2@ loadline @ 6
ELSE loadline @ blk @ linestart @ 5 THEN
>tib @ swap ; \ >tib for security
: restore-input ( x1 .. xn n -- flag )
1- swap >tib @ <> IF discard true EXIT THEN
5 = IF loadline ! 2dup linestart 2! rot dup loadfile !
reposition-file IF drop true EXIT THEN
refill 0= IF drop true EXIT THEN
ELSE linestart ! blk !
dup loadline @ <> IF 2drop true EXIT THEN
loadline !
THEN
>in ! false ;
\ This things we don't need, but for being complete... jaw
\ EXPECT SPAN 17may93jaw
variable span
: expect ( c-addr +len -- )
0 rot over
BEGIN key decode >r 2over = r> or UNTIL
2drop nip span ! ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>