1: \ checks that postpone works correctly with words with special
2: \ compilation semantics
3:
4: \ by M. Anton Ertl 1996
5:
6: \ This file is based on John Hayes' core.fr (coretest.fs), which has
7: \ the following copyright notice:
8:
9: \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
10: \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
11:
12: \ my contributions to this file are in the public domain
13:
14: \ you have to load John Hayes' tester.fs (=tester.fr) and coretest.fs
15: \ (core.fr) first
16:
17: \ These tests are especially useful for showing that state-smart
18: \ implementations of words with special compilation semantics,
19: \ combined with a straight-forward implementation of POSTPONE (and
20: \ [COMPILE]) do not conform to the ANS Forth standard. The essential
21: \ sentences in the standad are:
22:
23: \ 6.1.2033 POSTPONE CORE
24: \ ...
25: \ Compilation: ( <spaces>name -- )
26:
27: \ Skip leading space delimiters. Parse name delimited by a space. Find
28: \ name. Append the compilation semantics of name to the current
29: \ definition.
30:
31: \ 6.2.2530 [COMPILE] bracket-compile CORE EXT
32: \ ...
33: \ Compilation: ( <spaces>name -- )
34:
35: \ Skip leading space delimiters. Parse name delimited by a space. Find
36: \ name. If name has other than default compilation semantics, append
37: \ them to the current definition;...
38:
39:
40: \ Note that the compilation semantics are appended, not some
41: \ state-dependent semantics.
42:
43: \ first I test against a non-ANS solution suggested by Bernd Paysan
44:
45: : state@-now ( -- f )
46: state @ ; immediate
47:
48: : state@ ( -- f )
49: POSTPONE state@-now ;
50:
51: { state@ -> state @ }
52:
53: \ here I test POSTPONE with all core words with special compilation
54: \ semantics.
55:
56: testing postpone (
57:
58: : postpone-(
59: postpone ( ;
60:
61: { : pp1 [ postpone-( does nothing ) ] ; -> }
62: { here pp1 -> here }
63:
64: testing postpone +loop
65:
66: : postpone-+loop
67: postpone +loop ;
68:
69: { : PGD2 DO I -1 [ POSTPONE-+LOOP ] ; -> }
70: { 1 4 PGD2 -> 4 3 2 1 }
71: { -1 2 PGD2 -> 2 1 0 -1 }
72: { MID-UINT MID-UINT+1 PGD2 -> MID-UINT+1 MID-UINT }
73:
74: { : PGD4 DO 1 0 DO J LOOP -1 [ POSTPONE-+LOOP ] ; -> }
75: { 1 4 PGD4 -> 4 3 2 1 }
76: { -1 2 PGD4 -> 2 1 0 -1 }
77: { MID-UINT MID-UINT+1 PGD4 -> MID-UINT+1 MID-UINT }
78:
79: testing postpone ."
80:
81: : postpone-."
82: postpone ." ;
83:
84: : pdq2 [ postpone-." you should see this later. " ] cr ;
85: : pdq1 [ postpone-." you should see this first. " ] cr ;
86: { pdq1 pdq2 -> }
87:
88: testing postpone ;
89: : postpone-;
90: postpone ; ;
91:
92: { : psc [ postpone-; -> }
93: { psc -> }
94:
95: testing postpone abort"
96:
97: : postpone-abort"
98: postpone abort" ;
99:
100: { : paq1 [ postpone-abort" this should not abort" ] ; -> }
101:
102: testing postpone begin
103: : postpone-begin
104: postpone begin ;
105:
106: { : PB3 [ POSTPONE-BEGIN ] DUP 5 < WHILE DUP 1+ REPEAT ; -> }
107: { 0 PB3 -> 0 1 2 3 4 5 }
108: { 4 PB3 -> 4 5 }
109: { 5 PB3 -> 5 }
110: { 6 PB3 -> 6 }
111:
112: { : PB4 [ POSTPONE-BEGIN ] DUP 1+ DUP 5 > UNTIL ; -> }
113: { 3 PB4 -> 3 4 5 6 }
114: { 5 PB4 -> 5 6 }
115: { 6 PB4 -> 6 7 }
116:
117: { : PB5 [ POSTPONE-BEGIN ] DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }
118: { 1 PB5 -> 1 345 }
119: { 2 PB5 -> 2 345 }
120: { 3 PB5 -> 3 4 5 123 }
121: { 4 PB5 -> 4 5 123 }
122: { 5 PB5 -> 5 123 }
123:
124: testing postpone do
125: : postpone-do
126: postpone do ;
127:
128: { : PDO1 [ POSTPONE-DO ] I LOOP ; -> }
129: { 4 1 PDO1 -> 1 2 3 }
130: { 2 -1 PDO1 -> -1 0 1 }
131: { MID-UINT+1 MID-UINT PDO1 -> MID-UINT }
132:
133: { : PDO2 [ POSTPONE-DO ] I -1 +LOOP ; -> }
134: { 1 4 PDO2 -> 4 3 2 1 }
135: { -1 2 PDO2 -> 2 1 0 -1 }
136: { MID-UINT MID-UINT+1 PDO2 -> MID-UINT+1 MID-UINT }
137:
138: { : PDO3 [ POSTPONE-DO ] 1 0 [ POSTPONE-DO ] J LOOP LOOP ; -> }
139: { 4 1 PDO3 -> 1 2 3 }
140: { 2 -1 PDO3 -> -1 0 1 }
141: { MID-UINT+1 MID-UINT PDO3 -> MID-UINT }
142:
143: { : PDO4 [ POSTPONE-DO ] 1 0 [ POSTPONE-DO ] J LOOP -1 +LOOP ; -> }
144: { 1 4 PDO4 -> 4 3 2 1 }
145: { -1 2 PDO4 -> 2 1 0 -1 }
146: { MID-UINT MID-UINT+1 PDO4 -> MID-UINT+1 MID-UINT }
147:
148: { : PDO5 123 SWAP 0 [ POSTPONE-DO ] I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }
149: { 1 PDO5 -> 123 }
150: { 5 PDO5 -> 123 }
151: { 6 PDO5 -> 234 }
152:
153: { : PDO6 ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} )
154: 0 SWAP 0 [ POSTPONE-DO ]
155: I 1+ 0 [ POSTPONE-DO ] I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
156: LOOP ; -> }
157: { 1 PDO6 -> 1 }
158: { 2 PDO6 -> 3 }
159: { 3 PDO6 -> 4 1 2 }
160:
161: testing postpone does>
162: : postpone-does>
163: postpone does> ;
164:
165: { : PDOES1 [ POSTPONE-DOES> ] @ 1 + ; -> }
166: { : PDOES2 [ POSTPONE-DOES> ] @ 2 + ; -> }
167: { CREATE PCR1 -> }
168: { PCR1 -> HERE }
169: { ' PCR1 >BODY -> HERE }
170: { 1 , -> }
171: { PCR1 @ -> 1 }
172: { PDOES1 -> }
173: { PCR1 -> 2 }
174: { PDOES2 -> }
175: { PCR1 -> 3 }
176:
177: { : pWEIRD: CREATE [ POSTPONE-DOES> ] 1 + [ POSTPONE-DOES> ] 2 + ; -> }
178: { pWEIRD: PW1 -> }
179: { ' PW1 >BODY -> HERE }
180: { PW1 -> HERE 1 + }
181: { PW1 -> HERE 2 + }
182:
183: testing postpone else
184: : postpone-else
185: postpone else ;
186:
187: { : PELSE1 IF 123 [ postpone-ELSE ] 234 THEN ; -> }
188: { 0 PELSE1 -> 234 }
189: { 1 PELSE1 -> 123 }
190:
191: { : PELSE2 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 [ postpone-ELSE ] 345 THEN ; -> }
192: { 1 PELSE2 -> 1 345 }
193: { 2 PELSE2 -> 2 345 }
194: { 3 PELSE2 -> 3 4 5 123 }
195: { 4 PELSE2 -> 4 5 123 }
196: { 5 PELSE2 -> 5 123 }
197:
198: testing postpone if
199: : postpone-if
200: postpone if ;
201:
202: { : PIF1 [ POSTPONE-IF ] 123 THEN ; -> }
203: { : PIF2 [ POSTPONE-IF ] 123 ELSE 234 THEN ; -> }
204: { 0 PIF1 -> }
205: { 1 PIF1 -> 123 }
206: { -1 PIF1 -> 123 }
207: { 0 PIF2 -> 234 }
208: { 1 PIF2 -> 123 }
209: { -1 PIF1 -> 123 }
210:
211: { : PIF6 ( N -- 0,1,..N ) DUP [ POSTPONE-IF ] DUP >R 1- RECURSE R> THEN ; -> }
212: { 0 PIF6 -> 0 }
213: { 1 PIF6 -> 0 1 }
214: { 2 PIF6 -> 0 1 2 }
215: { 3 PIF6 -> 0 1 2 3 }
216: { 4 PIF6 -> 0 1 2 3 4 }
217:
218: testing postpone literal
219: : postpone-literal
220: postpone literal ;
221:
222: { : plit [ 42 postpone-literal ] ; -> }
223: { plit -> 42 }
224:
225: testing postpone loop
226: : postpone-loop
227: postpone loop ;
228:
229: { : PLOOP1 DO I [ POSTPONE-LOOP ] ; -> }
230: { 4 1 PLOOP1 -> 1 2 3 }
231: { 2 -1 PLOOP1 -> -1 0 1 }
232: { MID-UINT+1 MID-UINT PLOOP1 -> MID-UINT }
233:
234: { : PLOOP3 DO 1 0 DO J [ POSTPONE-LOOP ] [ POSTPONE-LOOP ] ; -> }
235: { 4 1 PLOOP3 -> 1 2 3 }
236: { 2 -1 PLOOP3 -> -1 0 1 }
237: { MID-UINT+1 MID-UINT PLOOP3 -> MID-UINT }
238:
239: { : PLOOP4 DO 1 0 DO J [ POSTPONE-LOOP ] -1 +LOOP ; -> }
240: { 1 4 PLOOP4 -> 4 3 2 1 }
241: { -1 2 PLOOP4 -> 2 1 0 -1 }
242: { MID-UINT MID-UINT+1 PLOOP4 -> MID-UINT+1 MID-UINT }
243:
244: { : PLOOP5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN [ POSTPONE-LOOP ] ; -> }
245: { 1 PLOOP5 -> 123 }
246: { 5 PLOOP5 -> 123 }
247: { 6 PLOOP5 -> 234 }
248:
249: { : PLOOP6 ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} )
250: 0 SWAP 0 DO
251: I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ [ POSTPONE-LOOP ]
252: [ POSTPONE-LOOP ] ; -> }
253: { 1 PLOOP6 -> 1 }
254: { 2 PLOOP6 -> 3 }
255: { 3 PLOOP6 -> 4 1 2 }
256:
257: testing postpone postpone
258: : postpone-postpone
259: postpone postpone ;
260:
261: { : PPP1 123 ; -> }
262: { : PPP4 [ POSTPONE-POSTPONE PPP1 ] ; IMMEDIATE -> }
263: { : PPP5 PPP4 ; -> }
264: { PPP5 -> 123 }
265: { : PPP6 345 ; IMMEDIATE -> }
266: { : PPP7 [ POSTPONE-POSTPONE PPP6 ] ; -> }
267: { PPP7 -> 345 }
268:
269: testing postpone recurse
270: : postpone-recurse
271: postpone recurse ;
272:
273: { : GREC ( N -- 0,1,..N ) DUP IF DUP >R 1- [ postpone-RECURSE ] R> THEN ; -> }
274: { 0 GREC -> 0 }
275: { 1 GREC -> 0 1 }
276: { 2 GREC -> 0 1 2 }
277: { 3 GREC -> 0 1 2 3 }
278: { 4 GREC -> 0 1 2 3 4 }
279:
280: testing postpone repeat
281: : postpone-repeat
282: postpone repeat ;
283:
284: { : PREP3 BEGIN DUP 5 < WHILE DUP 1+ [ POSTPONE-REPEAT ] ; -> }
285: { 0 PREP3 -> 0 1 2 3 4 5 }
286: { 4 PREP3 -> 4 5 }
287: { 5 PREP3 -> 5 }
288: { 6 PREP3 -> 6 }
289:
290: { : PREP5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ [ POSTPONE-REPEAT ] 123 ELSE 345 THEN ; -> }
291: { 1 PREP5 -> 1 345 }
292: { 2 PREP5 -> 2 345 }
293: { 3 PREP5 -> 3 4 5 123 }
294: { 4 PREP5 -> 4 5 123 }
295: { 5 PREP5 -> 5 123 }
296:
297: testing postpone S"
298: : postpone-s"
299: postpone s" ;
300:
301: { : PSQ4 [ postpone-S" XY" ] ; -> }
302: { PSQ4 SWAP DROP -> 2 }
303: { PSQ4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }
304:
305: testing postpone then
306: : postpone-then
307: postpone then ;
308:
309: { : PTH1 IF 123 [ POSTPONE-THEN ] ; -> }
310: { : PTH2 IF 123 ELSE 234 [ POSTPONE-THEN ] ; -> }
311: { 0 PTH1 -> }
312: { 1 PTH1 -> 123 }
313: { -1 PTH1 -> 123 }
314: { 0 PTH2 -> 234 }
315: { 1 PTH2 -> 123 }
316: { -1 PTH1 -> 123 }
317:
318: { : PTH5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 [ POSTPONE-THEN ] ; -> }
319: { 1 PTH5 -> 1 345 }
320: { 2 PTH5 -> 2 345 }
321: { 3 PTH5 -> 3 4 5 123 }
322: { 4 PTH5 -> 4 5 123 }
323: { 5 PTH5 -> 5 123 }
324:
325: { : PTH6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> [ POSTPONE-THEN ] ; -> }
326: { 0 PTH6 -> 0 }
327: { 1 PTH6 -> 0 1 }
328: { 2 PTH6 -> 0 1 2 }
329: { 3 PTH6 -> 0 1 2 3 }
330: { 4 PTH6 -> 0 1 2 3 4 }
331:
332: testing postpone until
333: : postpone-until
334: postpone until ;
335:
336: { : PUNT4 BEGIN DUP 1+ DUP 5 > [ postpone-UNTIL ] ; -> }
337: { 3 PUNT4 -> 3 4 5 6 }
338: { 5 PUNT4 -> 5 6 }
339: { 6 PUNT4 -> 6 7 }
340:
341: testing postpone while
342: : postpone-while
343: postpone while ;
344:
345: { : PWH3 BEGIN DUP 5 < [ POSTPONE-WHILE ] DUP 1+ REPEAT ; -> }
346: { 0 PWH3 -> 0 1 2 3 4 5 }
347: { 4 PWH3 -> 4 5 }
348: { 5 PWH3 -> 5 }
349: { 6 PWH3 -> 6 }
350:
351: { : PWH5 BEGIN DUP 2 > [ POSTPONE-WHILE ] DUP 5 < [ POSTPONE-WHILE ] DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }
352: { 1 PWH5 -> 1 345 }
353: { 2 PWH5 -> 2 345 }
354: { 3 PWH5 -> 3 4 5 123 }
355: { 4 PWH5 -> 4 5 123 }
356: { 5 PWH5 -> 5 123 }
357:
358:
359: testing postpone [
360: : postpone-[
361: postpone [ ;
362:
363: { here postpone-[ -> here }
364:
365: testing postpone [']
366: : postpone-[']
367: postpone ['] ;
368:
369: { : PTICK1 123 ; -> }
370: { : PTICK2 [ postpone-['] PTICK1 ] ; IMMEDIATE -> }
371: { PTICK2 EXECUTE -> 123 }
372:
373: testing postpone [char]
374: : postpone-[char]
375: postpone [char] ;
376:
377: { : PCHAR1 [ postpone-[CHAR] X ] ; -> }
378: { : PCHAR2 [ postpone-[CHAR] HELLO ] ; -> }
379: { PCHAR1 -> 58 }
380: { PCHAR2 -> 48 }
381:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>