File:
[gforth] /
gforth /
extend.fs
Revision
1.11:
download - view:
text,
annotated -
select for diffs
Mon Oct 16 18:33:07 1995 UTC (27 years, 3 months 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
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:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>