File:  [gforth] / gforth / test / postpone.fs
Revision 1.1: download - view: text, annotated - select for diffs
Wed May 21 20:40:20 1997 UTC (26 years, 10 months ago) by anton
Branches: MAIN
CVS tags: v0-7-0, v0-6-2, v0-6-1, v0-6-0, v0-5-0, v0-4-0, HEAD
jwilke's changes:
Moved many files to other directories
renamed many files
other changes unknown to me.

    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>