Return to extend.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/extend.fs, revision 1.7

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