File:  [gforth] / gforth / extend.fs
Revision 1.9: download - view: text, annotated - select for diffs
Thu Apr 20 09:42:50 1995 UTC (28 years, 11 months ago) by anton
Branches: MAIN
CVS tags: HEAD
added "system documentation requirements" section to gforth.ds.
added answers for environmental queries for wordsets.
changed W/O file access mode from "w+" to "w".
S" now uses a buffer
BIN is now idempotent
added FILE-STATUS
some other minor changes and bug fixes.

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

\ May be cross-compiled

decimal

\ .(                                                    12may93jaw

: .(   ( -- )
    [char] ) parse type ; immediate

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

: value ( n -- )
  (constant) , ;
\ !! 2value

: 2Literal  swap postpone Literal  postpone Literal ;
  immediate restrict

: m*/    ( d1 n2 u3 -- dqout )    >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 immediate

: of
        1+ >r
        postpone over postpone = postpone if postpone drop
        r> ; immediate

: endof
        >r postpone else r> ; immediate

: endcase
        postpone drop
        0 ?do postpone then loop ; immediate

\ C"                                                    17may93jaw

: (c")     "lit ;

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

\ UNUSED                                                17may93jaw

: unused   s0 @ 512 -        \ for stack
           here - ;

\ [COMPILE]                                             17may93jaw

: [compile] 
 ' compile, ; immediate

\ MARKER                                                17may93jaw

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

\ CONVERT                                               17may93jaw

: convert true >number drop ;

\ ERASE                                                 17may93jaw

: erase ( 0 1 chars um/mod nip )  0 fill ;
: blank ( 0 1 chars um/mod nip ) bl fill ;

\ SEARCH                                                02sep94py

: search   ( buf buflen text textlen -- restbuf restlen flag )
  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  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 )
  loadfile @ dup 0= IF  drop loadline @ 0 min  THEN ;

: save-input ( -- x1 .. xn n )
  >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 )
  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

: expect ( c-addr +len -- )
    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>