Return to extend.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/extend.fs, revision 1.1

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