Return to extend.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/extend.fs, revision 1.11

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: 
1.11    ! anton       9: : .(   ( compilation "...<paren>" -- ) \ core-ext dot-paren
1.8       anton      10:     [char] ) parse type ; immediate
1.1       anton      11: 
                     12: \ VALUE 2>R 2R> 2R@                                     17may93jaw
                     13: 
1.11    ! anton      14: : value ( w -- ) \ core-ext
1.3       anton      15:   (constant) , ;
                     16: \ !! 2value
1.1       anton      17: 
1.11    ! anton      18: : 2Literal ( compilation w1 w2 -- ; run-time  -- w1 w2 ) \ double two-literal
        !            19:     swap postpone Literal  postpone Literal ; immediate restrict
1.2       pazsan     20: 
1.11    ! anton      21: : m*/ ( d1 n2 u3 -- dqout ) \ double m-star-slash
        !            22:     >r s>d >r abs -rot
        !            23:     s>d r> xor r> swap >r >r dabs rot tuck um* 2swap um*
        !            24:     swap >r 0 d+ r> -rot r@ um/mod -rot r> um/mod nip swap
        !            25:     r> IF dnegate THEN ;
1.4       pazsan     26: 
1.1       anton      27: \ CASE OF ENDOF ENDCASE                                 17may93jaw
                     28: 
                     29: \ just as described in dpANS5
                     30: 
1.11    ! anton      31: 0 CONSTANT case ( compilation  -- case-sys ; run-time  -- ) \ core-ext
        !            32:     immediate
1.1       anton      33: 
1.11    ! anton      34: : of ( compilation  -- of-sys ; run-time x1 x2 -- |x1 ) \ core-ext
        !            35:     \ !! the implementation does not match the stack effect
        !            36:     1+ >r
        !            37:     postpone over postpone = postpone if postpone drop
        !            38:     r> ; immediate
        !            39: 
        !            40: : endof ( compilation case-sys1 of-sys -- case-sys2 ; run-time  -- ) \ core-ext end-of
        !            41:     >r postpone else r> ; immediate
        !            42: 
        !            43: : endcase ( compilation case-sys -- ; run-time x -- ) \ core-ext end-case
        !            44:     postpone drop
        !            45:     0 ?do postpone then loop ; immediate
1.1       anton      46: 
                     47: \ C"                                                    17may93jaw
                     48: 
                     49: : (c")     "lit ;
                     50: 
1.11    ! anton      51: : CLiteral
        !            52:     postpone (c") here over char+ allot  place align ; immediate restrict
        !            53: 
        !            54: : C" ( compilation "...<quote>" -- ; run-time  -- c-addr ) \ core-ext c-quote
        !            55:     [char] " parse postpone CLiteral ; immediate restrict
1.1       anton      56: 
                     57: \ UNUSED                                                17may93jaw
                     58: 
1.11    ! anton      59: : unused ( -- u ) \ core-ext
        !            60:     s0 @ 512 -        \ for stack
        !            61:     here - ;
1.1       anton      62: 
                     63: \ [COMPILE]                                             17may93jaw
                     64: 
1.11    ! anton      65: : [compile] ( compilation "name" -- ; run-time ? -- ? ) \ core-ext bracket-compile
        !            66:     ' compile, ; immediate
1.1       anton      67: 
                     68: \ MARKER                                                17may93jaw
                     69: 
                     70: \ : marker here last @ create , , DOES> dup @ last ! cell+ @ dp ! ;
                     71: \ doesn't work now. vocabularies?
                     72: 
                     73: \ CONVERT                                               17may93jaw
                     74: 
1.11    ! anton      75: : convert ( ud1 c-addr1 -- ud2 c-addr2 ) \ core-ext
        !            76:     \ obsolescent; supersedet by @code{>number}.
        !            77:     true >number drop ;
1.1       anton      78: 
                     79: \ ERASE                                                 17may93jaw
                     80: 
1.11    ! anton      81: : erase ( addr len -- ) \ core-ext
        !            82:     \ !! dependence on "1 chars 1 ="
        !            83:     ( 0 1 chars um/mod nip )  0 fill ;
        !            84: : blank ( addr len -- ) \ string
        !            85:     bl fill ;
1.1       anton      86: 
1.7       pazsan     87: \ SEARCH                                                02sep94py
                     88: 
1.11    ! anton      89: : search   ( buf buflen text textlen -- restbuf restlen flag ) \ string
        !            90:     2over  2 pick - 1+ 3 pick c@ >r
        !            91:     BEGIN
        !            92:        r@ scan dup
        !            93:     WHILE
        !            94:        >r >r  2dup r@ -text
        !            95:        0=
        !            96:        IF
        !            97:            >r drop 2drop r> r> r> rot + 1- rdrop true
        !            98:            EXIT
        !            99:        THEN
        !           100:        r> r>  1 /string
        !           101:     REPEAT
        !           102:     2drop 2drop  rdrop false ;
1.7       pazsan    103: 
1.1       anton     104: \ ROLL                                                  17may93jaw
                    105: 
1.11    ! anton     106: : roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
1.10      pazsan    107:   dup 1+ pick >r
                    108:   cells sp@ cell+ dup cell+ rot move drop r> ;
1.1       anton     109: 
                    110: \ SOURCE-ID SAVE-INPUT RESTORE-INPUT                    11jun93jaw
                    111: 
1.11    ! anton     112: : source-id ( -- 0 | -1 | fileid ) \ core-ext source-i-d
1.4       pazsan    113:   loadfile @ dup 0= IF  drop loadline @ 0 min  THEN ;
1.1       anton     114: 
1.11    ! anton     115: : save-input ( -- x1 .. xn n ) \ core-ext
1.1       anton     116:   >in @
                    117:   loadfile @ ?dup
1.4       pazsan    118:   IF    dup file-position throw loadline @ >tib @ 6
                    119:         #tib @ >tib +!
                    120:   ELSE  loadline @ blk @ linestart @ >tib @ 5 THEN
                    121: ;
1.1       anton     122: 
1.11    ! anton     123: : restore-input ( x1 .. xn n -- flag ) \ core-ext
1.4       pazsan    124:   swap >tib !
                    125:   6 = IF   loadline ! rot dup loadfile !
1.1       anton     126:            reposition-file IF drop true EXIT THEN
                    127:       ELSE linestart ! blk !
                    128:            dup loadline @ <> IF 2drop true EXIT THEN
                    129:            loadline !
                    130:       THEN
                    131:   >in ! false ;
                    132: 
                    133: 
                    134: 
                    135: \ This things we don't need, but for being complete... jaw
                    136: 
                    137: \ EXPECT SPAN                                           17may93jaw
                    138: 
1.11    ! anton     139: variable span ( -- a-addr ) \ core-ext
        !           140: \ obsolescent
1.1       anton     141: 
1.11    ! anton     142: : expect ( c-addr +len -- ) \ core-ext
        !           143:     \ obsolescent; use accept
1.9       anton     144:     0 rot over
                    145:     BEGIN ( maxlen span c-addr pos1 )
                    146:        key decode ( maxlen span c-addr pos2 flag )
                    147:        >r 2over = r> or
                    148:     UNTIL
                    149:     type-rest drop
                    150:     2drop nip span ! ;
1.1       anton     151: