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: [undefined] postpone-literal [if]
220: : postpone-literal
221: postpone literal ;
222: [then]
223:
224: { : plit [ 42 postpone-literal ] ; -> }
225: { plit -> 42 }
226:
227: testing postpone loop
228: : postpone-loop
229: postpone loop ;
230:
231: { : PLOOP1 DO I [ POSTPONE-LOOP ] ; -> }
232: { 4 1 PLOOP1 -> 1 2 3 }
233: { 2 -1 PLOOP1 -> -1 0 1 }
234: { MID-UINT+1 MID-UINT PLOOP1 -> MID-UINT }
235:
236: { : PLOOP3 DO 1 0 DO J [ POSTPONE-LOOP ] [ POSTPONE-LOOP ] ; -> }
237: { 4 1 PLOOP3 -> 1 2 3 }
238: { 2 -1 PLOOP3 -> -1 0 1 }
239: { MID-UINT+1 MID-UINT PLOOP3 -> MID-UINT }
240:
241: { : PLOOP4 DO 1 0 DO J [ POSTPONE-LOOP ] -1 +LOOP ; -> }
242: { 1 4 PLOOP4 -> 4 3 2 1 }
243: { -1 2 PLOOP4 -> 2 1 0 -1 }
244: { MID-UINT MID-UINT+1 PLOOP4 -> MID-UINT+1 MID-UINT }
245:
246: { : PLOOP5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN [ POSTPONE-LOOP ] ; -> }
247: { 1 PLOOP5 -> 123 }
248: { 5 PLOOP5 -> 123 }
249: { 6 PLOOP5 -> 234 }
250:
251: { : PLOOP6 ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} )
252: 0 SWAP 0 DO
253: I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ [ POSTPONE-LOOP ]
254: [ POSTPONE-LOOP ] ; -> }
255: { 1 PLOOP6 -> 1 }
256: { 2 PLOOP6 -> 3 }
257: { 3 PLOOP6 -> 4 1 2 }
258:
259: testing postpone postpone
260: : postpone-postpone
261: postpone postpone ;
262:
263: { : PPP1 123 ; -> }
264: { : PPP4 [ POSTPONE-POSTPONE PPP1 ] ; IMMEDIATE -> }
265: { : PPP5 PPP4 ; -> }
266: { PPP5 -> 123 }
267: { : PPP6 345 ; IMMEDIATE -> }
268: { : PPP7 [ POSTPONE-POSTPONE PPP6 ] ; -> }
269: { PPP7 -> 345 }
270:
271: testing postpone recurse
272: : postpone-recurse
273: postpone recurse ;
274:
275: { : GREC ( N -- 0,1,..N ) DUP IF DUP >R 1- [ postpone-RECURSE ] R> THEN ; -> }
276: { 0 GREC -> 0 }
277: { 1 GREC -> 0 1 }
278: { 2 GREC -> 0 1 2 }
279: { 3 GREC -> 0 1 2 3 }
280: { 4 GREC -> 0 1 2 3 4 }
281:
282: testing postpone repeat
283: : postpone-repeat
284: postpone repeat ;
285:
286: { : PREP3 BEGIN DUP 5 < WHILE DUP 1+ [ POSTPONE-REPEAT ] ; -> }
287: { 0 PREP3 -> 0 1 2 3 4 5 }
288: { 4 PREP3 -> 4 5 }
289: { 5 PREP3 -> 5 }
290: { 6 PREP3 -> 6 }
291:
292: { : PREP5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ [ POSTPONE-REPEAT ] 123 ELSE 345 THEN ; -> }
293: { 1 PREP5 -> 1 345 }
294: { 2 PREP5 -> 2 345 }
295: { 3 PREP5 -> 3 4 5 123 }
296: { 4 PREP5 -> 4 5 123 }
297: { 5 PREP5 -> 5 123 }
298:
299: testing postpone S"
300: : postpone-s"
301: postpone s" ;
302:
303: { : PSQ4 [ postpone-S" XY" ] ; -> }
304: { PSQ4 SWAP DROP -> 2 }
305: { PSQ4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }
306:
307: testing postpone then
308: : postpone-then
309: postpone then ;
310:
311: { : PTH1 IF 123 [ POSTPONE-THEN ] ; -> }
312: { : PTH2 IF 123 ELSE 234 [ POSTPONE-THEN ] ; -> }
313: { 0 PTH1 -> }
314: { 1 PTH1 -> 123 }
315: { -1 PTH1 -> 123 }
316: { 0 PTH2 -> 234 }
317: { 1 PTH2 -> 123 }
318: { -1 PTH1 -> 123 }
319:
320: { : PTH5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 [ POSTPONE-THEN ] ; -> }
321: { 1 PTH5 -> 1 345 }
322: { 2 PTH5 -> 2 345 }
323: { 3 PTH5 -> 3 4 5 123 }
324: { 4 PTH5 -> 4 5 123 }
325: { 5 PTH5 -> 5 123 }
326:
327: { : PTH6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> [ POSTPONE-THEN ] ; -> }
328: { 0 PTH6 -> 0 }
329: { 1 PTH6 -> 0 1 }
330: { 2 PTH6 -> 0 1 2 }
331: { 3 PTH6 -> 0 1 2 3 }
332: { 4 PTH6 -> 0 1 2 3 4 }
333:
334: testing postpone until
335: : postpone-until
336: postpone until ;
337:
338: { : PUNT4 BEGIN DUP 1+ DUP 5 > [ postpone-UNTIL ] ; -> }
339: { 3 PUNT4 -> 3 4 5 6 }
340: { 5 PUNT4 -> 5 6 }
341: { 6 PUNT4 -> 6 7 }
342:
343: testing postpone while
344: : postpone-while
345: postpone while ;
346:
347: { : PWH3 BEGIN DUP 5 < [ POSTPONE-WHILE ] DUP 1+ REPEAT ; -> }
348: { 0 PWH3 -> 0 1 2 3 4 5 }
349: { 4 PWH3 -> 4 5 }
350: { 5 PWH3 -> 5 }
351: { 6 PWH3 -> 6 }
352:
353: { : PWH5 BEGIN DUP 2 > [ POSTPONE-WHILE ] DUP 5 < [ POSTPONE-WHILE ] DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }
354: { 1 PWH5 -> 1 345 }
355: { 2 PWH5 -> 2 345 }
356: { 3 PWH5 -> 3 4 5 123 }
357: { 4 PWH5 -> 4 5 123 }
358: { 5 PWH5 -> 5 123 }
359:
360:
361: testing postpone [
362: : postpone-[
363: postpone [ ;
364:
365: { here postpone-[ -> here }
366:
367: testing postpone [']
368: : postpone-[']
369: postpone ['] ;
370:
371: { : PTICK1 123 ; -> }
372: { : PTICK2 [ postpone-['] PTICK1 ] ; IMMEDIATE -> }
373: { PTICK2 EXECUTE -> 123 }
374:
375: testing postpone [char]
376: : postpone-[char]
377: postpone [char] ;
378:
379: { : PCHAR1 [ postpone-[CHAR] X ] ; -> }
380: { : PCHAR2 [ postpone-[CHAR] HELLO ] ; -> }
381: { PCHAR1 -> 58 }
382: { PCHAR2 -> 48 }
383:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to postpone.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / test