File:
[gforth] /
gforth /
extend.fs
Revision
1.9:
download - view:
text,
annotated -
select for diffs
Thu Apr 20 09:42:50 1995 UTC (29 years 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>