File:  [gforth] / gforth / extend.fs
Revision 1.2: download - view: text, annotated - select for diffs
Wed Apr 20 17:12:02 1994 UTC (25 years, 7 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
primitives: key?, ms and time&date added
engine.c: time.h for ms and time&date included
bugs fixed to run tt.pfe

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

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