File:  [gforth] / gforth / test / ttester.fs
Revision 1.16: download - view: text, annotated - select for diffs
Mon Sep 21 15:32:56 2009 UTC (8 years ago) by anton
Branches: MAIN
CVS tags: HEAD
removed HEX usage

    1: \ This file contains the code for ttester, a utility for testing Forth words,
    2: \ as developed by several authors (see below), together with some explanations
    3: \ of its use.
    4: 
    5: \ ttester is based on the original tester suite by Hayes:
    6: \ From: John Hayes S1I
    7: \ Subject: tester.fr
    8: \ Date: Mon, 27 Nov 95 13:10:09 PST  
    9: \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
   10: \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
   11: \ VERSION 1.1
   12: \ All the subsequent changes have been placed in the public domain.
   13: \ The primary changes from the original are the replacement of "{" by "T{"
   14: \ and "}" by "}T" (to avoid conflicts with the uses of { for locals and }
   15: \ for FSL arrays), modifications so that the stack is allowed to be non-empty
   16: \ before T{, and extensions for the handling of floating point tests.
   17: \ Code for testing equality of floating point values comes
   18: \ from ftester.fs written by David N. Williams, based on the idea of
   19: \ approximate equality in Dirk Zoller's float.4th.
   20: \ Further revisions were provided by Anton Ertl, including the ability
   21: \ to handle either integrated or separate floating point stacks.
   22: \ Revision history and possibly newer versions can be found at
   23: \ http://www.complang.tuwien.ac.at/cvsweb/cgi-bin/cvsweb/gforth/test/ttester.fs
   24: \ Explanatory material and minor reformatting (no code changes) by
   25: \ C. G. Montgomery March 2009, with helpful comments from David Williams
   26: \ and Krishna Myneni.
   27: 
   28: \ Usage:
   29: 
   30: \ The basic usage takes the form  T{ <code> -> <expected stack> }T .
   31: \ This executes  <code>  and compares the resulting stack contents with
   32: \ the  <expected stack>  values, and reports any discrepancy between the
   33: \ two sets of values.
   34: \ For example:
   35: \ T{ 1 2 3 swap -> 1 3 2 }T  ok
   36: \ T{ 1 2 3 swap -> 1 2 2 }T INCORRECT RESULT: T{ 1 2 3 swap -> 1 2 2 }T ok
   37: \ T{ 1 2 3 swap -> 1 2 }T WRONG NUMBER OF RESULTS: T{ 1 2 3 swap -> 1 2 }T ok
   38: 
   39: \ Floating point testing can involve further complications.  The code
   40: \ attempts to determine whether floating-point support is present, and
   41: \ if so, whether there is a separate floating-point stack, and behave
   42: \ accordingly.  The CONSTANTs HAS-FLOATING and HAS-FLOATING-STACK
   43: \ contain the results of its efforts, so the behavior of the code can
   44: \ be modified by the user if necessary.
   45: 
   46: \ Then there are the perennial issues of floating point value
   47: \ comparisons.  Exact equality is specified by SET-EXACT (the
   48: \ default).  If approximate equality tests are desired, execute
   49: \ SET-NEAR .  Then the FVARIABLEs REL-NEAR (default 1E-12) and
   50: \ ABS-NEAR (default 0E) contain the values to be used in comparisons
   51: \ by the (internal) word FNEARLY= .
   52: 
   53: \ When there is not a separate floating point stack and you want to
   54: \ use approximate equality for FP values, it is necessary to identify
   55: \ which stack items are floating point quantities.  This can be done
   56: \ by replacing the closing }T with a version that specifies this, such
   57: \ as RRXR}T which identifies the stack picture ( r r x r ).  The code
   58: \ provides such words for all combinations of R and X with up to four
   59: \ stack items.  They can be used with either an integrated or separate
   60: \ floating point stacks. Adding more if you need them is
   61: \ straightforward; see the examples in the source.  Here is an example
   62: \ which also illustrates controlling the precision of comparisons:
   63: 
   64: \   SET-NEAR
   65: \   1E-6 REL-NEAR F!
   66: \   T{ S" 3.14159E" >FLOAT -> -1E FACOS TRUE RX}T
   67: 
   68: \ The word ERROR is now vectored, so that its action can be changed by
   69: \ the user (for example, to add a counter for the number of errors).
   70: \ The default action ERROR1 can be used as a factor in the display of
   71: \ error reports.
   72: 
   73: \ Loading ttester.fs does not change BASE.  Remember that floating point input
   74: \ is ambiguous if the base is not decimal.
   75: 
   76: \ The file defines some 70 words in all, but in most cases only the
   77: \ ones mentioned above will be needed for successful testing.
   78: 
   79: BASE @
   80: DECIMAL
   81: 
   82: VARIABLE ACTUAL-DEPTH			\ stack record
   83: CREATE ACTUAL-RESULTS 32 CELLS ALLOT
   84: VARIABLE START-DEPTH
   85: VARIABLE XCURSOR      \ for ...}T
   86: VARIABLE ERROR-XT
   87: 
   88: : ERROR ERROR-XT @ EXECUTE ;   \ for vectoring of error reporting
   89: 
   90: : "FLOATING" S" FLOATING" ;    \ only compiled S" in CORE
   91: : "FLOATING-STACK" S" FLOATING-STACK" ;
   92: "FLOATING" ENVIRONMENT? [IF]
   93:     [IF]
   94:         TRUE
   95:     [ELSE]
   96:         FALSE
   97:     [THEN]
   98: [ELSE]
   99:     FALSE
  100: [THEN] CONSTANT HAS-FLOATING
  101: "FLOATING-STACK" ENVIRONMENT? [IF]
  102:     [IF]
  103:         TRUE
  104:     [ELSE]
  105:         FALSE
  106:     [THEN]
  107: [ELSE]            \ We don't know whether the FP stack is separate.
  108:     HAS-FLOATING  \ If we have FLOATING, we assume it is.
  109: [THEN] CONSTANT HAS-FLOATING-STACK
  110: 
  111: HAS-FLOATING [IF]
  112:     \ Set the following to the relative and absolute tolerances you
  113:     \ want for approximate float equality, to be used with F~ in
  114:     \ FNEARLY=.  Keep the signs, because F~ needs them.
  115:     FVARIABLE REL-NEAR 1E-12 REL-NEAR F!
  116:     FVARIABLE ABS-NEAR 0E    ABS-NEAR F!
  117: 
  118:     \ When EXACT? is TRUE, }F uses FEXACTLY=, otherwise FNEARLY=.
  119:     
  120:     TRUE VALUE EXACT?
  121:     : SET-EXACT  ( -- )   TRUE TO EXACT? ;
  122:     : SET-NEAR   ( -- )  FALSE TO EXACT? ;
  123: 
  124:     : FEXACTLY=  ( F: X Y -- S: FLAG )
  125:         (
  126:         Leave TRUE if the two floats are identical.
  127:         )
  128:         0E F~ ;
  129:     
  130:     : FABS=  ( F: X Y -- S: FLAG )
  131:         (
  132:         Leave TRUE if the two floats are equal within the tolerance
  133:         stored in ABS-NEAR.
  134:         )
  135:         ABS-NEAR F@ F~ ;
  136:     
  137:     : FREL=  ( F: X Y -- S: FLAG )
  138:         (
  139:         Leave TRUE if the two floats are relatively equal based on the
  140:         tolerance stored in ABS-NEAR.
  141:         )
  142:         REL-NEAR F@ FNEGATE F~ ;
  143: 
  144:     : F2DUP  FOVER FOVER ;
  145:     : F2DROP FDROP FDROP ;
  146:     
  147:     : FNEARLY=  ( F: X Y -- S: FLAG )
  148:         (
  149:         Leave TRUE if the two floats are nearly equal.  This is a 
  150:         refinement of Dirk Zoller's FEQ to also allow X = Y, including
  151:         both zero, or to allow approximately equality when X and Y are too
  152:         small to satisfy the relative approximation mode in the F~ 
  153:         specification.
  154:         )
  155:         F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN
  156:         F2DUP FREL=     IF F2DROP TRUE EXIT THEN
  157:         FABS= ;
  158: 
  159:     : FCONF= ( R1 R2 -- F )
  160:         EXACT? IF
  161:             FEXACTLY=
  162:         ELSE
  163:             FNEARLY=
  164:         THEN ;
  165: [THEN]
  166: 
  167: HAS-FLOATING-STACK [IF]
  168:     VARIABLE ACTUAL-FDEPTH
  169:     CREATE ACTUAL-FRESULTS 32 FLOATS ALLOT
  170:     VARIABLE START-FDEPTH
  171:     VARIABLE FCURSOR
  172: 
  173:     : EMPTY-FSTACK ( ... -- ... )
  174:         FDEPTH START-FDEPTH @ < IF
  175:             FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
  176:         THEN
  177:         FDEPTH START-FDEPTH @ > IF
  178:             FDEPTH START-FDEPTH @ DO FDROP LOOP
  179:         THEN ;
  180:     
  181:     : F{ ( -- )
  182:         FDEPTH START-FDEPTH ! 0 FCURSOR ! ;
  183: 
  184:     : F-> ( ... -- ... )
  185:         FDEPTH DUP ACTUAL-FDEPTH !
  186:         START-FDEPTH @ > IF
  187:             FDEPTH START-FDEPTH @ - 0 DO ACTUAL-FRESULTS I FLOATS + F! LOOP
  188:         THEN ;
  189: 
  190:     : F} ( ... -- ... )
  191:         FDEPTH ACTUAL-FDEPTH @ = IF
  192:             FDEPTH START-FDEPTH @ > IF
  193:                 FDEPTH START-FDEPTH @ - 0 DO
  194:                     ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF
  195:                         S" INCORRECT FP RESULT: " ERROR LEAVE
  196:                     THEN
  197:                 LOOP
  198:             THEN
  199:         ELSE
  200:             S" WRONG NUMBER OF FP RESULTS: " ERROR
  201:         THEN ;
  202: 
  203:     : F...}T ( -- )
  204:         FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF
  205:             S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR
  206:         ELSE FDEPTH START-FDEPTH @ = 0= IF
  207:             S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
  208:         THEN THEN ;
  209: 
  210:     
  211:     : FTESTER ( R -- )
  212:         FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ START-FDEPTH @ + 1+ < OR IF
  213:             S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR 
  214:         ELSE ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
  215:             S" INCORRECT FP RESULT: " ERROR
  216:         THEN THEN
  217:         1 FCURSOR +! ;
  218:         
  219: [ELSE]
  220:     : EMPTY-FSTACK ;
  221:     : F{ ;
  222:     : F-> ;
  223:     : F} ;
  224:     : F...}T ;
  225: 
  226:     HAS-FLOATING [IF]
  227:     : COMPUTE-CELLS-PER-FP ( -- U )
  228:         DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ;
  229: 
  230:     COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP
  231: 
  232:     : FTESTER ( R -- )
  233:         DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + CELLS-PER-FP + < OR IF
  234:             S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
  235:         ELSE ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
  236:             S" INCORRECT FP RESULT: " ERROR
  237:         THEN THEN
  238:         CELLS-PER-FP XCURSOR +! ;
  239:     [THEN]
  240: [THEN]    
  241: 
  242: : EMPTY-STACK	\ ( ... -- ) empty stack; handles underflowed stack too.
  243:     DEPTH START-DEPTH @ < IF
  244:         DEPTH START-DEPTH @ SWAP DO 0 LOOP
  245:     THEN
  246:     DEPTH START-DEPTH @ > IF
  247:         DEPTH START-DEPTH @ DO DROP LOOP
  248:     THEN
  249:     EMPTY-FSTACK ;
  250: 
  251: : ERROR1	\ ( C-ADDR U -- ) display an error message 
  252: 		\ followed by the line that had the error.
  253:    TYPE SOURCE TYPE CR			\ display line corresponding to error
  254:    EMPTY-STACK				\ throw away everything else
  255: ;
  256: 
  257: ' ERROR1 ERROR-XT !
  258: 
  259: : T{		\ ( -- ) syntactic sugar.
  260:    DEPTH START-DEPTH ! 0 XCURSOR ! F{ ;
  261: 
  262: : ->		\ ( ... -- ) record depth and contents of stack.
  263:    DEPTH DUP ACTUAL-DEPTH !		\ record depth
  264:    START-DEPTH @ > IF		\ if there is something on the stack
  265:        DEPTH START-DEPTH @ - 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ save them
  266:    THEN
  267:    F-> ;
  268: 
  269: : }T		\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
  270: 		\ (ACTUAL) CONTENTS.
  271:    DEPTH ACTUAL-DEPTH @ = IF		\ if depths match
  272:       DEPTH START-DEPTH @ > IF		\ if there is something on the stack
  273:          DEPTH START-DEPTH @ - 0 DO	\ for each stack item
  274: 	    ACTUAL-RESULTS I CELLS + @	\ compare actual with expected
  275: 	    <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
  276: 	 LOOP
  277:       THEN
  278:    ELSE					\ depth mismatch
  279:       S" WRONG NUMBER OF RESULTS: " ERROR
  280:    THEN
  281:    F} ;
  282: 
  283: : ...}T ( -- )
  284:     XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF
  285:         S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR
  286:     ELSE DEPTH START-DEPTH @ = 0= IF
  287:         S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
  288:     THEN THEN
  289:     F...}T ;
  290: 
  291: : XTESTER ( X -- )
  292:     DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF
  293:         S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
  294:     ELSE ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF
  295:         S" INCORRECT CELL RESULT: " ERROR
  296:     THEN THEN
  297:     1 XCURSOR +! ;
  298: 
  299: : X}T XTESTER ...}T ;
  300: : XX}T XTESTER XTESTER ...}T ;
  301: : XXX}T XTESTER XTESTER XTESTER ...}T ;
  302: : XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ;
  303: 
  304: HAS-FLOATING [IF]
  305: : R}T FTESTER ...}T ;
  306: : XR}T FTESTER XTESTER ...}T ;
  307: : RX}T XTESTER FTESTER ...}T ;
  308: : RR}T FTESTER FTESTER ...}T ;
  309: : XXR}T FTESTER XTESTER XTESTER ...}T ;
  310: : XRX}T XTESTER FTESTER XTESTER ...}T ;
  311: : XRR}T FTESTER FTESTER XTESTER ...}T ;
  312: : RXX}T XTESTER XTESTER FTESTER ...}T ;
  313: : RXR}T FTESTER XTESTER FTESTER ...}T ;
  314: : RRX}T XTESTER FTESTER FTESTER ...}T ;
  315: : RRR}T FTESTER FTESTER FTESTER ...}T ;
  316: : XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ;
  317: : XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ;
  318: : XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ;
  319: : XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ;
  320: : XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ;
  321: : XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ;
  322: : XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ;
  323: : RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ;
  324: : RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ;
  325: : RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ;
  326: : RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ;
  327: : RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ;
  328: : RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ;
  329: : RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ;
  330: : RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ;
  331: [THEN]
  332: 
  333: \ Set the following flag to TRUE for more verbose output; this may
  334: \ allow you to tell which test caused your system to hang.
  335: VARIABLE VERBOSE
  336:    FALSE VERBOSE !
  337: 
  338: : TESTING	\ ( -- ) TALKING COMMENT.
  339:    SOURCE VERBOSE @
  340:    IF DUP >R TYPE CR R> >IN !
  341:    ELSE >IN ! DROP
  342:    THEN ;
  343: 
  344: BASE !
  345: \ end of ttester.fs

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