Annotation of gforth/test/postpone.fs, revision 1.2

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
1.2     ! anton     219: [undefined] postpone-literal [if]
1.1       anton     220: : postpone-literal
                    221:     postpone literal ;
1.2     ! anton     222: [then]
1.1       anton     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>