File:  [gforth] / gforth / test / ttester.fs
Revision 1.14: download - view: text, annotated - select for diffs
Wed Apr 8 19:59:17 2009 UTC (8 years, 8 months ago) by anton
Branches: MAIN
CVS tags: HEAD
Comments made nicer by Charles G Montgomery et al.

    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: HEX
   81: 
   82: VARIABLE ACTUAL-DEPTH			\ stack record
   83: CREATE ACTUAL-RESULTS 20 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 DECIMAL 1E-12 HEX REL-NEAR F!
  116:     FVARIABLE ABS-NEAR    DECIMAL 0E HEX 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:     DECIMAL
  125:     : FEXACTLY=  ( F: X Y -- S: FLAG )
  126:         (
  127:         Leave TRUE if the two floats are identical.
  128:         )
  129:         0E F~ ;
  130:     HEX
  131:     
  132:     : FABS=  ( F: X Y -- S: FLAG )
  133:         (
  134:         Leave TRUE if the two floats are equal within the tolerance
  135:         stored in ABS-NEAR.
  136:         )
  137:         ABS-NEAR F@ F~ ;
  138:     
  139:     : FREL=  ( F: X Y -- S: FLAG )
  140:         (
  141:         Leave TRUE if the two floats are relatively equal based on the
  142:         tolerance stored in ABS-NEAR.
  143:         )
  144:         REL-NEAR F@ FNEGATE F~ ;
  145: 
  146:     : F2DUP  FOVER FOVER ;
  147:     : F2DROP FDROP FDROP ;
  148:     
  149:     : FNEARLY=  ( F: X Y -- S: FLAG )
  150:         (
  151:         Leave TRUE if the two floats are nearly equal.  This is a 
  152:         refinement of Dirk Zoller's FEQ to also allow X = Y, including
  153:         both zero, or to allow approximately equality when X and Y are too
  154:         small to satisfy the relative approximation mode in the F~ 
  155:         specification.
  156:         )
  157:         F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN
  158:         F2DUP FREL=     IF F2DROP TRUE EXIT THEN
  159:         FABS= ;
  160: 
  161:     : FCONF= ( R1 R2 -- F )
  162:         EXACT? IF
  163:             FEXACTLY=
  164:         ELSE
  165:             FNEARLY=
  166:         THEN ;
  167: [THEN]
  168: 
  169: HAS-FLOATING-STACK [IF]
  170:     VARIABLE ACTUAL-FDEPTH
  171:     CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
  172:     VARIABLE START-FDEPTH
  173:     VARIABLE FCURSOR
  174: 
  175:     : EMPTY-FSTACK ( ... -- ... )
  176:         FDEPTH START-FDEPTH @ < IF
  177:             FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
  178:         THEN
  179:         FDEPTH START-FDEPTH @ > IF
  180:             FDEPTH START-FDEPTH @ DO FDROP LOOP
  181:         THEN ;
  182: 
  183:     : F{ ( -- )
  184:         FDEPTH START-FDEPTH ! 0 FCURSOR ! ;
  185: 
  186:     : F-> ( ... -- ... )
  187:         FDEPTH DUP ACTUAL-FDEPTH !
  188:         START-FDEPTH @ > IF
  189:             FDEPTH START-FDEPTH @ - 0 DO ACTUAL-FRESULTS I FLOATS + F! LOOP
  190:         THEN ;
  191: 
  192:     : F} ( ... -- ... )
  193:         FDEPTH ACTUAL-FDEPTH @ = IF
  194:             FDEPTH START-FDEPTH @ > IF
  195:                 FDEPTH START-FDEPTH @ - 0 DO
  196:                     ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF
  197:                         S" INCORRECT FP RESULT: " ERROR LEAVE
  198:                     THEN
  199:                 LOOP
  200:             THEN
  201:         ELSE
  202:             S" WRONG NUMBER OF FP RESULTS: " ERROR
  203:         THEN ;
  204: 
  205:     : F...}T ( -- )
  206:         FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF
  207:             S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR
  208:         ELSE FDEPTH START-FDEPTH @ = 0= IF
  209:             S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
  210:         THEN THEN ;
  211: 
  212:     
  213:     : FTESTER ( R -- )
  214:         FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ START-FDEPTH @ + 1+ < OR IF
  215:             S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR 
  216:         ELSE ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
  217:             S" INCORRECT FP RESULT: " ERROR
  218:         THEN THEN
  219:         1 FCURSOR +! ;
  220:         
  221: [ELSE]
  222:     : EMPTY-FSTACK ;
  223:     : F{ ;
  224:     : F-> ;
  225:     : F} ;
  226:     : F...}T ;
  227: 
  228:     HAS-FLOATING [IF]
  229:     DECIMAL
  230:     : COMPUTE-CELLS-PER-FP ( -- U )
  231:         DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ;
  232:     HEX
  233: 
  234:     COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP
  235: 
  236:     : FTESTER ( R -- )
  237:         DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + CELLS-PER-FP + < OR IF
  238:             S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
  239:         ELSE ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
  240:             S" INCORRECT FP RESULT: " ERROR
  241:         THEN THEN
  242:         CELLS-PER-FP XCURSOR +! ;
  243:     [THEN]
  244: [THEN]    
  245: 
  246: : EMPTY-STACK	\ ( ... -- ) empty stack; handles underflowed stack too.
  247:     DEPTH START-DEPTH @ < IF
  248:         DEPTH START-DEPTH @ SWAP DO 0 LOOP
  249:     THEN
  250:     DEPTH START-DEPTH @ > IF
  251:         DEPTH START-DEPTH @ DO DROP LOOP
  252:     THEN
  253:     EMPTY-FSTACK ;
  254: 
  255: : ERROR1	\ ( C-ADDR U -- ) display an error message 
  256: 		\ followed by the line that had the error.
  257:    TYPE SOURCE TYPE CR			\ display line corresponding to error
  258:    EMPTY-STACK				\ throw away everything else
  259: ;
  260: 
  261: ' ERROR1 ERROR-XT !
  262: 
  263: : T{		\ ( -- ) syntactic sugar.
  264:    DEPTH START-DEPTH ! 0 XCURSOR ! F{ ;
  265: 
  266: : ->		\ ( ... -- ) record depth and contents of stack.
  267:    DEPTH DUP ACTUAL-DEPTH !		\ record depth
  268:    START-DEPTH @ > IF		\ if there is something on the stack
  269:        DEPTH START-DEPTH @ - 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ save them
  270:    THEN
  271:    F-> ;
  272: 
  273: : }T		\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
  274: 		\ (ACTUAL) CONTENTS.
  275:    DEPTH ACTUAL-DEPTH @ = IF		\ if depths match
  276:       DEPTH START-DEPTH @ > IF		\ if there is something on the stack
  277:          DEPTH START-DEPTH @ - 0 DO	\ for each stack item
  278: 	    ACTUAL-RESULTS I CELLS + @	\ compare actual with expected
  279: 	    <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
  280: 	 LOOP
  281:       THEN
  282:    ELSE					\ depth mismatch
  283:       S" WRONG NUMBER OF RESULTS: " ERROR
  284:    THEN
  285:    F} ;
  286: 
  287: : ...}T ( -- )
  288:     XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF
  289:         S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR
  290:     ELSE DEPTH START-DEPTH @ = 0= IF
  291:         S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
  292:     THEN THEN
  293:     F...}T ;
  294: 
  295: : XTESTER ( X -- )
  296:     DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF
  297:         S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
  298:     ELSE ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF
  299:         S" INCORRECT CELL RESULT: " ERROR
  300:     THEN THEN
  301:     1 XCURSOR +! ;
  302: 
  303: : X}T XTESTER ...}T ;
  304: : XX}T XTESTER XTESTER ...}T ;
  305: : XXX}T XTESTER XTESTER XTESTER ...}T ;
  306: : XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ;
  307: 
  308: HAS-FLOATING [IF]
  309: : R}T FTESTER ...}T ;
  310: : XR}T FTESTER XTESTER ...}T ;
  311: : RX}T XTESTER FTESTER ...}T ;
  312: : RR}T FTESTER FTESTER ...}T ;
  313: : XXR}T FTESTER XTESTER XTESTER ...}T ;
  314: : XRX}T XTESTER FTESTER XTESTER ...}T ;
  315: : XRR}T FTESTER FTESTER XTESTER ...}T ;
  316: : RXX}T XTESTER XTESTER FTESTER ...}T ;
  317: : RXR}T FTESTER XTESTER FTESTER ...}T ;
  318: : RRX}T XTESTER FTESTER FTESTER ...}T ;
  319: : RRR}T FTESTER FTESTER FTESTER ...}T ;
  320: : XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ;
  321: : XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ;
  322: : XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ;
  323: : XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ;
  324: : XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ;
  325: : XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ;
  326: : XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ;
  327: : RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ;
  328: : RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ;
  329: : RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ;
  330: : RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ;
  331: : RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ;
  332: : RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ;
  333: : RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ;
  334: : RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ;
  335: [THEN]
  336: 
  337: \ Set the following flag to TRUE for more verbose output; this may
  338: \ allow you to tell which test caused your system to hang.
  339: VARIABLE VERBOSE
  340:    FALSE VERBOSE !
  341: 
  342: : TESTING	\ ( -- ) TALKING COMMENT.
  343:    SOURCE VERBOSE @
  344:    IF DUP >R TYPE CR R> >IN !
  345:    ELSE >IN ! DROP
  346:    THEN ;
  347: 
  348: BASE !
  349: \ end of ttester.fs

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