|
57
|
1 \ (C) 1993 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
|
|
|
2 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
|
|
|
3 \ VERSION 1.0
|
|
|
4 \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
|
|
|
5 \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
|
|
|
6 \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
|
|
|
7 \ THE RANGE OF UNSIGNED NUMBER IS 0 ... 2^(N)-1.
|
|
|
8 \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
|
|
|
9 \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
|
|
|
10
|
|
|
11 TESTING CORE WORDS
|
|
|
12 HEX
|
|
|
13
|
|
|
14 \ ------------------------------------------------------------------------
|
|
|
15 TESTING BOOLEANS: INVERT AND OR XOR
|
|
|
16
|
|
|
17 { 0 0 AND -> 0 }
|
|
|
18 { 0 1 AND -> 0 }
|
|
|
19 { 1 0 AND -> 0 }
|
|
|
20 { 1 1 AND -> 1 }
|
|
|
21
|
|
|
22 { 0 INVERT 1 AND -> 1 }
|
|
|
23 { 1 INVERT 1 AND -> 0 }
|
|
|
24
|
|
|
25 0 CONSTANT 0S
|
|
|
26 0 INVERT CONSTANT 1S
|
|
|
27
|
|
|
28 { 0S INVERT -> 1S }
|
|
|
29 { 1S INVERT -> 0S }
|
|
|
30
|
|
|
31 { 0S 0S AND -> 0S }
|
|
|
32 { 0S 1S AND -> 0S }
|
|
|
33 { 1S 0S AND -> 0S }
|
|
|
34 { 1S 1S AND -> 1S }
|
|
|
35
|
|
|
36 { 0S 0S OR -> 0S }
|
|
|
37 { 0S 1S OR -> 1S }
|
|
|
38 { 1S 0S OR -> 1S }
|
|
|
39 { 1S 1S OR -> 1S }
|
|
|
40
|
|
|
41 { 0S 0S XOR -> 0S }
|
|
|
42 { 0S 1S XOR -> 1S }
|
|
|
43 { 1S 0S XOR -> 1S }
|
|
|
44 { 1S 1S XOR -> 0S }
|
|
|
45
|
|
|
46 \ ------------------------------------------------------------------------
|
|
|
47 TESTING 2* 2/ LSHIFT RSHIFT
|
|
|
48
|
|
|
49 : FIND-MSB
|
|
|
50 1 BEGIN DUP 2* WHILE 2* REPEAT ;
|
|
|
51 FIND-MSB CONSTANT MSB
|
|
|
52
|
|
|
53 { 0 2* -> 0 }
|
|
|
54 { 1 2* -> 2 }
|
|
|
55 { 4000 2* -> 8000 }
|
|
|
56 { 0 INVERT 2* 1 XOR -> 0 INVERT }
|
|
|
57 { MSB 2* -> 0 }
|
|
|
58
|
|
|
59 { 0 2/ -> 0 }
|
|
|
60 { 1 2/ -> 0 }
|
|
|
61 { 4000 2/ -> 2000 }
|
|
|
62 { 0 INVERT 2/ -> 0 INVERT } \ MSB PROPOGATED
|
|
|
63 { 0 INVERT 1 XOR 2/ -> 0 INVERT }
|
|
|
64 { MSB 2/ MSB AND -> MSB }
|
|
|
65
|
|
|
66 { 1 0 LSHIFT -> 1 }
|
|
|
67 { 1 1 LSHIFT -> 2 }
|
|
|
68 { 1 2 LSHIFT -> 4 }
|
|
|
69 { 1 F LSHIFT -> 8000 } \ BIGGEST GUARANTEED SHIFT
|
|
|
70 { 0 INVERT 1 LSHIFT 1 XOR -> 0 INVERT }
|
|
|
71 { MSB 1 LSHIFT -> 0 }
|
|
|
72
|
|
|
73 { 1 0 RSHIFT -> 1 }
|
|
|
74 { 1 1 RSHIFT -> 0 }
|
|
|
75 { 2 1 RSHIFT -> 1 }
|
|
|
76 { 4 2 RSHIFT -> 1 }
|
|
|
77 { 8000 F RSHIFT -> 1 } \ BIGGEST
|
|
|
78 { MSB 1 RSHIFT MSB AND -> 0 } \ RSHIFT ZERO FILLS MSBS
|
|
|
79 { MSB 1 RSHIFT 2* -> MSB }
|
|
|
80
|
|
|
81 \ ------------------------------------------------------------------------
|
|
|
82 TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
|
|
|
83 0 INVERT CONSTANT MAX-UINT
|
|
|
84 0 INVERT 1 RSHIFT CONSTANT MAX-INT
|
|
|
85 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT
|
|
|
86 0 INVERT 1 RSHIFT CONSTANT MID-UINT
|
|
|
87 0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1
|
|
|
88
|
|
|
89 0S CONSTANT <FALSE>
|
|
|
90 1S CONSTANT <TRUE>
|
|
|
91
|
|
|
92 { -> } \ START WITH CLEAN SLATE
|
|
|
93 { 0 0= -> <TRUE> }
|
|
|
94 { 1 0= -> <FALSE> }
|
|
|
95 { 2 0= -> <FALSE> }
|
|
|
96 { -1 0= -> <FALSE> }
|
|
|
97 { MAX-UINT 0= -> <FALSE> }
|
|
|
98 { MIN-INT 0= -> <FALSE> }
|
|
|
99 { MAX-INT 0= -> <FALSE> }
|
|
|
100
|
|
|
101 { 0 0 = -> <TRUE> }
|
|
|
102 { 1 1 = -> <TRUE> }
|
|
|
103 { -1 -1 = -> <TRUE> }
|
|
|
104 { 1 0 = -> <FALSE> }
|
|
|
105 { -1 0 = -> <FALSE> }
|
|
|
106 { 0 1 = -> <FALSE> }
|
|
|
107 { 0 -1 = -> <FALSE> }
|
|
|
108
|
|
|
109 { 0 0< -> <FALSE> }
|
|
|
110 { -1 0< -> <TRUE> }
|
|
|
111 { MIN-INT 0< -> <TRUE> }
|
|
|
112 { 1 0< -> <FALSE> }
|
|
|
113 { MAX-INT 0< -> <FALSE> }
|
|
|
114
|
|
|
115 { 0 1 < -> <TRUE> }
|
|
|
116 { 1 2 < -> <TRUE> }
|
|
|
117 { -1 0 < -> <TRUE> }
|
|
|
118 { -1 1 < -> <TRUE> }
|
|
|
119 { MIN-INT 0 < -> <TRUE> }
|
|
|
120 { MIN-INT MAX-INT < -> <TRUE> }
|
|
|
121 { 0 MAX-INT < -> <TRUE> }
|
|
|
122 { 0 0 < -> <FALSE> }
|
|
|
123 { 1 1 < -> <FALSE> }
|
|
|
124 { 1 0 < -> <FALSE> }
|
|
|
125 { 2 1 < -> <FALSE> }
|
|
|
126 { 0 -1 < -> <FALSE> }
|
|
|
127 { 1 -1 < -> <FALSE> }
|
|
|
128 { 0 MIN-INT < -> <FALSE> }
|
|
|
129 { MAX-INT MIN-INT < -> <FALSE> }
|
|
|
130 { MAX-INT 0 < -> <FALSE> }
|
|
|
131
|
|
|
132 { 0 1 > -> <FALSE> }
|
|
|
133 { 1 2 > -> <FALSE> }
|
|
|
134 { -1 0 > -> <FALSE> }
|
|
|
135 { -1 1 > -> <FALSE> }
|
|
|
136 { MIN-INT 0 > -> <FALSE> }
|
|
|
137 { MIN-INT MAX-INT > -> <FALSE> }
|
|
|
138 { 0 MAX-INT > -> <FALSE> }
|
|
|
139 { 0 0 > -> <FALSE> }
|
|
|
140 { 1 1 > -> <FALSE> }
|
|
|
141 { 1 0 > -> <TRUE> }
|
|
|
142 { 2 1 > -> <TRUE> }
|
|
|
143 { 0 -1 > -> <TRUE> }
|
|
|
144 { 1 -1 > -> <TRUE> }
|
|
|
145 { 0 MIN-INT > -> <TRUE> }
|
|
|
146 { MAX-INT MIN-INT > -> <TRUE> }
|
|
|
147 { MAX-INT 0 > -> <TRUE> }
|
|
|
148
|
|
|
149 { 0 1 U< -> <TRUE> }
|
|
|
150 { 1 2 U< -> <TRUE> }
|
|
|
151 { 0 MID-UINT U< -> <TRUE> }
|
|
|
152 { 0 MAX-UINT U< -> <TRUE> }
|
|
|
153 { MID-UINT MAX-UINT U< -> <TRUE> }
|
|
|
154 { 0 0 U< -> <FALSE> }
|
|
|
155 { 1 1 U< -> <FALSE> }
|
|
|
156 { 1 0 U< -> <FALSE> }
|
|
|
157 { 2 1 U< -> <FALSE> }
|
|
|
158 { MID-UINT 0 U< -> <FALSE> }
|
|
|
159 { MAX-UINT 0 U< -> <FALSE> }
|
|
|
160 { MAX-UINT MID-UINT U< -> <FALSE> }
|
|
|
161
|
|
|
162 { 0 1 MIN -> 0 }
|
|
|
163 { 1 2 MIN -> 1 }
|
|
|
164 { -1 0 MIN -> -1 }
|
|
|
165 { -1 1 MIN -> -1 }
|
|
|
166 { MIN-INT 0 MIN -> MIN-INT }
|
|
|
167 { MIN-INT MAX-INT MIN -> MIN-INT }
|
|
|
168 { 0 MAX-INT MIN -> 0 }
|
|
|
169 { 0 0 MIN -> 0 }
|
|
|
170 { 1 1 MIN -> 1 }
|
|
|
171 { 1 0 MIN -> 0 }
|
|
|
172 { 2 1 MIN -> 1 }
|
|
|
173 { 0 -1 MIN -> -1 }
|
|
|
174 { 1 -1 MIN -> -1 }
|
|
|
175 { 0 MIN-INT MIN -> MIN-INT }
|
|
|
176 { MAX-INT MIN-INT MIN -> MIN-INT }
|
|
|
177 { MAX-INT 0 MIN -> 0 }
|
|
|
178
|
|
|
179 { 0 1 MAX -> 1 }
|
|
|
180 { 1 2 MAX -> 2 }
|
|
|
181 { -1 0 MAX -> 0 }
|
|
|
182 { -1 1 MAX -> 1 }
|
|
|
183 { MIN-INT 0 MAX -> 0 }
|
|
|
184 { MIN-INT MAX-INT MAX -> MAX-INT }
|
|
|
185 { 0 MAX-INT MAX -> MAX-INT }
|
|
|
186 { 0 0 MAX -> 0 }
|
|
|
187 { 1 1 MAX -> 1 }
|
|
|
188 { 1 0 MAX -> 1 }
|
|
|
189 { 2 1 MAX -> 2 }
|
|
|
190 { 0 -1 MAX -> 0 }
|
|
|
191 { 1 -1 MAX -> 1 }
|
|
|
192 { 0 MIN-INT MAX -> 0 }
|
|
|
193 { MAX-INT MIN-INT MAX -> MAX-INT }
|
|
|
194 { MAX-INT 0 MAX -> MAX-INT }
|
|
|
195
|
|
|
196 \ ------------------------------------------------------------------------
|
|
|
197 TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
|
|
|
198
|
|
|
199 { 1 2 2DROP -> }
|
|
|
200 { 1 2 2DUP -> 1 2 1 2 }
|
|
|
201 { 1 2 3 4 2OVER -> 1 2 3 4 1 2 }
|
|
|
202 { 1 2 3 4 2SWAP -> 3 4 1 2 }
|
|
|
203 { 0 ?DUP -> 0 }
|
|
|
204 { 1 ?DUP -> 1 1 }
|
|
|
205 { -1 ?DUP -> -1 -1 }
|
|
|
206 { DEPTH -> 0 }
|
|
|
207 { 0 DEPTH -> 0 1 }
|
|
|
208 { 0 1 DEPTH -> 0 1 2 }
|
|
|
209 { 0 DROP -> }
|
|
|
210 { 1 2 DROP -> 1 }
|
|
|
211 { 1 DUP -> 1 1 }
|
|
|
212 { 1 2 OVER -> 1 2 1 }
|
|
|
213 { 1 2 3 ROT -> 2 3 1 }
|
|
|
214 { 1 2 SWAP -> 2 1 }
|
|
|
215
|
|
|
216 \ ------------------------------------------------------------------------
|
|
|
217 TESTING >R R> R@
|
|
|
218
|
|
|
219 { : GR1 >R R> ; -> }
|
|
|
220 { : GR2 >R R@ R> DROP ; -> }
|
|
|
221 { 123 GR1 -> 123 }
|
|
|
222 { 123 GR2 -> 123 }
|
|
|
223
|
|
|
224 \ ------------------------------------------------------------------------
|
|
|
225 TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
|
|
|
226
|
|
|
227 { 0 5 + -> 5 }
|
|
|
228 { 5 0 + -> 5 }
|
|
|
229 { 0 -5 + -> -5 }
|
|
|
230 { -5 0 + -> -5 }
|
|
|
231 { 1 2 + -> 3 }
|
|
|
232 { 1 -2 + -> -1 }
|
|
|
233 { -1 2 + -> 1 }
|
|
|
234 { -1 -2 + -> -3 }
|
|
|
235 { -1 1 + -> 0 }
|
|
|
236 { MID-UINT 1 + -> MID-UINT+1 }
|
|
|
237
|
|
|
238 { 0 5 - -> -5 }
|
|
|
239 { 5 0 - -> 5 }
|
|
|
240 { 0 -5 - -> 5 }
|
|
|
241 { -5 0 - -> -5 }
|
|
|
242 { 1 2 - -> -1 }
|
|
|
243 { 1 -2 - -> 3 }
|
|
|
244 { -1 2 - -> -3 }
|
|
|
245 { -1 -2 - -> 1 }
|
|
|
246 { 0 1 - -> -1 }
|
|
|
247 { MID-UINT+1 1 - -> MID-UINT }
|
|
|
248
|
|
|
249 { 0 1+ -> 1 }
|
|
|
250 { -1 1+ -> 0 }
|
|
|
251 { 1 1+ -> 2 }
|
|
|
252 { MID-UINT 1+ -> MID-UINT+1 }
|
|
|
253
|
|
|
254 { 2 1- -> 1 }
|
|
|
255 { 1 1- -> 0 }
|
|
|
256 { 0 1- -> -1 }
|
|
|
257 { MID-UINT+1 1- -> MID-UINT }
|
|
|
258
|
|
|
259 { 0 NEGATE -> 0 }
|
|
|
260 { 1 NEGATE -> -1 }
|
|
|
261 { -1 NEGATE -> 1 }
|
|
|
262 { 2 NEGATE -> -2 }
|
|
|
263 { -2 NEGATE -> 2 }
|
|
|
264
|
|
|
265 { 0 ABS -> 0 }
|
|
|
266 { 1 ABS -> 1 }
|
|
|
267 { -1 ABS -> 1 }
|
|
|
268 { MIN-INT ABS -> MID-UINT+1 }
|
|
|
269
|
|
|
270 \ ------------------------------------------------------------------------
|
|
|
271 TESTING MULTIPLY: S>D * M* UM*
|
|
|
272
|
|
|
273 { 0 S>D -> 0 0 }
|
|
|
274 { 1 S>D -> 1 0 }
|
|
|
275 { 2 S>D -> 2 0 }
|
|
|
276 { -1 S>D -> -1 -1 }
|
|
|
277 { -2 S>D -> -2 -1 }
|
|
|
278 { MIN-INT S>D -> MIN-INT -1 }
|
|
|
279 { MAX-INT S>D -> MAX-INT 0 }
|
|
|
280
|
|
|
281 { 0 0 M* -> 0 S>D }
|
|
|
282 { 0 1 M* -> 0 S>D }
|
|
|
283 { 1 0 M* -> 0 S>D }
|
|
|
284 { 1 2 M* -> 2 S>D }
|
|
|
285 { 2 1 M* -> 2 S>D }
|
|
|
286 { 3 3 M* -> 9 S>D }
|
|
|
287 { -3 3 M* -> -9 S>D }
|
|
|
288 { 3 -3 M* -> -9 S>D }
|
|
|
289 { -3 -3 M* -> 9 S>D }
|
|
|
290 { 0 MIN-INT M* -> 0 S>D }
|
|
|
291 { 1 MIN-INT M* -> MIN-INT S>D }
|
|
|
292 { 2 MIN-INT M* -> 0 1S }
|
|
|
293 { 0 MAX-INT M* -> 0 S>D }
|
|
|
294 { 1 MAX-INT M* -> MAX-INT S>D }
|
|
|
295 { 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }
|
|
|
296 { MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }
|
|
|
297 { MAX-INT MIN-INT M* -> MSB MSB 2/ }
|
|
|
298 { MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }
|
|
|
299
|
|
|
300 { 0 0 * -> 0 } \ TEST IDENTITIES
|
|
|
301 { 0 1 * -> 0 }
|
|
|
302 { 1 0 * -> 0 }
|
|
|
303 { 1 2 * -> 2 }
|
|
|
304 { 2 1 * -> 2 }
|
|
|
305 { 3 3 * -> 9 }
|
|
|
306 { -3 3 * -> -9 }
|
|
|
307 { 3 -3 * -> -9 }
|
|
|
308 { -3 -3 * -> 9 }
|
|
|
309
|
|
|
310 { MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }
|
|
|
311 { MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }
|
|
|
312 { MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }
|
|
|
313
|
|
|
314 { 0 0 UM* -> 0 0 }
|
|
|
315 { 0 1 UM* -> 0 0 }
|
|
|
316 { 1 0 UM* -> 0 0 }
|
|
|
317 { 1 2 UM* -> 2 0 }
|
|
|
318 { 2 1 UM* -> 2 0 }
|
|
|
319 { 3 3 UM* -> 9 0 }
|
|
|
320
|
|
|
321 { MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }
|
|
|
322 { MID-UINT+1 2 UM* -> 0 1 }
|
|
|
323 { MID-UINT+1 4 UM* -> 0 2 }
|
|
|
324 { 1S 2 UM* -> 1S 1 LSHIFT 1 }
|
|
|
325 { MAX-UINT MAX-UINT UM* -> 1 1 INVERT }
|
|
|
326
|
|
|
327 \ ------------------------------------------------------------------------
|
|
|
328 TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
|
|
|
329
|
|
|
330 { 0 S>D 1 FM/MOD -> 0 0 }
|
|
|
331 { 1 S>D 1 FM/MOD -> 0 1 }
|
|
|
332 { 2 S>D 1 FM/MOD -> 0 2 }
|
|
|
333 { -1 S>D 1 FM/MOD -> 0 -1 }
|
|
|
334 { -2 S>D 1 FM/MOD -> 0 -2 }
|
|
|
335 { 0 S>D -1 FM/MOD -> 0 0 }
|
|
|
336 { 1 S>D -1 FM/MOD -> 0 -1 }
|
|
|
337 { 2 S>D -1 FM/MOD -> 0 -2 }
|
|
|
338 { -1 S>D -1 FM/MOD -> 0 1 }
|
|
|
339 { -2 S>D -1 FM/MOD -> 0 2 }
|
|
|
340 { 2 S>D 2 FM/MOD -> 0 1 }
|
|
|
341 { -1 S>D -1 FM/MOD -> 0 1 }
|
|
|
342 { -2 S>D -2 FM/MOD -> 0 1 }
|
|
|
343 { 7 S>D 3 FM/MOD -> 1 2 }
|
|
|
344 { 7 S>D -3 FM/MOD -> -2 -3 }
|
|
|
345 { -7 S>D 3 FM/MOD -> 2 -3 }
|
|
|
346 { -7 S>D -3 FM/MOD -> -1 2 }
|
|
|
347 { MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }
|
|
|
348 { MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }
|
|
|
349 { MAX-INT S>D MAX-INT FM/MOD -> 0 1 }
|
|
|
350 { MIN-INT S>D MIN-INT FM/MOD -> 0 1 }
|
|
|
351 { 1S 1 4 FM/MOD -> 3 MAX-INT }
|
|
|
352 { 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }
|
|
|
353 { 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }
|
|
|
354 { 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }
|
|
|
355 { 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }
|
|
|
356 { 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }
|
|
|
357 { 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }
|
|
|
358 { 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }
|
|
|
359 { 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }
|
|
|
360 { MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }
|
|
|
361 { MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }
|
|
|
362 { MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }
|
|
|
363 { MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }
|
|
|
364
|
|
|
365 { 0 S>D 1 SM/REM -> 0 0 }
|
|
|
366 { 1 S>D 1 SM/REM -> 0 1 }
|
|
|
367 { 2 S>D 1 SM/REM -> 0 2 }
|
|
|
368 { -1 S>D 1 SM/REM -> 0 -1 }
|
|
|
369 { -2 S>D 1 SM/REM -> 0 -2 }
|
|
|
370 { 0 S>D -1 SM/REM -> 0 0 }
|
|
|
371 { 1 S>D -1 SM/REM -> 0 -1 }
|
|
|
372 { 2 S>D -1 SM/REM -> 0 -2 }
|
|
|
373 { -1 S>D -1 SM/REM -> 0 1 }
|
|
|
374 { -2 S>D -1 SM/REM -> 0 2 }
|
|
|
375 { 2 S>D 2 SM/REM -> 0 1 }
|
|
|
376 { -1 S>D -1 SM/REM -> 0 1 }
|
|
|
377 { -2 S>D -2 SM/REM -> 0 1 }
|
|
|
378 { 7 S>D 3 SM/REM -> 1 2 }
|
|
|
379 { 7 S>D -3 SM/REM -> 1 -2 }
|
|
|
380 { -7 S>D 3 SM/REM -> -1 -2 }
|
|
|
381 { -7 S>D -3 SM/REM -> -1 2 }
|
|
|
382 { MAX-INT S>D 1 SM/REM -> 0 MAX-INT }
|
|
|
383 { MIN-INT S>D 1 SM/REM -> 0 MIN-INT }
|
|
|
384 { MAX-INT S>D MAX-INT SM/REM -> 0 1 }
|
|
|
385 { MIN-INT S>D MIN-INT SM/REM -> 0 1 }
|
|
|
386 { 1S 1 4 SM/REM -> 3 MAX-INT }
|
|
|
387 { 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }
|
|
|
388 { 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }
|
|
|
389 { 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }
|
|
|
390 { 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }
|
|
|
391 { MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }
|
|
|
392 { MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }
|
|
|
393 { MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }
|
|
|
394 { MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }
|
|
|
395
|
|
|
396 { 0 0 1 UM/MOD -> 0 0 }
|
|
|
397 { 1 0 1 UM/MOD -> 0 1 }
|
|
|
398 { 1 0 2 UM/MOD -> 1 0 }
|
|
|
399 { 3 0 2 UM/MOD -> 1 1 }
|
|
|
400 { MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }
|
|
|
401 { MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }
|
|
|
402 { MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }
|
|
|
403
|
|
|
404 : IFFLOORED
|
|
|
405 [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
|
|
|
406 : IFSYM
|
|
|
407 [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
|
|
|
408
|
|
|
409 \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
|
|
|
410 \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
|
|
|
411 IFFLOORED : T/MOD >R S>D R> FM/MOD ;
|
|
|
412 IFFLOORED : T/ T/MOD SWAP DROP ;
|
|
|
413 IFFLOORED : TMOD T/MOD DROP ;
|
|
|
414 IFFLOORED : T*/MOD >R M* R> FM/MOD ;
|
|
|
415 IFFLOORED : T*/ T*/MOD SWAP DROP ;
|
|
|
416 IFSYM : T/MOD >R S>D R> SM/REM ;
|
|
|
417 IFSYM : T/ T/MOD SWAP DROP ;
|
|
|
418 IFSYM : TMOD T/MOD DROP ;
|
|
|
419 IFSYM : T*/MOD >R M* R> SM/REM ;
|
|
|
420 IFSYM : T*/ T*/MOD SWAP DROP ;
|
|
|
421
|
|
|
422 { 0 1 /MOD -> 0 1 T/MOD }
|
|
|
423 { 1 1 /MOD -> 1 1 T/MOD }
|
|
|
424 { 2 1 /MOD -> 2 1 T/MOD }
|
|
|
425 { -1 1 /MOD -> -1 1 T/MOD }
|
|
|
426 { -2 1 /MOD -> -2 1 T/MOD }
|
|
|
427 { 0 -1 /MOD -> 0 -1 T/MOD }
|
|
|
428 { 1 -1 /MOD -> 1 -1 T/MOD }
|
|
|
429 { 2 -1 /MOD -> 2 -1 T/MOD }
|
|
|
430 { -1 -1 /MOD -> -1 -1 T/MOD }
|
|
|
431 { -2 -1 /MOD -> -2 -1 T/MOD }
|
|
|
432 { 2 2 /MOD -> 2 2 T/MOD }
|
|
|
433 { -1 -1 /MOD -> -1 -1 T/MOD }
|
|
|
434 { -2 -2 /MOD -> -2 -2 T/MOD }
|
|
|
435 { 7 3 /MOD -> 7 3 T/MOD }
|
|
|
436 { 7 -3 /MOD -> 7 -3 T/MOD }
|
|
|
437 { -7 3 /MOD -> -7 3 T/MOD }
|
|
|
438 { -7 -3 /MOD -> -7 -3 T/MOD }
|
|
|
439 { MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }
|
|
|
440 { MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }
|
|
|
441 { MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }
|
|
|
442 { MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }
|
|
|
443
|
|
|
444 { 0 1 / -> 0 1 T/ }
|
|
|
445 { 1 1 / -> 1 1 T/ }
|
|
|
446 { 2 1 / -> 2 1 T/ }
|
|
|
447 { -1 1 / -> -1 1 T/ }
|
|
|
448 { -2 1 / -> -2 1 T/ }
|
|
|
449 { 0 -1 / -> 0 -1 T/ }
|
|
|
450 { 1 -1 / -> 1 -1 T/ }
|
|
|
451 { 2 -1 / -> 2 -1 T/ }
|
|
|
452 { -1 -1 / -> -1 -1 T/ }
|
|
|
453 { -2 -1 / -> -2 -1 T/ }
|
|
|
454 { 2 2 / -> 2 2 T/ }
|
|
|
455 { -1 -1 / -> -1 -1 T/ }
|
|
|
456 { -2 -2 / -> -2 -2 T/ }
|
|
|
457 { 7 3 / -> 7 3 T/ }
|
|
|
458 { 7 -3 / -> 7 -3 T/ }
|
|
|
459 { -7 3 / -> -7 3 T/ }
|
|
|
460 { -7 -3 / -> -7 -3 T/ }
|
|
|
461 { MAX-INT 1 / -> MAX-INT 1 T/ }
|
|
|
462 { MIN-INT 1 / -> MIN-INT 1 T/ }
|
|
|
463 { MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }
|
|
|
464 { MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }
|
|
|
465
|
|
|
466 { 0 1 MOD -> 0 1 TMOD }
|
|
|
467 { 1 1 MOD -> 1 1 TMOD }
|
|
|
468 { 2 1 MOD -> 2 1 TMOD }
|
|
|
469 { -1 1 MOD -> -1 1 TMOD }
|
|
|
470 { -2 1 MOD -> -2 1 TMOD }
|
|
|
471 { 0 -1 MOD -> 0 -1 TMOD }
|
|
|
472 { 1 -1 MOD -> 1 -1 TMOD }
|
|
|
473 { 2 -1 MOD -> 2 -1 TMOD }
|
|
|
474 { -1 -1 MOD -> -1 -1 TMOD }
|
|
|
475 { -2 -1 MOD -> -2 -1 TMOD }
|
|
|
476 { 2 2 MOD -> 2 2 TMOD }
|
|
|
477 { -1 -1 MOD -> -1 -1 TMOD }
|
|
|
478 { -2 -2 MOD -> -2 -2 TMOD }
|
|
|
479 { 7 3 MOD -> 7 3 TMOD }
|
|
|
480 { 7 -3 MOD -> 7 -3 TMOD }
|
|
|
481 { -7 3 MOD -> -7 3 TMOD }
|
|
|
482 { -7 -3 MOD -> -7 -3 TMOD }
|
|
|
483 { MAX-INT 1 MOD -> MAX-INT 1 TMOD }
|
|
|
484 { MIN-INT 1 MOD -> MIN-INT 1 TMOD }
|
|
|
485 { MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }
|
|
|
486 { MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }
|
|
|
487
|
|
|
488 { 0 2 1 */ -> 0 2 1 T*/ }
|
|
|
489 { 1 2 1 */ -> 1 2 1 T*/ }
|
|
|
490 { 2 2 1 */ -> 2 2 1 T*/ }
|
|
|
491 { -1 2 1 */ -> -1 2 1 T*/ }
|
|
|
492 { -2 2 1 */ -> -2 2 1 T*/ }
|
|
|
493 { 0 2 -1 */ -> 0 2 -1 T*/ }
|
|
|
494 { 1 2 -1 */ -> 1 2 -1 T*/ }
|
|
|
495 { 2 2 -1 */ -> 2 2 -1 T*/ }
|
|
|
496 { -1 2 -1 */ -> -1 2 -1 T*/ }
|
|
|
497 { -2 2 -1 */ -> -2 2 -1 T*/ }
|
|
|
498 { 2 2 2 */ -> 2 2 2 T*/ }
|
|
|
499 { -1 2 -1 */ -> -1 2 -1 T*/ }
|
|
|
500 { -2 2 -2 */ -> -2 2 -2 T*/ }
|
|
|
501 { 7 2 3 */ -> 7 2 3 T*/ }
|
|
|
502 { 7 2 -3 */ -> 7 2 -3 T*/ }
|
|
|
503 { -7 2 3 */ -> -7 2 3 T*/ }
|
|
|
504 { -7 2 -3 */ -> -7 2 -3 T*/ }
|
|
|
505 { MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }
|
|
|
506 { MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }
|
|
|
507
|
|
|
508 { 0 2 1 */MOD -> 0 2 1 T*/MOD }
|
|
|
509 { 1 2 1 */MOD -> 1 2 1 T*/MOD }
|
|
|
510 { 2 2 1 */MOD -> 2 2 1 T*/MOD }
|
|
|
511 { -1 2 1 */MOD -> -1 2 1 T*/MOD }
|
|
|
512 { -2 2 1 */MOD -> -2 2 1 T*/MOD }
|
|
|
513 { 0 2 -1 */MOD -> 0 2 -1 T*/MOD }
|
|
|
514 { 1 2 -1 */MOD -> 1 2 -1 T*/MOD }
|
|
|
515 { 2 2 -1 */MOD -> 2 2 -1 T*/MOD }
|
|
|
516 { -1 2 -1 */MOD -> -1 2 -1 T*/MOD }
|
|
|
517 { -2 2 -1 */MOD -> -2 2 -1 T*/MOD }
|
|
|
518 { 2 2 2 */MOD -> 2 2 2 T*/MOD }
|
|
|
519 { -1 2 -1 */MOD -> -1 2 -1 T*/MOD }
|
|
|
520 { -2 2 -2 */MOD -> -2 2 -2 T*/MOD }
|
|
|
521 { 7 2 3 */MOD -> 7 2 3 T*/MOD }
|
|
|
522 { 7 2 -3 */MOD -> 7 2 -3 T*/MOD }
|
|
|
523 { -7 2 3 */MOD -> -7 2 3 T*/MOD }
|
|
|
524 { -7 2 -3 */MOD -> -7 2 -3 T*/MOD }
|
|
|
525 { MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }
|
|
|
526 { MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }
|
|
|
527
|
|
|
528 \ ------------------------------------------------------------------------
|
|
|
529 TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
|
|
|
530
|
|
|
531 HERE 1 ALLOT
|
|
|
532 HERE
|
|
|
533 CONSTANT 2NDA
|
|
|
534 CONSTANT 1STA
|
|
|
535 { 1STA 2NDA U< -> <TRUE> } \ HERE MUST GROW WITH ALLOT
|
|
|
536 { 1STA 1+ -> 2NDA } \ ... BY ONE ADDRESS UNIT
|
|
|
537 ( MISSING TEST: NEGATIVE ALLOT )
|
|
|
538
|
|
|
539 HERE 1 ,
|
|
|
540 HERE 2 ,
|
|
|
541 CONSTANT 2ND
|
|
|
542 CONSTANT 1ST
|
|
|
543 { 1ST 2ND U< -> <TRUE> } \ HERE MUST GROW WITH ALLOT
|
|
|
544 { 1ST CELL+ -> 2ND } \ ... BY ONE CELL
|
|
|
545 { 1ST 1 CELLS + -> 2ND }
|
|
|
546 { 1ST @ 2ND @ -> 1 2 }
|
|
|
547 { 5 1ST ! -> }
|
|
|
548 { 1ST @ 2ND @ -> 5 2 }
|
|
|
549 { 6 2ND ! -> }
|
|
|
550 { 1ST @ 2ND @ -> 5 6 }
|
|
|
551 { 1ST 2@ -> 6 5 }
|
|
|
552 { 2 1 1ST 2! -> }
|
|
|
553 { 1ST 2@ -> 2 1 }
|
|
|
554
|
|
|
555 HERE 1 C,
|
|
|
556 HERE 2 C,
|
|
|
557 CONSTANT 2NDC
|
|
|
558 CONSTANT 1STC
|
|
|
559 { 1STC 2NDC U< -> <TRUE> } \ HERE MUST GROW WITH ALLOT
|
|
|
560 { 1STC CHAR+ -> 2NDC } \ ... BY ONE CHAR
|
|
|
561 { 1STC 1 CHARS + -> 2NDC }
|
|
|
562 { 1STC C@ 2NDC C@ -> 1 2 }
|
|
|
563 { 3 1STC C! -> }
|
|
|
564 { 1STC C@ 2NDC C@ -> 3 2 }
|
|
|
565 { 4 2NDC C! -> }
|
|
|
566 { 1STC C@ 2NDC C@ -> 3 4 }
|
|
|
567
|
|
|
568 HERE 1 ALLOT ALIGN 123 , CONSTANT X
|
|
|
569 { X 1+ ALIGNED @ -> 123 }
|
|
|
570 ( MISSING TEST: CHARS AT ALIGNED ADDRESS )
|
|
|
571
|
|
|
572 { 1 CELLS 1 CHARS MOD -> 0 } \ SIZE OF CELL MULTIPLE OF SIZE OF CHAR
|
|
|
573
|
|
|
574 { 0 1ST ! -> }
|
|
|
575 { 1 1ST +! -> }
|
|
|
576 { 1ST @ -> 1 }
|
|
|
577 { -1 1ST +! 1ST @ -> 0 }
|
|
|
578
|
|
|
579 \ ------------------------------------------------------------------------
|
|
|
580 TESTING CHAR [CHAR] [ ] BL S"
|
|
|
581
|
|
|
582 { BL -> 20 }
|
|
|
583 { CHAR X -> 58 }
|
|
|
584 { CHAR HELLO -> 48 }
|
|
|
585 { : GC1 [CHAR] X ; -> }
|
|
|
586 { : GC2 [CHAR] HELLO ; -> }
|
|
|
587 { GC1 -> 58 }
|
|
|
588 { GC2 -> 48 }
|
|
|
589 { : GC3 [ GC1 ] LITERAL ; -> }
|
|
|
590 { GC3 -> 58 }
|
|
|
591 { : GC4 S" XY" ; -> }
|
|
|
592 { GC4 SWAP DROP -> 2 }
|
|
|
593 { GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }
|
|
|
594
|
|
|
595 \ ------------------------------------------------------------------------
|
|
|
596 TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
|
|
|
597
|
|
|
598 { : GT1 123 ; -> }
|
|
|
599 { ' GT1 EXECUTE -> 123 }
|
|
|
600 { : GT2 ['] GT1 ; IMMEDIATE -> }
|
|
|
601 { GT2 EXECUTE -> 123 }
|
|
|
602 HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
|
|
|
603 HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
|
|
|
604 { GT1STRING FIND -> ' GT1 -1 }
|
|
|
605 { GT2STRING FIND -> ' GT2 1 }
|
|
|
606 ( HOW TO SEARCH FOR NON-EXISTENT WORD? )
|
|
|
607 { : GT3 GT2 LITERAL ; -> }
|
|
|
608 { GT3 -> ' GT1 }
|
|
|
609 { GT1STRING COUNT -> GT1STRING CHAR+ 3 }
|
|
|
610
|
|
|
611 { : GT4 POSTPONE GT1 ; IMMEDIATE -> }
|
|
|
612 { : GT5 GT4 ; -> }
|
|
|
613 { GT5 -> 123 }
|
|
|
614 { : GT6 345 ; IMMEDIATE -> }
|
|
|
615 { : GT7 POSTPONE GT6 ; -> }
|
|
|
616 { GT7 -> 345 }
|
|
|
617
|
|
|
618 { : GT8 STATE @ ; IMMEDIATE -> }
|
|
|
619 { GT8 -> 0 }
|
|
|
620 { : GT9 GT8 LITERAL ; -> }
|
|
|
621 { GT9 0= -> <FALSE> }
|
|
|
622
|
|
|
623 \ ------------------------------------------------------------------------
|
|
|
624 TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
|
|
|
625
|
|
|
626 { : GI1 IF 123 THEN ; -> }
|
|
|
627 { : GI2 IF 123 ELSE 234 THEN ; -> }
|
|
|
628 { 0 GI1 -> }
|
|
|
629 { 1 GI1 -> 123 }
|
|
|
630 { -1 GI1 -> 123 }
|
|
|
631 { 0 GI2 -> 234 }
|
|
|
632 { 1 GI2 -> 123 }
|
|
|
633 { -1 GI1 -> 123 }
|
|
|
634
|
|
|
635 { : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }
|
|
|
636 { 0 GI3 -> 0 1 2 3 4 5 }
|
|
|
637 { 4 GI3 -> 4 5 }
|
|
|
638 { 5 GI3 -> 5 }
|
|
|
639 { 6 GI3 -> 6 }
|
|
|
640
|
|
|
641 { : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }
|
|
|
642 { 3 GI4 -> 3 4 5 6 }
|
|
|
643 { 5 GI4 -> 5 6 }
|
|
|
644 { 6 GI4 -> 6 7 }
|
|
|
645
|
|
|
646 { : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }
|
|
|
647 { 1 GI5 -> 1 345 }
|
|
|
648 { 2 GI5 -> 2 345 }
|
|
|
649 { 3 GI5 -> 3 4 5 123 }
|
|
|
650 { 4 GI5 -> 4 5 123 }
|
|
|
651 { 5 GI5 -> 5 123 }
|
|
|
652
|
|
|
653 { : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }
|
|
|
654 { 0 GI6 -> 0 }
|
|
|
655 { 1 GI6 -> 0 1 }
|
|
|
656 { 2 GI6 -> 0 1 2 }
|
|
|
657 { 3 GI6 -> 0 1 2 3 }
|
|
|
658 { 4 GI6 -> 0 1 2 3 4 }
|
|
|
659
|
|
|
660 \ ------------------------------------------------------------------------
|
|
|
661 TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
|
|
|
662
|
|
|
663 { : GD1 DO I LOOP ; -> }
|
|
|
664 { 4 1 GD1 -> 1 2 3 }
|
|
|
665 { 2 -1 GD1 -> -1 0 1 }
|
|
|
666 { MID-UINT+1 MID-UINT GD1 -> MID-UINT }
|
|
|
667
|
|
|
668 { : GD2 DO I -1 +LOOP ; -> }
|
|
|
669 { 1 4 GD2 -> 4 3 2 1 }
|
|
|
670 { -1 2 GD2 -> 2 1 0 -1 }
|
|
|
671 { MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }
|
|
|
672
|
|
|
673 { : GD3 DO 1 0 DO J LOOP LOOP ; -> }
|
|
|
674 { 4 1 GD3 -> 1 2 3 }
|
|
|
675 { 2 -1 GD3 -> -1 0 1 }
|
|
|
676 { MID-UINT+1 MID-UINT GD3 -> MID-UINT }
|
|
|
677
|
|
|
678 { : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }
|
|
|
679 { 1 4 GD4 -> 4 3 2 1 }
|
|
|
680 { -1 2 GD4 -> 2 1 0 -1 }
|
|
|
681 { MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }
|
|
|
682
|
|
|
683 { : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }
|
|
|
684 { 1 GD5 -> 123 }
|
|
|
685 { 5 GD5 -> 123 }
|
|
|
686 { 6 GD5 -> 234 }
|
|
|
687
|
|
|
688 { : GD6 ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} )
|
|
|
689 0 SWAP 0 DO
|
|
|
690 I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
|
|
|
691 LOOP ; -> }
|
|
|
692 { 1 GD6 -> 1 }
|
|
|
693 { 2 GD6 -> 3 }
|
|
|
694 { 3 GD6 -> 4 1 2 }
|
|
|
695
|
|
|
696 \ ------------------------------------------------------------------------
|
|
|
697 TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
|
|
|
698
|
|
|
699 { 123 CONSTANT X123 -> }
|
|
|
700 { X123 -> 123 }
|
|
|
701 { : EQU CONSTANT ; -> }
|
|
|
702 { X123 EQU Y123 -> }
|
|
|
703 { Y123 -> 123 }
|
|
|
704
|
|
|
705 { VARIABLE V1 -> }
|
|
|
706 { 123 V1 ! -> }
|
|
|
707 { V1 @ -> 123 }
|
|
|
708
|
|
|
709 { : NOP : POSTPONE ; ; -> }
|
|
|
710 { NOP NOP1 NOP NOP2 -> }
|
|
|
711 { NOP1 -> }
|
|
|
712 { NOP2 -> }
|
|
|
713
|
|
|
714 { : DOES1 DOES> @ 1 + ; -> }
|
|
|
715 { : DOES2 DOES> @ 2 + ; -> }
|
|
|
716 { CREATE CR1 -> }
|
|
|
717 { CR1 -> HERE }
|
|
|
718 { ' CR1 >BODY -> HERE }
|
|
|
719 { 1 , -> }
|
|
|
720 { CR1 @ -> 1 }
|
|
|
721 { DOES1 -> }
|
|
|
722 { CR1 -> 2 }
|
|
|
723 { DOES2 -> }
|
|
|
724 { CR1 -> 3 }
|
|
|
725
|
|
|
726 { : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }
|
|
|
727 { WEIRD: W1 -> }
|
|
|
728 { ' W1 >BODY -> HERE }
|
|
|
729 { W1 -> HERE 1 + }
|
|
|
730 { W1 -> HERE 2 + }
|
|
|
731
|
|
|
732 \ ------------------------------------------------------------------------
|
|
|
733 TESTING EVALUATE
|
|
|
734
|
|
|
735 : GE1 S" 123" ; IMMEDIATE
|
|
|
736 : GE2 S" 123 1+" ; IMMEDIATE
|
|
|
737 : GE3 S" : GE4 345 ;" ;
|
|
|
738 : GE5 EVALUATE ; IMMEDIATE
|
|
|
739
|
|
|
740 { GE1 EVALUATE -> 123 } ( TEST EVALUATE IN INTERP. STATE )
|
|
|
741 { GE2 EVALUATE -> 124 }
|
|
|
742 { GE3 EVALUATE -> }
|
|
|
743 { GE4 -> 345 }
|
|
|
744
|
|
|
745 { : GE6 GE1 GE5 ; -> } ( TEST EVALUATE IN COMPILE STATE )
|
|
|
746 { GE6 -> 123 }
|
|
|
747 { : GE7 GE2 GE5 ; -> }
|
|
|
748 { GE7 -> 124 }
|
|
|
749
|
|
|
750 \ ------------------------------------------------------------------------
|
|
|
751 TESTING SOURCE >IN WORD
|
|
|
752
|
|
|
753 : GS1 S" SOURCE" 2DUP EVALUATE
|
|
|
754 >R SWAP >R = R> R> = ;
|
|
|
755 { GS1 -> <TRUE> <TRUE> }
|
|
|
756
|
|
|
757 VARIABLE SCANS
|
|
|
758 : RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
|
|
|
759
|
|
|
760 { 2 SCANS !
|
|
|
761 345 RESCAN?
|
|
|
762 -> 345 345 }
|
|
|
763
|
|
|
764 : GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ;
|
|
|
765 { GS2 -> 123 123 123 123 123 }
|
|
|
766
|
|
|
767 : GS3 BL WORD COUNT SWAP C@ ;
|
|
|
768 { GS3 HELLO -> 5 CHAR H }
|
|
|
769
|
|
|
770 : GS4 SOURCE >IN ! DROP ;
|
|
|
771 { GS4 123 456
|
|
|
772 -> }
|
|
|
773
|
|
|
774 \ ------------------------------------------------------------------------
|
|
|
775 TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
|
|
|
776
|
|
|
777 : S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
|
|
|
778 >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH
|
|
|
779 R> ?DUP IF \ IF NON-EMPTY STRINGS
|
|
|
780 0 DO
|
|
|
781 OVER C@ OVER C@ - IF 2DROP <FALSE> UNLOOP EXIT THEN
|
|
|
782 SWAP CHAR+ SWAP CHAR+
|
|
|
783 LOOP
|
|
|
784 THEN
|
|
|
785 2DROP <TRUE> \ IF WE GET HERE, STRINGS MATCH
|
|
|
786 ELSE
|
|
|
787 R> DROP 2DROP <FALSE> \ LENGTHS MISMATCH
|
|
|
788 THEN ;
|
|
|
789
|
|
|
790 : GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
|
|
|
791 { GP1 -> <TRUE> }
|
|
|
792
|
|
|
793 : GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
|
|
|
794 { GP2 -> <TRUE> }
|
|
|
795
|
|
|
796 : GP3 <# 1 0 # # #> S" 01" S= ;
|
|
|
797 { GP3 -> <TRUE> }
|
|
|
798
|
|
|
799 : GP4 <# 1 0 #S #> S" 1" S= ;
|
|
|
800 { GP4 -> <TRUE> }
|
|
|
801
|
|
|
802 24 CONSTANT MAX-BASE \ BASE 2 .. 36
|
|
|
803 : COUNT-BITS
|
|
|
804 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
|
|
|
805 COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD
|
|
|
806
|
|
|
807 : GP5
|
|
|
808 BASE @ <TRUE>
|
|
|
809 MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE
|
|
|
810 I BASE ! \ TBD: ASSUMES BASE WORKS
|
|
|
811 I 0 <# #S #> S" 10" S= AND
|
|
|
812 LOOP
|
|
|
813 SWAP BASE ! ;
|
|
|
814 { GP5 -> <TRUE> }
|
|
|
815
|
|
|
816 : GP6
|
|
|
817 BASE @ >R 2 BASE !
|
|
|
818 MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY
|
|
|
819 R> BASE ! \ S: C-ADDR U
|
|
|
820 DUP #BITS-UD = SWAP
|
|
|
821 0 DO \ S: C-ADDR FLAG
|
|
|
822 OVER C@ [CHAR] 1 = AND \ ALL ONES
|
|
|
823 >R CHAR+ R>
|
|
|
824 LOOP SWAP DROP ;
|
|
|
825 { GP6 -> <TRUE> }
|
|
|
826
|
|
|
827 \ This is a version I changed from the above
|
|
|
828
|
|
|
829 : GP7
|
|
|
830 BASE @ >R MAX-BASE BASE !
|
|
|
831 <TRUE>
|
|
|
832 A 0 DO
|
|
|
833 I 0 <# #S #>
|
|
|
834 1 = SWAP C@ 30 I + = AND AND
|
|
|
835 LOOP
|
|
|
836 MAX-BASE A DO
|
|
|
837 I 0 <# #S #>
|
|
|
838 1 = SWAP C@ 41 I A - + = AND AND
|
|
|
839 LOOP
|
|
|
840 R> BASE ! ;
|
|
|
841 { GP7 -> <TRUE> }
|
|
|
842
|
|
|
843 \ >NUMBER TESTS
|
|
|
844 CREATE GN-BUF 0 C,
|
|
|
845 : GN-STRING GN-BUF 1 ;
|
|
|
846 : GN-CONSUMED GN-BUF CHAR+ 0 ;
|
|
|
847 : GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ;
|
|
|
848
|
|
|
849 { 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }
|
|
|
850 { 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }
|
|
|
851 { 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }
|
|
|
852 { 0 0 GN' -' >NUMBER -> 0 0 GN-STRING } \ SHOULD FAIL TO CONVERT THESE
|
|
|
853 { 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }
|
|
|
854 { 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }
|
|
|
855
|
|
|
856 : >NUMBER-BASED
|
|
|
857 BASE @ >R BASE ! >NUMBER R> BASE ! ;
|
|
|
858
|
|
|
859 { 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }
|
|
|
860 { 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }
|
|
|
861 { 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }
|
|
|
862 { 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }
|
|
|
863 { 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }
|
|
|
864 { 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }
|
|
|
865
|
|
|
866 : GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
|
|
|
867 BASE @ >R BASE !
|
|
|
868 <# #S #>
|
|
|
869 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY
|
|
|
870 R> BASE ! ;
|
|
|
871 { 0 0 2 GN1 -> 0 0 0 }
|
|
|
872 { MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }
|
|
|
873 { MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }
|
|
|
874 { 0 0 MAX-BASE GN1 -> 0 0 0 }
|
|
|
875 { MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }
|
|
|
876 { MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }
|
|
|
877
|
|
|
878 : GN2 \ ( -- 16 10 )
|
|
|
879 BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ;
|
|
|
880 { GN2 -> 10 A }
|
|
|
881
|
|
|
882 \ ------------------------------------------------------------------------
|
|
|
883 TESTING FILL MOVE
|
|
|
884
|
|
|
885 CREATE FBUF 00 C, 00 C, 00 C,
|
|
|
886 CREATE SBUF 12 C, 34 C, 56 C,
|
|
|
887 : SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ;
|
|
|
888
|
|
|
889 { FBUF 0 20 FILL -> }
|
|
|
890 { SEEBUF -> 00 00 00 }
|
|
|
891
|
|
|
892 { FBUF 1 20 FILL -> }
|
|
|
893 { SEEBUF -> 20 00 00 }
|
|
|
894
|
|
|
895 { FBUF 3 20 FILL -> }
|
|
|
896 { SEEBUF -> 20 20 20 }
|
|
|
897
|
|
|
898 { FBUF FBUF 3 CHARS MOVE -> } \ BIZARRE SPECIAL CASE
|
|
|
899 { SEEBUF -> 20 20 20 }
|
|
|
900
|
|
|
901 { SBUF FBUF 0 CHARS MOVE -> }
|
|
|
902 { SEEBUF -> 20 20 20 }
|
|
|
903
|
|
|
904 { SBUF FBUF 1 CHARS MOVE -> }
|
|
|
905 { SEEBUF -> 12 20 20 }
|
|
|
906
|
|
|
907 { SBUF FBUF 3 CHARS MOVE -> }
|
|
|
908 { SEEBUF -> 12 34 56 }
|
|
|
909
|
|
|
910 { FBUF FBUF CHAR+ 2 CHARS MOVE -> }
|
|
|
911 { SEEBUF -> 12 12 34 }
|
|
|
912
|
|
|
913 { FBUF CHAR+ FBUF 2 CHARS MOVE -> }
|
|
|
914 { SEEBUF -> 12 34 34 }
|
|
|
915
|
|
|
916 \ ------------------------------------------------------------------------
|
|
|
917 TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
|
|
|
918
|
|
|
919 : OUTPUT-TEST
|
|
|
920 ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
|
|
|
921 9 1+ 0 DO I . LOOP CR
|
|
|
922 ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
|
|
|
923 [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
|
|
|
924 ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
|
|
|
925 [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
|
|
|
926 ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
|
|
|
927 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
|
|
|
928 ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
|
|
|
929 S" LINE 1" TYPE CR S" LINE 2" TYPE CR
|
|
|
930 ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
|
|
|
931 ." SIGNED: " MIN-INT . MAX-INT . CR
|
|
|
932 ." UNSIGNED: " 0 U. MAX-UINT U. CR
|
|
|
933 ;
|
|
|
934
|
|
|
935 { OUTPUT-TEST -> }
|
|
|
936
|
|
|
937 \ ------------------------------------------------------------------------
|
|
|
938 TESTING INPUT: ACCEPT
|
|
|
939
|
|
|
940 CREATE ABUF 80 CHARS ALLOT
|
|
|
941
|
|
|
942 : ACCEPT-TEST
|
|
|
943 CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
|
|
|
944 ABUF 80 ACCEPT
|
|
|
945 CR ." RECEIVED: " [CHAR] " EMIT
|
|
|
946 ABUF SWAP TYPE [CHAR] " EMIT CR
|
|
|
947 ;
|
|
|
948
|
|
|
949 { ACCEPT-TEST -> }
|
|
|
950
|
|
|
951 \ ------------------------------------------------------------------------
|
|
|
952 TESTING DICTIONARY SEARCH RULES
|
|
|
953
|
|
|
954 { : GDX 123 ; : GDX GDX 234 ; -> }
|
|
|
955
|
|
|
956 { GDX -> 123 234 }
|
|
|
957
|
