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