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 | ||
8e9db35f PB |
12 | TEST{ |
13 | ||
14 | \ ========================================================== | |
15 | T{ 1 2 3 }T{ 1 2 3 }T | |
16 | ||
17 | \ ----------------------------------------------------- .( | |
18 | T{ 27 .( IF YOU SEE THIS THEN .( WORKED!) }T{ 27 }T | |
19 | ||
20 | CR .( 1234 - SHOULD LINE UP WITH NEXT LINE.) CR 1234 8 .R CR | |
21 | ||
22 | T{ .( ) 987 .( TEST NULL STRING IN .( ) CR }T{ 987 }T | |
23 | ||
24 | \ ----------------------------------------------------- 0<> | |
25 | T{ 5 0<> }T{ TRUE }T | |
26 | T{ 0 0<> }T{ 0 }T | |
27 | T{ -1000 0<> }T{ TRUE }T | |
28 | ||
29 | \ ----------------------------------------------------- 2>R 2R> 2R@ | |
30 | : T2>R ( -- .... ) | |
31 | 17 | |
32 | 20 5 2>R | |
33 | 19 | |
34 | 2R@ | |
35 | 37 | |
36 | 2R> | |
37 | \ 2>R should be the equivalent of SWAP >R >R so this next construct | |
38 | \ should reduce to a SWAP. | |
39 | 88 77 2>R R> R> | |
40 | ; | |
41 | T{ T2>R }T{ 17 19 20 5 37 20 5 77 88 }T | |
42 | ||
43 | \ ----------------------------------------------------- :NONAME | |
44 | T{ :NONAME 100 50 + ; EXECUTE }T{ 150 }T | |
45 | ||
46 | \ ----------------------------------------------------- <> | |
47 | T{ 12345 12305 <> }T{ TRUE }T | |
48 | T{ HEX 98765432 98765432 DECIMAL <> }T{ 0 }T | |
49 | ||
50 | \ ----------------------------------------------------- ?DO | |
51 | : T?DO ( n -- sum_n ) 0 SWAP 1+ 0 ?DO i + LOOP ; | |
52 | T{ 0 T?DO }T{ 0 }T | |
53 | T{ 4 T?DO }T{ 10 }T | |
54 | ||
55 | \ ----------------------------------------------------- AGAIN | |
56 | : T.AGAIN ( n -- ) | |
57 | BEGIN | |
58 | DUP . | |
59 | DUP 6 < IF EXIT THEN | |
60 | 1- | |
61 | AGAIN | |
62 | ; | |
63 | T{ 10 T.AGAIN CR }T{ 5 }T | |
64 | ||
65 | \ ----------------------------------------------------- C" | |
66 | : T.C" ( -- $STRING ) | |
67 | C" x5&" | |
68 | ; | |
69 | T{ T.C" C@ }T{ 3 }T | |
70 | T{ T.C" COUNT DROP C@ }T{ CHAR x }T | |
71 | T{ T.C" COUNT DROP CHAR+ C@ }T{ CHAR 5 }T | |
72 | T{ T.C" COUNT DROP 2 CHARS + C@ }T{ CHAR & }T | |
73 | ||
74 | \ ----------------------------------------------------- CASE | |
75 | : T.CASE ( N -- ) | |
76 | CASE | |
77 | 1 OF 101 ENDOF | |
78 | 27 OF 892 ENDOF | |
79 | 941 SWAP \ default | |
80 | ENDCASE | |
81 | ; | |
82 | T{ 1 T.CASE }T{ 101 }T | |
83 | T{ 27 T.CASE }T{ 892 }T | |
84 | T{ 49 T.CASE }T{ 941 }T | |
85 | ||
86 | \ ----------------------------------------------------- COMPILE, | |
87 | : COMPILE.SWAP ['] SWAP COMPILE, ; IMMEDIATE | |
88 | : T.COMPILE, | |
89 | 19 20 27 COMPILE.SWAP 39 | |
90 | ; | |
91 | T{ T.COMPILE, }T{ 19 27 20 39 }T | |
92 | ||
93 | \ ----------------------------------------------------- CONVERT | |
94 | : T.CONVERT | |
95 | 0 S>D S" 1234xyz" DROP CONVERT | |
96 | >R | |
97 | D>S | |
98 | R> C@ | |
99 | ; | |
100 | T{ T.CONVERT }T{ 1234 CHAR x }T | |
101 | ||
102 | \ ----------------------------------------------------- ERASE | |
103 | : T.COMMA.SEQ ( n -- , lay down N sequential bytes ) | |
104 | 0 ?DO I C, LOOP | |
105 | ; | |
106 | CREATE T-ERASE-DATA 64 T.COMMA.SEQ | |
107 | T{ T-ERASE-DATA 8 + C@ }T{ 8 }T | |
108 | T{ T-ERASE-DATA 7 + 3 ERASE | |
109 | T{ T-ERASE-DATA 6 + C@ }T{ 6 }T | |
110 | T{ T-ERASE-DATA 7 + C@ }T{ 0 }T | |
111 | T{ T-ERASE-DATA 8 + C@ }T{ 0 }T | |
112 | T{ T-ERASE-DATA 9 + C@ }T{ 0 }T | |
113 | T{ T-ERASE-DATA 10 + C@ }T{ 10 }T | |
114 | ||
115 | \ ----------------------------------------------------- FALSE | |
116 | T{ FALSE }T{ 0 }T | |
117 | ||
118 | \ ----------------------------------------------------- HEX | |
119 | T{ HEX 10 DECIMAL }T{ 16 }T | |
120 | ||
121 | \ ----------------------------------------------------- MARKER | |
122 | : INDIC? ( <name> -- ifInDic , is the following word defined? ) | |
123 | bl word find | |
124 | swap drop 0= 0= | |
125 | ; | |
126 | create FOOBAR | |
127 | MARKER MYMARK \ create word that forgets itself | |
128 | create GOOFBALL | |
129 | MYMARK | |
130 | T{ indic? foobar indic? mymark indic? goofball }T{ true false false }T | |
131 | ||
132 | \ ----------------------------------------------------- NIP | |
133 | T{ 33 44 55 NIP }T{ 33 55 }T | |
134 | ||
135 | \ ----------------------------------------------------- PARSE | |
136 | : T.PARSE ( char <string>char -- addr num ) | |
137 | PARSE | |
138 | >R \ save length | |
139 | PAD R@ CMOVE \ move string to pad | |
140 | PAD R> | |
141 | ; | |
142 | T{ CHAR % T.PARSE wxyz% SWAP C@ }T{ 4 CHAR w }T | |
143 | ||
144 | \ ----------------------------------------------------- PICK | |
145 | T{ 13 12 11 10 2 PICK }T{ 13 12 11 10 12 }T | |
146 | ||
147 | \ ----------------------------------------------------- QUERY | |
148 | T{ ' QUERY 0<> }T{ TRUE }T | |
149 | ||
150 | \ ----------------------------------------------------- REFILL | |
151 | T{ ' REFILL 0<> }T{ TRUE }T | |
152 | ||
153 | \ ----------------------------------------------------- RESTORE-INPUT | |
08689895 HE |
154 | T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T |
155 | ||
156 | \ TESTING SAVE-INPUT and RESTORE-INPUT with a string source | |
157 | ||
158 | VARIABLE SI_INC 0 SI_INC ! | |
159 | ||
160 | : SI1 | |
161 | SI_INC @ >IN +! | |
162 | 15 SI_INC ! | |
163 | ; | |
164 | ||
165 | : S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; | |
166 | ||
167 | T{ S$ EVALUATE SI_INC @ }T{ 0 2345 15 }T | |
8e9db35f PB |
168 | |
169 | \ ----------------------------------------------------- ROLL | |
170 | T{ 15 14 13 12 11 10 0 ROLL }T{ 15 14 13 12 11 10 }T | |
171 | T{ 15 14 13 12 11 10 1 ROLL }T{ 15 14 13 12 10 11 }T | |
172 | T{ 15 14 13 12 11 10 2 ROLL }T{ 15 14 13 11 10 12 }T | |
173 | T{ 15 14 13 12 11 10 3 ROLL }T{ 15 14 12 11 10 13 }T | |
174 | T{ 15 14 13 12 11 10 4 ROLL }T{ 15 13 12 11 10 14 }T | |
175 | ||
176 | \ ----------------------------------------------------- SOURCE-ID | |
177 | T{ SOURCE-ID 0<> }T{ TRUE }T | |
178 | T{ : T.SOURCE-ID S" SOURCE-ID" EVALUATE ; T.SOURCE-ID }T{ -1 }T | |
179 | ||
180 | \ ----------------------------------------------------- SPAN | |
181 | T{ ' SPAN 0<> }T{ TRUE }T | |
182 | ||
183 | \ ----------------------------------------------------- TO VALUE | |
184 | 333 VALUE MY-VALUE | |
185 | T{ MY-VALUE }T{ 333 }T | |
186 | T{ 1000 TO MY-VALUE MY-VALUE }T{ 1000 }T | |
187 | : TEST.VALUE ( -- 19 100 ) | |
188 | 100 TO MY-VALUE | |
189 | 19 | |
190 | MY-VALUE | |
191 | ; | |
192 | T{ TEST.VALUE }T{ 19 100 }T | |
193 | ||
194 | \ ----------------------------------------------------- TRUE | |
195 | T{ TRUE }T{ 0 0= }T | |
196 | ||
197 | \ ----------------------------------------------------- TUCK | |
198 | T{ 44 55 66 TUCK }T{ 44 66 55 66 }T | |
199 | ||
200 | \ ----------------------------------------------------- U.R | |
201 | HEX CR .( ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR | |
202 | ABCD4321 C U.R CR DECIMAL | |
203 | ||
204 | \ ----------------------------------------------------- U> | |
205 | T{ -5 3 U> }T{ TRUE }T | |
206 | T{ 10 8 U> }T{ TRUE }T | |
207 | ||
208 | \ ----------------------------------------------------- UNUSED | |
209 | T{ UNUSED 0> }T{ TRUE }T | |
210 | ||
211 | \ ----------------------------------------------------- WITHIN | |
212 | T{ 4 5 10 WITHIN }T{ 0 }T | |
213 | T{ 5 5 10 WITHIN }T{ TRUE }T | |
214 | T{ 9 5 10 WITHIN }T{ TRUE }T | |
215 | T{ 10 5 10 WITHIN }T{ 0 }T | |
216 | ||
217 | T{ 4 10 5 WITHIN }T{ TRUE }T | |
218 | T{ 5 10 5 WITHIN }T{ 0 }T | |
219 | T{ 9 10 5 WITHIN }T{ 0 }T | |
220 | T{ 10 10 5 WITHIN }T{ TRUE }T | |
221 | ||
222 | T{ -6 -5 10 WITHIN }T{ 0 }T | |
223 | T{ -5 -5 10 WITHIN }T{ TRUE }T | |
224 | T{ 9 -5 10 WITHIN }T{ TRUE }T | |
225 | T{ 10 -5 10 WITHIN }T{ 0 }T | |
226 | ||
227 | ||
228 | \ ----------------------------------------------------- [COMPILE] | |
229 | : T.[COMPILE].IF [COMPILE] IF ; IMMEDIATE | |
230 | : T.[COMPILE] 40 0> T.[COMPILE].IF 97 ELSE 53 THEN 97 = ; | |
231 | T{ T.[COMPILE] }T{ TRUE }T | |
232 | ||
233 | \ ----------------------------------------------------- \ | |
d98c27bb HE |
234 | |
235 | \ .( TESTING DO +LOOP with large and small increments ) | |
236 | ||
237 | \ Contributed by Andrew Haley | |
238 | 0 invert CONSTANT MAX-UINT | |
239 | 0 INVERT 1 RSHIFT CONSTANT MAX-INT | |
240 | 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT | |
241 | MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP | |
242 | USTEP NEGATE CONSTANT -USTEP | |
243 | MAX-INT 7 RSHIFT 1+ CONSTANT STEP | |
244 | STEP NEGATE CONSTANT -STEP | |
245 | ||
246 | VARIABLE BUMP | |
247 | ||
248 | T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; }T{ }T | |
249 | ||
250 | T{ 0 MAX-UINT 0 USTEP GD8 }T{ 256 }T | |
251 | T{ 0 0 MAX-UINT -USTEP GD8 }T{ 256 }T | |
252 | ||
253 | T{ 0 MAX-INT MIN-INT STEP GD8 }T{ 256 }T | |
254 | T{ 0 MIN-INT MAX-INT -STEP GD8 }T{ 256 }T | |
255 | ||
256 | \ Two's complement arithmetic, wraps around modulo wordsize | |
257 | \ Only tested if the Forth system does wrap around, use of conditional | |
258 | \ compilation deliberately avoided | |
259 | ||
260 | MAX-INT 1+ MIN-INT = CONSTANT +WRAP? | |
261 | MIN-INT 1- MAX-INT = CONSTANT -WRAP? | |
262 | MAX-UINT 1+ 0= CONSTANT +UWRAP? | |
263 | 0 1- MAX-UINT = CONSTANT -UWRAP? | |
264 | ||
265 | : GD9 ( n limit start step f result -- ) | |
266 | >R IF GD8 ELSE 2DROP 2DROP R@ THEN }T{ R> }T | |
267 | ; | |
268 | ||
269 | T{ 0 0 0 USTEP +UWRAP? 256 GD9 | |
270 | T{ 0 0 0 -USTEP -UWRAP? 1 GD9 | |
271 | T{ 0 MIN-INT MAX-INT STEP +WRAP? 1 GD9 | |
272 | T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9 | |
273 | ||
274 | \ -------------------------------------------------------------------------- | |
275 | \ .( TESTING DO +LOOP with maximum and minimum increments ) | |
276 | ||
277 | : (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ; | |
278 | (-MI) CONSTANT -MAX-INT | |
279 | ||
280 | T{ 0 1 0 MAX-INT GD8 }T{ 1 }T | |
281 | T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8 }T{ 2 }T | |
282 | ||
283 | T{ 0 MAX-INT 0 MAX-INT GD8 }T{ 1 }T | |
284 | T{ 0 MAX-INT 1 MAX-INT GD8 }T{ 1 }T | |
285 | T{ 0 MAX-INT -1 MAX-INT GD8 }T{ 2 }T | |
286 | T{ 0 MAX-INT DUP 1- MAX-INT GD8 }T{ 1 }T | |
287 | ||
288 | T{ 0 MIN-INT 1+ 0 MIN-INT GD8 }T{ 1 }T | |
289 | T{ 0 MIN-INT 1+ -1 MIN-INT GD8 }T{ 1 }T | |
290 | T{ 0 MIN-INT 1+ 1 MIN-INT GD8 }T{ 2 }T | |
291 | T{ 0 MIN-INT 1+ DUP MIN-INT GD8 }T{ 1 }T | |
292 | ||
40c6f87f HE |
293 | \ ---------------------------------------------------------------------------- |
294 | \ .( TESTING number prefixes # $ % and 'c' character input ) | |
295 | \ Adapted from the Forth 200X Draft 14.5 document | |
296 | ||
297 | VARIABLE OLD-BASE | |
298 | DECIMAL BASE @ OLD-BASE ! | |
299 | T{ #1289 }T{ 1289 }T | |
300 | T{ #-1289 }T{ -1289 }T | |
301 | T{ $12eF }T{ 4847 }T | |
302 | T{ $-12eF }T{ -4847 }T | |
303 | T{ %10010110 }T{ 150 }T | |
304 | T{ %-10010110 }T{ -150 }T | |
305 | T{ 'z' }T{ 122 }T | |
306 | T{ 'Z' }T{ 90 }T | |
307 | \ Check BASE is unchanged | |
308 | T{ BASE @ OLD-BASE @ = }T{ TRUE }T | |
309 | ||
310 | \ Repeat in Hex mode | |
311 | 16 OLD-BASE ! 16 BASE ! | |
312 | T{ #1289 }T{ 509 }T | |
313 | T{ #-1289 }T{ -509 }T | |
314 | T{ $12eF }T{ 12EF }T | |
315 | T{ $-12eF }T{ -12EF }T | |
316 | T{ %10010110 }T{ 96 }T | |
317 | T{ %-10010110 }T{ -96 }T | |
318 | T{ 'z' }T{ 7a }T | |
319 | T{ 'Z' }T{ 5a }T | |
320 | \ Check BASE is unchanged | |
321 | T{ BASE @ OLD-BASE @ = }T{ TRUE }T \ 2 | |
322 | ||
323 | DECIMAL | |
324 | \ Check number prefixes in compile mode | |
325 | T{ : nmp #8327 $-2cbe %011010111 ''' ; nmp }T{ 8327 -11454 215 39 }T | |
d98c27bb | 326 | |
29bf5876 HE |
327 | \ ----------------------------------------------------- ENVIRONMENT? |
328 | ||
329 | T{ s" unknown-query-string" ENVIRONMENT? }T{ FALSE }T | |
330 | T{ s" MAX-CHAR" ENVIRONMENT? }T{ 255 TRUE }T | |
331 | T{ s" ADDRESS-UNITS-BITS" ENVIRONMENT? }T{ 8 TRUE }T | |
332 | ||
8e9db35f PB |
333 | }TEST |
334 |