Commit | Line | Data |
---|---|---|
8e9db35f PB |
1 | \ @(#) t_corex.fth 98/03/16 1.2 |
2 | \ Test ANS Forth Core Extensions | |
3 | \ | |
4 | \ Copyright 1994 3DO, Phil Burk | |
5 | ||
6 | INCLUDE? }T{ t_tools.fth | |
7 | ||
8 | ANEW TASK-T_COREX.FTH | |
9 | ||
10 | DECIMAL | |
11 | ||
12 | \ STUB because missing definition in pForth - FIXME | |
13 | : SAVE-INPUT ; | |
14 | : RESTORE-INPUT -1 ; | |
15 | ||
16 | TEST{ | |
17 | ||
18 | \ ========================================================== | |
19 | T{ 1 2 3 }T{ 1 2 3 }T | |
20 | ||
21 | \ ----------------------------------------------------- .( | |
22 | T{ 27 .( IF YOU SEE THIS THEN .( WORKED!) }T{ 27 }T | |
23 | ||
24 | CR .( 1234 - SHOULD LINE UP WITH NEXT LINE.) CR 1234 8 .R CR | |
25 | ||
26 | T{ .( ) 987 .( TEST NULL STRING IN .( ) CR }T{ 987 }T | |
27 | ||
28 | \ ----------------------------------------------------- 0<> | |
29 | T{ 5 0<> }T{ TRUE }T | |
30 | T{ 0 0<> }T{ 0 }T | |
31 | T{ -1000 0<> }T{ TRUE }T | |
32 | ||
33 | \ ----------------------------------------------------- 2>R 2R> 2R@ | |
34 | : T2>R ( -- .... ) | |
35 | 17 | |
36 | 20 5 2>R | |
37 | 19 | |
38 | 2R@ | |
39 | 37 | |
40 | 2R> | |
41 | \ 2>R should be the equivalent of SWAP >R >R so this next construct | |
42 | \ should reduce to a SWAP. | |
43 | 88 77 2>R R> R> | |
44 | ; | |
45 | T{ T2>R }T{ 17 19 20 5 37 20 5 77 88 }T | |
46 | ||
47 | \ ----------------------------------------------------- :NONAME | |
48 | T{ :NONAME 100 50 + ; EXECUTE }T{ 150 }T | |
49 | ||
50 | \ ----------------------------------------------------- <> | |
51 | T{ 12345 12305 <> }T{ TRUE }T | |
52 | T{ HEX 98765432 98765432 DECIMAL <> }T{ 0 }T | |
53 | ||
54 | \ ----------------------------------------------------- ?DO | |
55 | : T?DO ( n -- sum_n ) 0 SWAP 1+ 0 ?DO i + LOOP ; | |
56 | T{ 0 T?DO }T{ 0 }T | |
57 | T{ 4 T?DO }T{ 10 }T | |
58 | ||
59 | \ ----------------------------------------------------- AGAIN | |
60 | : T.AGAIN ( n -- ) | |
61 | BEGIN | |
62 | DUP . | |
63 | DUP 6 < IF EXIT THEN | |
64 | 1- | |
65 | AGAIN | |
66 | ; | |
67 | T{ 10 T.AGAIN CR }T{ 5 }T | |
68 | ||
69 | \ ----------------------------------------------------- C" | |
70 | : T.C" ( -- $STRING ) | |
71 | C" x5&" | |
72 | ; | |
73 | T{ T.C" C@ }T{ 3 }T | |
74 | T{ T.C" COUNT DROP C@ }T{ CHAR x }T | |
75 | T{ T.C" COUNT DROP CHAR+ C@ }T{ CHAR 5 }T | |
76 | T{ T.C" COUNT DROP 2 CHARS + C@ }T{ CHAR & }T | |
77 | ||
78 | \ ----------------------------------------------------- CASE | |
79 | : T.CASE ( N -- ) | |
80 | CASE | |
81 | 1 OF 101 ENDOF | |
82 | 27 OF 892 ENDOF | |
83 | 941 SWAP \ default | |
84 | ENDCASE | |
85 | ; | |
86 | T{ 1 T.CASE }T{ 101 }T | |
87 | T{ 27 T.CASE }T{ 892 }T | |
88 | T{ 49 T.CASE }T{ 941 }T | |
89 | ||
90 | \ ----------------------------------------------------- COMPILE, | |
91 | : COMPILE.SWAP ['] SWAP COMPILE, ; IMMEDIATE | |
92 | : T.COMPILE, | |
93 | 19 20 27 COMPILE.SWAP 39 | |
94 | ; | |
95 | T{ T.COMPILE, }T{ 19 27 20 39 }T | |
96 | ||
97 | \ ----------------------------------------------------- CONVERT | |
98 | : T.CONVERT | |
99 | 0 S>D S" 1234xyz" DROP CONVERT | |
100 | >R | |
101 | D>S | |
102 | R> C@ | |
103 | ; | |
104 | T{ T.CONVERT }T{ 1234 CHAR x }T | |
105 | ||
106 | \ ----------------------------------------------------- ERASE | |
107 | : T.COMMA.SEQ ( n -- , lay down N sequential bytes ) | |
108 | 0 ?DO I C, LOOP | |
109 | ; | |
110 | CREATE T-ERASE-DATA 64 T.COMMA.SEQ | |
111 | T{ T-ERASE-DATA 8 + C@ }T{ 8 }T | |
112 | T{ T-ERASE-DATA 7 + 3 ERASE | |
113 | T{ T-ERASE-DATA 6 + C@ }T{ 6 }T | |
114 | T{ T-ERASE-DATA 7 + C@ }T{ 0 }T | |
115 | T{ T-ERASE-DATA 8 + C@ }T{ 0 }T | |
116 | T{ T-ERASE-DATA 9 + C@ }T{ 0 }T | |
117 | T{ T-ERASE-DATA 10 + C@ }T{ 10 }T | |
118 | ||
119 | \ ----------------------------------------------------- FALSE | |
120 | T{ FALSE }T{ 0 }T | |
121 | ||
122 | \ ----------------------------------------------------- HEX | |
123 | T{ HEX 10 DECIMAL }T{ 16 }T | |
124 | ||
125 | \ ----------------------------------------------------- MARKER | |
126 | : INDIC? ( <name> -- ifInDic , is the following word defined? ) | |
127 | bl word find | |
128 | swap drop 0= 0= | |
129 | ; | |
130 | create FOOBAR | |
131 | MARKER MYMARK \ create word that forgets itself | |
132 | create GOOFBALL | |
133 | MYMARK | |
134 | T{ indic? foobar indic? mymark indic? goofball }T{ true false false }T | |
135 | ||
136 | \ ----------------------------------------------------- NIP | |
137 | T{ 33 44 55 NIP }T{ 33 55 }T | |
138 | ||
139 | \ ----------------------------------------------------- PARSE | |
140 | : T.PARSE ( char <string>char -- addr num ) | |
141 | PARSE | |
142 | >R \ save length | |
143 | PAD R@ CMOVE \ move string to pad | |
144 | PAD R> | |
145 | ; | |
146 | T{ CHAR % T.PARSE wxyz% SWAP C@ }T{ 4 CHAR w }T | |
147 | ||
148 | \ ----------------------------------------------------- PICK | |
149 | T{ 13 12 11 10 2 PICK }T{ 13 12 11 10 12 }T | |
150 | ||
151 | \ ----------------------------------------------------- QUERY | |
152 | T{ ' QUERY 0<> }T{ TRUE }T | |
153 | ||
154 | \ ----------------------------------------------------- REFILL | |
155 | T{ ' REFILL 0<> }T{ TRUE }T | |
156 | ||
157 | \ ----------------------------------------------------- RESTORE-INPUT | |
158 | T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T \ EXPECTED FAILURE | |
159 | ||
160 | \ ----------------------------------------------------- ROLL | |
161 | T{ 15 14 13 12 11 10 0 ROLL }T{ 15 14 13 12 11 10 }T | |
162 | T{ 15 14 13 12 11 10 1 ROLL }T{ 15 14 13 12 10 11 }T | |
163 | T{ 15 14 13 12 11 10 2 ROLL }T{ 15 14 13 11 10 12 }T | |
164 | T{ 15 14 13 12 11 10 3 ROLL }T{ 15 14 12 11 10 13 }T | |
165 | T{ 15 14 13 12 11 10 4 ROLL }T{ 15 13 12 11 10 14 }T | |
166 | ||
167 | \ ----------------------------------------------------- SOURCE-ID | |
168 | T{ SOURCE-ID 0<> }T{ TRUE }T | |
169 | T{ : T.SOURCE-ID S" SOURCE-ID" EVALUATE ; T.SOURCE-ID }T{ -1 }T | |
170 | ||
171 | \ ----------------------------------------------------- SPAN | |
172 | T{ ' SPAN 0<> }T{ TRUE }T | |
173 | ||
174 | \ ----------------------------------------------------- TO VALUE | |
175 | 333 VALUE MY-VALUE | |
176 | T{ MY-VALUE }T{ 333 }T | |
177 | T{ 1000 TO MY-VALUE MY-VALUE }T{ 1000 }T | |
178 | : TEST.VALUE ( -- 19 100 ) | |
179 | 100 TO MY-VALUE | |
180 | 19 | |
181 | MY-VALUE | |
182 | ; | |
183 | T{ TEST.VALUE }T{ 19 100 }T | |
184 | ||
185 | \ ----------------------------------------------------- TRUE | |
186 | T{ TRUE }T{ 0 0= }T | |
187 | ||
188 | \ ----------------------------------------------------- TUCK | |
189 | T{ 44 55 66 TUCK }T{ 44 66 55 66 }T | |
190 | ||
191 | \ ----------------------------------------------------- U.R | |
192 | HEX CR .( ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR | |
193 | ABCD4321 C U.R CR DECIMAL | |
194 | ||
195 | \ ----------------------------------------------------- U> | |
196 | T{ -5 3 U> }T{ TRUE }T | |
197 | T{ 10 8 U> }T{ TRUE }T | |
198 | ||
199 | \ ----------------------------------------------------- UNUSED | |
200 | T{ UNUSED 0> }T{ TRUE }T | |
201 | ||
202 | \ ----------------------------------------------------- WITHIN | |
203 | T{ 4 5 10 WITHIN }T{ 0 }T | |
204 | T{ 5 5 10 WITHIN }T{ TRUE }T | |
205 | T{ 9 5 10 WITHIN }T{ TRUE }T | |
206 | T{ 10 5 10 WITHIN }T{ 0 }T | |
207 | ||
208 | T{ 4 10 5 WITHIN }T{ TRUE }T | |
209 | T{ 5 10 5 WITHIN }T{ 0 }T | |
210 | T{ 9 10 5 WITHIN }T{ 0 }T | |
211 | T{ 10 10 5 WITHIN }T{ TRUE }T | |
212 | ||
213 | T{ -6 -5 10 WITHIN }T{ 0 }T | |
214 | T{ -5 -5 10 WITHIN }T{ TRUE }T | |
215 | T{ 9 -5 10 WITHIN }T{ TRUE }T | |
216 | T{ 10 -5 10 WITHIN }T{ 0 }T | |
217 | ||
218 | ||
219 | \ ----------------------------------------------------- [COMPILE] | |
220 | : T.[COMPILE].IF [COMPILE] IF ; IMMEDIATE | |
221 | : T.[COMPILE] 40 0> T.[COMPILE].IF 97 ELSE 53 THEN 97 = ; | |
222 | T{ T.[COMPILE] }T{ TRUE }T | |
223 | ||
224 | \ ----------------------------------------------------- \ | |
225 | }TEST | |
226 |