Annotation of gforth/postponetest.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>