1 \ @(#) t_corex.fth 98/03/16 1.2
2 \ Test ANS Forth Core Extensions
4 \ Copyright 1994 3DO, Phil Burk
6 INCLUDE? }T{ t_tools.fth
14 \ ==========================================================
17 \ ----------------------------------------------------- .(
18 T{ 27 .( IF YOU SEE THIS THEN .( WORKED!) }T{ 27 }T
20 CR .( 1234 - SHOULD LINE UP WITH NEXT LINE.) CR 1234 8 .R CR
22 T{ .( ) 987 .( TEST NULL STRING IN .( ) CR }T{ 987 }T
24 \ ----------------------------------------------------- 0<>
27 T{ -1000 0<> }T{ TRUE }T
29 \ ----------------------------------------------------- 2>R 2R> 2R@
37 \ 2>R should be the equivalent of SWAP >R >R so this next construct
38 \ should reduce to a SWAP.
41 T{ T2>R }T{ 17 19 20 5 37 20 5 77 88 }T
43 \ ----------------------------------------------------- :NONAME
44 T{ :NONAME 100 50 + ; EXECUTE }T{ 150 }T
46 \ ----------------------------------------------------- <>
47 T{ 12345 12305 <> }T{ TRUE }T
48 T{ HEX 98765432 98765432 DECIMAL <> }T{ 0 }T
50 \ ----------------------------------------------------- ?DO
51 : T?DO ( n -- sum_n ) 0 SWAP 1+ 0 ?DO i + LOOP ;
55 \ ----------------------------------------------------- AGAIN
63 T{ 10 T.AGAIN CR }T{ 5 }T
65 \ ----------------------------------------------------- C"
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
74 \ ----------------------------------------------------- CASE
82 T{ 1 T.CASE }T{ 101 }T
83 T{ 27 T.CASE }T{ 892 }T
84 T{ 49 T.CASE }T{ 941 }T
86 \ ----------------------------------------------------- COMPILE,
87 : COMPILE.SWAP ['] SWAP COMPILE, ; IMMEDIATE
89 19 20 27 COMPILE.SWAP 39
91 T{ T.COMPILE, }T{ 19 27 20 39 }T
93 \ ----------------------------------------------------- CONVERT
95 0 S>D S" 1234xyz" DROP CONVERT
100 T{ T.CONVERT }T{ 1234 CHAR x }T
102 \ ----------------------------------------------------- ERASE
103 : T.COMMA.SEQ ( n -- , lay down N sequential bytes )
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
115 \ ----------------------------------------------------- FALSE
118 \ ----------------------------------------------------- HEX
119 T{ HEX 10 DECIMAL }T{ 16 }T
121 \ ----------------------------------------------------- MARKER
122 : INDIC? ( <name> -- ifInDic , is the following word defined? )
127 MARKER MYMARK \ create word that forgets itself
130 T{ indic? foobar indic? mymark indic? goofball }T{ true false false }T
132 \ ----------------------------------------------------- NIP
133 T{ 33 44 55 NIP }T{ 33 55 }T
135 \ ----------------------------------------------------- PARSE
136 : T.PARSE ( char <string>char -- addr num )
139 PAD R@ CMOVE \ move string to pad
142 T{ CHAR % T.PARSE wxyz% SWAP C@ }T{ 4 CHAR w }T
144 \ ----------------------------------------------------- PICK
145 T{ 13 12 11 10 2 PICK }T{ 13 12 11 10 12 }T
147 \ ----------------------------------------------------- QUERY
148 T{ ' QUERY 0<> }T{ TRUE }T
150 \ ----------------------------------------------------- REFILL
151 T{ ' REFILL 0<> }T{ TRUE }T
153 \ ----------------------------------------------------- RESTORE-INPUT
154 T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T
156 \ TESTING SAVE-INPUT and RESTORE-INPUT with a string source
158 VARIABLE SI_INC 0 SI_INC !
165 : S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ;
167 T{ S$ EVALUATE SI_INC @ }T{ 0 2345 15 }T
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
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
180 \ ----------------------------------------------------- SPAN
181 T{ ' SPAN 0<> }T{ TRUE }T
183 \ ----------------------------------------------------- TO VALUE
185 T{ MY-VALUE }T{ 333 }T
186 T{ 1000 TO MY-VALUE MY-VALUE }T{ 1000 }T
187 : TEST.VALUE ( -- 19 100 )
192 T{ TEST.VALUE }T{ 19 100 }T
194 \ ----------------------------------------------------- TRUE
197 \ ----------------------------------------------------- TUCK
198 T{ 44 55 66 TUCK }T{ 44 66 55 66 }T
200 \ ----------------------------------------------------- U.R
201 HEX CR .( ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR
202 ABCD4321 C U.R CR DECIMAL
204 \ ----------------------------------------------------- U>
205 T{ -5 3 U> }T{ TRUE }T
206 T{ 10 8 U> }T{ TRUE }T
208 \ ----------------------------------------------------- UNUSED
209 T{ UNUSED 0> }T{ TRUE }T
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
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
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
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
233 \ ----------------------------------------------------- \
235 \ .( TESTING DO +LOOP with large and small increments )
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
248 T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; }T{ }T
250 T{ 0 MAX-UINT 0 USTEP GD8 }T{ 256 }T
251 T{ 0 0 MAX-UINT -USTEP GD8 }T{ 256 }T
253 T{ 0 MAX-INT MIN-INT STEP GD8 }T{ 256 }T
254 T{ 0 MIN-INT MAX-INT -STEP GD8 }T{ 256 }T
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
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?
265 : GD9 ( n limit start step f result -- )
266 >R IF GD8 ELSE 2DROP 2DROP R@ THEN }T{ R> }T
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
274 \ --------------------------------------------------------------------------
275 \ .( TESTING DO +LOOP with maximum and minimum increments )
277 : (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ;
278 (-MI) CONSTANT -MAX-INT
280 T{ 0 1 0 MAX-INT GD8 }T{ 1 }T
281 T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8 }T{ 2 }T
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
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
293 \ ----------------------------------------------------------------------------
294 \ .( TESTING number prefixes # $ % and 'c' character input )
295 \ Adapted from the Forth 200X Draft 14.5 document
298 DECIMAL BASE @ OLD-BASE !
300 T{ #-1289 }T{ -1289 }T
302 T{ $-12eF }T{ -4847 }T
303 T{ %10010110 }T{ 150 }T
304 T{ %-10010110 }T{ -150 }T
307 \ Check BASE is unchanged
308 T{ BASE @ OLD-BASE @ = }T{ TRUE }T
311 16 OLD-BASE ! 16 BASE !
313 T{ #-1289 }T{ -509 }T
315 T{ $-12eF }T{ -12EF }T
316 T{ %10010110 }T{ 96 }T
317 T{ %-10010110 }T{ -96 }T
320 \ Check BASE is unchanged
321 T{ BASE @ OLD-BASE @ = }T{ TRUE }T \ 2
324 \ Check number prefixes in compile mode
325 T{ : nmp #8327 $-2cbe %011010111 ''' ; nmp }T{ 8327 -11454 215 39 }T
327 \ ----------------------------------------------------- ENVIRONMENT?
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