File:  [gforth] / gforth / extend.fs
Revision 1.4: download - view: text, annotated - select for diffs
Thu Jul 21 10:52:39 1994 UTC (25 years, 4 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added dictionary hashing
Changed argument interpretation as documented
Made refill for DOS 20 times faster
Added m*/ and missing FP words.

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>