Return to extend.fs CVS log

Up to [gforth] / gforth

added answords.fs and strsignal.c
added checking of documenetation of ANS Forth words
Fixed many documentation errors and added some documentation
signal handling now uses strsignal and can handle signals not present on all machines

    1: \ EXTEND.FS    CORE-EXT Word not fully tested!         12may93jaw
    2: 
    3: \ May be cross-compiled
    4: 
    5: decimal
    6: 
    7: \ .(                                                    12may93jaw
    8: 
    9: : .(   ( compilation "...<paren>" -- ) \ core-ext dot-paren
   10:     [char] ) parse type ; immediate
   11: 
   12: \ VALUE 2>R 2R> 2R@                                     17may93jaw
   13: 
   14: : value ( w -- ) \ core-ext
   15:   (constant) , ;
   16: \ !! 2value
   17: 
   18: : 2Literal ( compilation w1 w2 -- ; run-time  -- w1 w2 ) \ double two-literal
   19:     swap postpone Literal  postpone Literal ; immediate restrict
   20: 
   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 ;
   26: 
   27: \ CASE OF ENDOF ENDCASE                                 17may93jaw
   28: 
   29: \ just as described in dpANS5
   30: 
   31: 0 CONSTANT case ( compilation  -- case-sys ; run-time  -- ) \ core-ext
   32:     immediate
   33: 
   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
   46: 
   47: \ C"                                                    17may93jaw
   48: 
   49: : (c")     "lit ;
   50: 
   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
   56: 
   57: \ UNUSED                                                17may93jaw
   58: 
   59: : unused ( -- u ) \ core-ext
   60:     s0 @ 512 -        \ for stack
   61:     here - ;
   62: 
   63: \ [COMPILE]                                             17may93jaw
   64: 
   65: : [compile] ( compilation "name" -- ; run-time ? -- ? ) \ core-ext bracket-compile
   66:     ' compile, ; immediate
   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: 
   75: : convert ( ud1 c-addr1 -- ud2 c-addr2 ) \ core-ext
   76:     \ obsolescent; supersedet by @code{>number}.
   77:     true >number drop ;
   78: 
   79: \ ERASE                                                 17may93jaw
   80: 
   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 ;
   86: 
   87: \ SEARCH                                                02sep94py
   88: 
   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 ;
  103: 
  104: \ ROLL                                                  17may93jaw
  105: 
  106: : roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
  107:   dup 1+ pick >r
  108:   cells sp@ cell+ dup cell+ rot move drop r> ;
  109: 
  110: \ SOURCE-ID SAVE-INPUT RESTORE-INPUT                    11jun93jaw
  111: 
  112: : source-id ( -- 0 | -1 | fileid ) \ core-ext source-i-d
  113:   loadfile @ dup 0= IF  drop loadline @ 0 min  THEN ;
  114: 
  115: : save-input ( -- x1 .. xn n ) \ core-ext
  116:   >in @
  117:   loadfile @ ?dup
  118:   IF    dup file-position throw loadline @ >tib @ 6
  119:         #tib @ >tib +!
  120:   ELSE  loadline @ blk @ linestart @ >tib @ 5 THEN
  121: ;
  122: 
  123: : restore-input ( x1 .. xn n -- flag ) \ core-ext
  124:   swap >tib !
  125:   6 = IF   loadline ! rot dup loadfile !
  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: 
  139: variable span ( -- a-addr ) \ core-ext
  140: \ obsolescent
  141: 
  142: : expect ( c-addr +len -- ) \ core-ext
  143:     \ obsolescent; use accept
  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 ! ;
  151: