Annotation of gforth/extend.fs, revision 1.10

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

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