Return to extend.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/extend.fs, revision 1.2

1.1       anton       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: 
1.2     ! pazsan     19: : 2Literal  swap postpone Literal  postpone Literal ;
        !            20:   immediate restrict
        !            21: 
1.1       anton      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: 
1.2     ! pazsan     70: : erase ( 0 1 chars um/mod nip )  0 fill ;
        !            71: : blank ( 0 1 chars um/mod nip ) bl fill ;
1.1       anton      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: