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.
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 ( 0 1 chars um/mod nip ) 0 fill ;
74: : blank ( 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 dup 1+ pick >r
89: cells sp@ cell+ dup cell+ rot move drop r> ;
90:
91: \ SOURCE-ID SAVE-INPUT RESTORE-INPUT 11jun93jaw
92:
93: : source-id ( -- 0 | -1 | fileid )
94: loadfile @ dup 0= IF drop loadline @ 0 min THEN ;
95:
96: : save-input ( -- x1 .. xn n )
97: >in @
98: loadfile @ ?dup
99: IF dup file-position throw loadline @ >tib @ 6
100: #tib @ >tib +!
101: ELSE loadline @ blk @ linestart @ >tib @ 5 THEN
102: ;
103:
104: : restore-input ( x1 .. xn n -- flag )
105: swap >tib !
106: 6 = IF loadline ! rot dup loadfile !
107: reposition-file IF drop true EXIT THEN
108: ELSE linestart ! blk !
109: dup loadline @ <> IF 2drop true EXIT THEN
110: loadline !
111: THEN
112: >in ! false ;
113:
114:
115:
116: \ This things we don't need, but for being complete... jaw
117:
118: \ EXPECT SPAN 17may93jaw
119:
120: variable span
121:
122: : expect ( c-addr +len -- )
123: 0 rot over
124: BEGIN ( maxlen span c-addr pos1 )
125: key decode ( maxlen span c-addr pos2 flag )
126: >r 2over = r> or
127: UNTIL
128: type-rest drop
129: 2drop nip span ! ;
130:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>