Annotation of gforth/test/postpone.fs, revision 1.1
1.1 ! anton 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>
![[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