File:
[gforth] /
gforth /
extend.fs
Revision
1.7:
download - view:
text,
annotated -
select for diffs
Fri Sep 2 15:23:35 1994 UTC (29 years, 7 months ago) by
pazsan
Branches:
MAIN
CVS tags:
HEAD
Corrected bug in error reporting due to input stream restoration
Corrected bug in cross compiler du to later defined constants
renamed search into lookup and implemented the correct "search"
UPS: removed double deferred header and (header) - if problems tell
me why double deferred?
\ 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) , ;
\ !! 2value
: 2Literal swap postpone Literal postpone Literal ;
immediate restrict
: m*/ ( d1 n2 u3 -- dqout ) >r s>d >r abs -rot
s>d r> xor r> swap >r >r dabs rot tuck um* 2swap um*
swap >r 0 d+ r> -rot r@ um/mod -rot r> um/mod nip swap
r> IF dnegate THEN ;
\ 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 s0 @ 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 ;
\ SEARCH 02sep94py
: search ( buf buflen text textlen -- restbuf restlen flag )
2over 2 pick - 1+ 3 pick c@ >r
BEGIN r@ scan dup WHILE
>r >r 2dup r@ -text
0= IF >r drop 2drop r> r> r> rot + 1- rdrop true EXIT THEN
r> r> 1 /string REPEAT
2drop 2drop rdrop false ;
\ ROLL 17may93jaw
: roll dup 1+ pick >r
cells sp@ cell+ dup cell+ rot move drop r> ;
\ SOURCE-ID SAVE-INPUT RESTORE-INPUT 11jun93jaw
: source-id ( -- 0 | -1 | fileid )
loadfile @ dup 0= IF drop loadline @ 0 min THEN ;
: save-input ( -- x1 .. xn n )
>in @
loadfile @ ?dup
IF dup file-position throw loadline @ >tib @ 6
#tib @ >tib +!
ELSE loadline @ blk @ linestart @ >tib @ 5 THEN
;
: restore-input ( x1 .. xn n -- flag )
swap >tib !
6 = IF loadline ! rot dup loadfile !
reposition-file 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>