File:  [gforth] / gforth / extend.fs
Revision 1.10: download - view: text, annotated - select for diffs
Thu Jul 6 15:57:27 1995 UTC (24 years, 6 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added makedoc facility to cross compiler.
Now most doc-* reverences are resolved.

    1: \ EXTEND.FS    CORE-EXT Word not fully tested!         12may93jaw
    2: 
    3: \ May be cross-compiled
    4: 
    5: decimal
    6: 
    7: \ .(                                                    12may93jaw
    8: 
    9: : .(   ( -- )
   10:     [char] ) parse type ; immediate
   11: 
   12: \ VALUE 2>R 2R> 2R@                                     17may93jaw
   13: 
   14: : value ( n -- )
   15:   (constant) , ;
   16: \ !! 2value
   17: 
   18: : 2Literal  swap postpone Literal  postpone Literal ;
   19:   immediate restrict
   20: 
   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: 
   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: 
   54: : unused   s0 @ 512 -        \ for stack
   55:            here - ;
   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: 
   73: : erase ( addr len -- )  ( 0 1 chars um/mod nip )  0 fill ;
   74: : blank ( addr len -- )  ( 0 1 chars um/mod nip ) bl fill ;
   75: 
   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: 
   86: \ ROLL                                                  17may93jaw
   87: 
   88: : roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) 
   89:   dup 1+ pick >r
   90:   cells sp@ cell+ dup cell+ rot move drop r> ;
   91: 
   92: \ SOURCE-ID SAVE-INPUT RESTORE-INPUT                    11jun93jaw
   93: 
   94: : source-id ( -- 0 | -1 | fileid )
   95:   loadfile @ dup 0= IF  drop loadline @ 0 min  THEN ;
   96: 
   97: : save-input ( -- x1 .. xn n )
   98:   >in @
   99:   loadfile @ ?dup
  100:   IF    dup file-position throw loadline @ >tib @ 6
  101:         #tib @ >tib +!
  102:   ELSE  loadline @ blk @ linestart @ >tib @ 5 THEN
  103: ;
  104: 
  105: : restore-input ( x1 .. xn n -- flag )
  106:   swap >tib !
  107:   6 = IF   loadline ! rot dup loadfile !
  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 -- )
  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 ! ;
  131: 

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