File:  [gforth] / gforth / test / postpone.fs
Revision 1.3: download - view: text, annotated - select for diffs
Fri Jun 22 00:48:48 2012 UTC (7 years, 1 month ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added postpone test, added smartdots.fs to list of sources

    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: 
  384: \ test if we can build entire macros
  385: 
  386: testing postpone macros
  387: : n+: ( N -- )  >R  : R> POSTPONE LITERAL POSTPONE + POSTPONE ; ;
  388: 3 n+: 3+
  389: : bar 3+ ;
  390: { 5 bar -> 8 }

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>