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?

    1: \ EXTEND.FS    CORE-EXT Word not fully tested!         12may93jaw
    2: 
    3: \ May be cross-compiled
    4: 
    5: decimal
    6: 
    7: \ .(                                                    12may93jaw
    8: 
    9: : .(    [char] ) parse type ;
   10: 
   11: \ VALUE 2>R 2R> 2R@                                     17may93jaw
   12: 
   13: : value ( n -- )
   14:   (constant) , ;
   15: \ !! 2value
   16: 
   17: : 2Literal  swap postpone Literal  postpone Literal ;
   18:   immediate restrict
   19: 
   20: : m*/    ( d1 n2 u3 -- dqout )    >r s>d >r abs -rot
   21:   s>d r> xor r> swap >r >r dabs rot tuck um* 2swap um*
   22:   swap >r 0 d+ r> -rot r@ um/mod -rot r> um/mod nip swap
   23:   r> IF dnegate THEN ;
   24: 
   25: \ CASE OF ENDOF ENDCASE                                 17may93jaw
   26: 
   27: \ just as described in dpANS5
   28: 
   29: 0 CONSTANT case immediate
   30: 
   31: : of
   32:         1+ >r
   33:         postpone over postpone = postpone if postpone drop
   34:         r> ; immediate
   35: 
   36: : endof
   37:         >r postpone else r> ; immediate
   38: 
   39: : endcase
   40:         postpone drop
   41:         0 ?do postpone then loop ; immediate
   42: 
   43: \ C"                                                    17may93jaw
   44: 
   45: : (c")     "lit ;
   46: 
   47: : CLiteral postpone (c") here over char+ allot  place align ;
   48:                                               immediate restrict
   49: : C"       [char] " parse postpone CLiteral ; immediate restrict
   50: 
   51: \ UNUSED                                                17may93jaw
   52: 
   53: : unused   s0 @ 512 -        \ for stack
   54:            here - ;
   55: 
   56: \ [COMPILE]                                             17may93jaw
   57: 
   58: : [compile] 
   59:  ' compile, ; immediate
   60: 
   61: \ MARKER                                                17may93jaw
   62: 
   63: \ : marker here last @ create , , DOES> dup @ last ! cell+ @ dp ! ;
   64: \ doesn't work now. vocabularies?
   65: 
   66: \ CONVERT                                               17may93jaw
   67: 
   68: : convert true >number drop ;
   69: 
   70: \ ERASE                                                 17may93jaw
   71: 
   72: : erase ( 0 1 chars um/mod nip )  0 fill ;
   73: : blank ( 0 1 chars um/mod nip ) bl fill ;
   74: 
   75: \ SEARCH                                                02sep94py
   76: 
   77: : search   ( buf buflen text textlen -- restbuf restlen flag )
   78:   2over  2 pick - 1+ 3 pick c@ >r
   79:   BEGIN  r@ scan dup  WHILE
   80:          >r >r  2dup r@ -text
   81:          0= IF  >r drop 2drop r> r> r> rot + 1- rdrop true  EXIT  THEN
   82: 	 r> r>  1 /string   REPEAT
   83:   2drop 2drop  rdrop false ;
   84: 
   85: \ ROLL                                                  17may93jaw
   86: 
   87: : roll  dup 1+ pick >r
   88:         cells sp@ cell+ dup cell+ rot move drop r> ;
   89: 
   90: \ SOURCE-ID SAVE-INPUT RESTORE-INPUT                    11jun93jaw
   91: 
   92: : source-id ( -- 0 | -1 | fileid )
   93:   loadfile @ dup 0= IF  drop loadline @ 0 min  THEN ;
   94: 
   95: : save-input ( -- x1 .. xn n )
   96:   >in @
   97:   loadfile @ ?dup
   98:   IF    dup file-position throw loadline @ >tib @ 6
   99:         #tib @ >tib +!
  100:   ELSE  loadline @ blk @ linestart @ >tib @ 5 THEN
  101: ;
  102: 
  103: : restore-input ( x1 .. xn n -- flag )
  104:   swap >tib !
  105:   6 = IF   loadline ! rot dup loadfile !
  106:            reposition-file IF drop true EXIT THEN
  107:       ELSE linestart ! blk !
  108:            dup loadline @ <> IF 2drop true EXIT THEN
  109:            loadline !
  110:       THEN
  111:   >in ! false ;
  112: 
  113: 
  114: 
  115: \ This things we don't need, but for being complete... jaw
  116: 
  117: \ EXPECT SPAN                                           17may93jaw
  118: 
  119: variable span
  120: 
  121: : expect ( c-addr +len -- )
  122:   0 rot over
  123:   BEGIN  key decode >r 2over = r> or  UNTIL
  124:   2drop nip span ! ;
  125: