Return to extend.fs CVS log

Up to [gforth] / gforth

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 ! ;