[gforth] / gforth / Attic / postponetest.fs  

gforth: gforth/Attic/postponetest.fs

1 : anton 1.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 :    
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help