File:  [gforth] / gforth / extend.fs
Revision 1.11: download - view: text, annotated - select for diffs
Mon Oct 16 18:33:07 1995 UTC (24 years ago) by anton
Branches: MAIN
CVS tags: HEAD
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

\ EXTEND.FS    CORE-EXT Word not fully tested!         12may93jaw

\ May be cross-compiled

decimal

\ .(                                                    12may93jaw

: .(   ( compilation "...<paren>" -- ) \ core-ext dot-paren
    [char] ) parse type ; immediate

\ VALUE 2>R 2R> 2R@                                     17may93jaw

: value ( w -- ) \ core-ext
  (constant) , ;
\ !! 2value

: 2Literal ( compilation w1 w2 -- ; run-time  -- w1 w2 ) \ double two-literal
    swap postpone Literal  postpone Literal ; immediate restrict

: m*/ ( d1 n2 u3 -- dqout ) \ double m-star-slash
    >r s>d >r abs -rot
    s>d r> xor r> swap >r >r dabs rot tuck um* 2swap um*
    swap >r 0 d+ r> -rot r@ um/mod -rot r> um/mod nip swap
    r> IF dnegate THEN ;

\ CASE OF ENDOF ENDCASE                                 17may93jaw

\ just as described in dpANS5

0 CONSTANT case ( compilation  -- case-sys ; run-time  -- ) \ core-ext
    immediate

: of ( compilation  -- of-sys ; run-time x1 x2 -- |x1 ) \ core-ext
    \ !! the implementation does not match the stack effect
    1+ >r
    postpone over postpone = postpone if postpone drop
    r> ; immediate

: endof ( compilation case-sys1 of-sys -- case-sys2 ; run-time  -- ) \ core-ext end-of
    >r postpone else r> ; immediate

: endcase ( compilation case-sys -- ; run-time x -- ) \ core-ext end-case
    postpone drop
    0 ?do postpone then loop ; immediate

\ C"                                                    17may93jaw

: (c")     "lit ;

: CLiteral
    postpone (c") here over char+ allot  place align ; immediate restrict

: C" ( compilation "...<quote>" -- ; run-time  -- c-addr ) \ core-ext c-quote
    [char] " parse postpone CLiteral ; immediate restrict

\ UNUSED                                                17may93jaw

: unused ( -- u ) \ core-ext
    s0 @ 512 -        \ for stack
    here - ;

\ [COMPILE]                                             17may93jaw

: [compile] ( compilation "name" -- ; run-time ? -- ? ) \ core-ext bracket-compile
    ' compile, ; immediate

\ MARKER                                                17may93jaw

\ : marker here last @ create , , DOES> dup @ last ! cell+ @ dp ! ;
\ doesn't work now. vocabularies?

\ CONVERT                                               17may93jaw

: convert ( ud1 c-addr1 -- ud2 c-addr2 ) \ core-ext
    \ obsolescent; supersedet by @code{>number}.
    true >number drop ;

\ ERASE                                                 17may93jaw

: erase ( addr len -- ) \ core-ext
    \ !! dependence on "1 chars 1 ="
    ( 0 1 chars um/mod nip )  0 fill ;
: blank ( addr len -- ) \ string
    bl fill ;

\ SEARCH                                                02sep94py

: search   ( buf buflen text textlen -- restbuf restlen flag ) \ string
    2over  2 pick - 1+ 3 pick c@ >r
    BEGIN
	r@ scan dup
    WHILE
	>r >r  2dup r@ -text
	0=
	IF
	    >r drop 2drop r> r> r> rot + 1- rdrop true
	    EXIT
	THEN
	r> r>  1 /string
    REPEAT
    2drop 2drop  rdrop false ;

\ ROLL                                                  17may93jaw

: roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
  dup 1+ pick >r
  cells sp@ cell+ dup cell+ rot move drop r> ;

\ SOURCE-ID SAVE-INPUT RESTORE-INPUT                    11jun93jaw

: source-id ( -- 0 | -1 | fileid ) \ core-ext source-i-d
  loadfile @ dup 0= IF  drop loadline @ 0 min  THEN ;

: save-input ( -- x1 .. xn n ) \ core-ext
  >in @
  loadfile @ ?dup
  IF    dup file-position throw loadline @ >tib @ 6
        #tib @ >tib +!
  ELSE  loadline @ blk @ linestart @ >tib @ 5 THEN
;

: restore-input ( x1 .. xn n -- flag ) \ core-ext
  swap >tib !
  6 = IF   loadline ! rot dup loadfile !
           reposition-file IF drop true EXIT THEN
      ELSE linestart ! blk !
           dup loadline @ <> IF 2drop true EXIT THEN
           loadline !
      THEN
  >in ! false ;



\ This things we don't need, but for being complete... jaw

\ EXPECT SPAN                                           17may93jaw

variable span ( -- a-addr ) \ core-ext
\ obsolescent

: expect ( c-addr +len -- ) \ core-ext
    \ obsolescent; use accept
    0 rot over
    BEGIN ( maxlen span c-addr pos1 )
	key decode ( maxlen span c-addr pos2 flag )
	>r 2over = r> or
    UNTIL
    type-rest drop
    2drop nip span ! ;


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