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
12 \ STUB because missing definition in pForth - FIXME
18 \ ==========================================================
21 \ ----------------------------------------------------- .(
22 T{ 27 .( IF YOU SEE THIS THEN .( WORKED!) }T{ 27 }T
24 CR .( 1234 - SHOULD LINE UP WITH NEXT LINE.) CR 1234 8 .R CR
26 T{ .( ) 987 .( TEST NULL STRING IN .( ) CR }T{ 987 }T
28 \ ----------------------------------------------------- 0<>
31 T{ -1000 0<> }T{ TRUE }T
33 \ ----------------------------------------------------- 2>R 2R> 2R@
41 \ 2>R should be the equivalent of SWAP >R >R so this next construct
42 \ should reduce to a SWAP.
45 T{ T2>R }T{ 17 19 20 5 37 20 5 77 88 }T
47 \ ----------------------------------------------------- :NONAME
48 T{ :NONAME 100 50 + ; EXECUTE }T{ 150 }T
50 \ ----------------------------------------------------- <>
51 T{ 12345 12305 <> }T{ TRUE }T
52 T{ HEX 98765432 98765432 DECIMAL <> }T{ 0 }T
54 \ ----------------------------------------------------- ?DO
55 : T?DO ( n -- sum_n ) 0 SWAP 1+ 0 ?DO i + LOOP ;
59 \ ----------------------------------------------------- AGAIN
67 T{ 10 T.AGAIN CR }T{ 5 }T
69 \ ----------------------------------------------------- C"
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
78 \ ----------------------------------------------------- CASE
86 T{ 1 T.CASE }T{ 101 }T
87 T{ 27 T.CASE }T{ 892 }T
88 T{ 49 T.CASE }T{ 941 }T
90 \ ----------------------------------------------------- COMPILE,
91 : COMPILE.SWAP ['] SWAP COMPILE, ; IMMEDIATE
93 19 20 27 COMPILE.SWAP 39
95 T{ T.COMPILE, }T{ 19 27 20 39 }T
97 \ ----------------------------------------------------- CONVERT
99 0 S>D S" 1234xyz" DROP CONVERT
104 T{ T.CONVERT }T{ 1234 CHAR x }T
106 \ ----------------------------------------------------- ERASE
107 : T.COMMA.SEQ ( n -- , lay down N sequential bytes )
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
119 \ ----------------------------------------------------- FALSE
122 \ ----------------------------------------------------- HEX
123 T{ HEX 10 DECIMAL }T{ 16 }T
125 \ ----------------------------------------------------- MARKER
126 : INDIC? ( <name> -- ifInDic , is the following word defined? )
131 MARKER MYMARK \ create word that forgets itself
134 T{ indic? foobar indic? mymark indic? goofball }T{ true false false }T
136 \ ----------------------------------------------------- NIP
137 T{ 33 44 55 NIP }T{ 33 55 }T
139 \ ----------------------------------------------------- PARSE
140 : T.PARSE ( char <string>char -- addr num )
143 PAD R@ CMOVE \ move string to pad
146 T{ CHAR % T.PARSE wxyz% SWAP C@ }T{ 4 CHAR w }T
148 \ ----------------------------------------------------- PICK
149 T{ 13 12 11 10 2 PICK }T{ 13 12 11 10 12 }T
151 \ ----------------------------------------------------- QUERY
152 T{ ' QUERY 0<> }T{ TRUE }T
154 \ ----------------------------------------------------- REFILL
155 T{ ' REFILL 0<> }T{ TRUE }T
157 \ ----------------------------------------------------- RESTORE-INPUT
158 T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T \ EXPECTED FAILURE
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
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
171 \ ----------------------------------------------------- SPAN
172 T{ ' SPAN 0<> }T{ TRUE }T
174 \ ----------------------------------------------------- TO VALUE
176 T{ MY-VALUE }T{ 333 }T
177 T{ 1000 TO MY-VALUE MY-VALUE }T{ 1000 }T
178 : TEST.VALUE ( -- 19 100 )
183 T{ TEST.VALUE }T{ 19 100 }T
185 \ ----------------------------------------------------- TRUE
188 \ ----------------------------------------------------- TUCK
189 T{ 44 55 66 TUCK }T{ 44 66 55 66 }T
191 \ ----------------------------------------------------- U.R
192 HEX CR .( ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR
193 ABCD4321 C U.R CR DECIMAL
195 \ ----------------------------------------------------- U>
196 T{ -5 3 U> }T{ TRUE }T
197 T{ 10 8 U> }T{ TRUE }T
199 \ ----------------------------------------------------- UNUSED
200 T{ UNUSED 0> }T{ TRUE }T
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
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
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
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
224 \ ----------------------------------------------------- \
226 \ .( TESTING DO +LOOP with large and small increments )
228 \ Contributed by Andrew Haley
229 0 invert CONSTANT MAX-UINT
230 0 INVERT 1 RSHIFT CONSTANT MAX-INT
231 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT
232 MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP
233 USTEP NEGATE CONSTANT -USTEP
234 MAX-INT 7 RSHIFT 1+ CONSTANT STEP
235 STEP NEGATE CONSTANT -STEP
239 T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; }T{ }T
241 T{ 0 MAX-UINT 0 USTEP GD8 }T{ 256 }T
242 T{ 0 0 MAX-UINT -USTEP GD8 }T{ 256 }T
244 T{ 0 MAX-INT MIN-INT STEP GD8 }T{ 256 }T
245 T{ 0 MIN-INT MAX-INT -STEP GD8 }T{ 256 }T
247 \ Two's complement arithmetic, wraps around modulo wordsize
248 \ Only tested if the Forth system does wrap around, use of conditional
249 \ compilation deliberately avoided
251 MAX-INT 1+ MIN-INT = CONSTANT +WRAP?
252 MIN-INT 1- MAX-INT = CONSTANT -WRAP?
253 MAX-UINT 1+ 0= CONSTANT +UWRAP?
254 0 1- MAX-UINT = CONSTANT -UWRAP?
256 : GD9 ( n limit start step f result -- )
257 >R IF GD8 ELSE 2DROP 2DROP R@ THEN }T{ R> }T
260 T{ 0 0 0 USTEP +UWRAP? 256 GD9
261 T{ 0 0 0 -USTEP -UWRAP? 1 GD9
262 T{ 0 MIN-INT MAX-INT STEP +WRAP? 1 GD9
263 T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9
265 \ --------------------------------------------------------------------------
266 \ .( TESTING DO +LOOP with maximum and minimum increments )
268 : (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ;
269 (-MI) CONSTANT -MAX-INT
271 T{ 0 1 0 MAX-INT GD8 }T{ 1 }T
272 T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8 }T{ 2 }T
274 T{ 0 MAX-INT 0 MAX-INT GD8 }T{ 1 }T
275 T{ 0 MAX-INT 1 MAX-INT GD8 }T{ 1 }T
276 T{ 0 MAX-INT -1 MAX-INT GD8 }T{ 2 }T
277 T{ 0 MAX-INT DUP 1- MAX-INT GD8 }T{ 1 }T
279 T{ 0 MIN-INT 1+ 0 MIN-INT GD8 }T{ 1 }T
280 T{ 0 MIN-INT 1+ -1 MIN-INT GD8 }T{ 1 }T
281 T{ 0 MIN-INT 1+ 1 MIN-INT GD8 }T{ 2 }T
282 T{ 0 MIN-INT 1+ DUP MIN-INT GD8 }T{ 1 }T
284 \ ----------------------------------------------------------------------------
285 \ .( TESTING number prefixes # $ % and 'c' character input )
286 \ Adapted from the Forth 200X Draft 14.5 document
289 DECIMAL BASE @ OLD-BASE !
291 T{ #-1289 }T{ -1289 }T
293 T{ $-12eF }T{ -4847 }T
294 T{ %10010110 }T{ 150 }T
295 T{ %-10010110 }T{ -150 }T
298 \ Check BASE is unchanged
299 T{ BASE @ OLD-BASE @ = }T{ TRUE }T
302 16 OLD-BASE ! 16 BASE !
304 T{ #-1289 }T{ -509 }T
306 T{ $-12eF }T{ -12EF }T
307 T{ %10010110 }T{ 96 }T
308 T{ %-10010110 }T{ -96 }T
311 \ Check BASE is unchanged
312 T{ BASE @ OLD-BASE @ = }T{ TRUE }T \ 2
315 \ Check number prefixes in compile mode
316 T{ : nmp #8327 $-2cbe %011010111 ''' ; nmp }T{ 8327 -11454 215 39 }T
318 \ ----------------------------------------------------- ENVIRONMENT?
320 T{ s" unknown-query-string" ENVIRONMENT? }T{ FALSE }T
321 T{ s" MAX-CHAR" ENVIRONMENT? }T{ 255 TRUE }T
322 T{ s" ADDRESS-UNITS-BITS" ENVIRONMENT? }T{ 8 TRUE }T