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