Return to ttester.fs CVS log

Up to [gforth] / gforth / test

split test/ttester.fs off from test/tester.fs.
added support for ftester-style approximate matching.
added support for approximate matching on shared-stack systems (RXRX}T etc.).

    1: \ From: John Hayes S1I
    2: \ Subject: tester.fr
    3: \ Date: Mon, 27 Nov 95 13:10:09 PST  
    4: 
    5: \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
    6: \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
    7: \ VERSION 1.1
    8: 
    9: \ revised by Anton Ertl 2007-08-12, 2007-08-19
   10: \ The original has the following shortcomings:
   11: 
   12: \ - It does not work as expected if the stack is non-empty before the {.
   13: 
   14: \ - It does not check FP results if the system has a separate FP stack.
   15: 
   16: \ - There is a conflict with the use of } for FSL arrays and { for locals.
   17: 
   18: \ I have revised it to address these shortcomings.  You can find the
   19: \ result at
   20: 
   21: \ http://www.forth200x.org/tests/tester.fs
   22: \ http://www.forth200x.org/tests/ttester.fs
   23: 
   24: \ tester.fs is intended to be a drop-in replacement of the original.
   25: \ ttester.fs is a version that uses T{ and }T instead of { and }.
   26: 
   27: \ In spirit of the original, I have strived to avoid any potential
   28: \ non-portabilities and stayed as much within the CORE words as
   29: \ possible; e.g., FLOATING words are used only if the FLOATING wordset
   30: \ is present
   31: 
   32: \ There are a few things to be noted:
   33: 
   34: \ - Following the despicable practice of the original, this version
   35: \ sets the base to HEX for everything that gets loaded later.
   36: \ Floating-point input is ambiguous when the base is not decimal, so
   37: \ you have to set it to decimal yourself when you want to deal with
   38: \ decimal numbers.
   39: 
   40: \ - For FP it is often useful to use approximate equality for checking
   41: \ the results.  You can turn on approximate matching with SET-NEAR
   42: \ (and turn it off (default) with SET-EXACT, and you can tune it by
   43: \ setting the variables REL-NEAR and ABS-NEAR.  If you want your tests
   44: \ to work with a shared stack, you have to specify the types of the
   45: \ elements on the stack by using one of the closing words that specify
   46: \ types, e.g. RRRX}T for checking the stack picture ( r r r x ).
   47: \ There are such words for all combination of R and X with up to 4
   48: \ stack items, and defining more if you need them is straightforward
   49: \ (see source).  If your tests are only intended for a separate-stack
   50: \ system or if you need only exact matching, you can use the plain }T
   51: \ instead.
   52: 
   53: HEX
   54: 
   55: \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
   56: \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
   57: VARIABLE VERBOSE
   58:    FALSE VERBOSE !
   59: 
   60: VARIABLE ACTUAL-DEPTH			\ STACK RECORD
   61: CREATE ACTUAL-RESULTS 20 CELLS ALLOT
   62: VARIABLE START-DEPTH
   63: VARIABLE XCURSOR \ FOR ...}T
   64: VARIABLE ERROR-XT
   65: 
   66: : ERROR ERROR-XT @ EXECUTE ;
   67: 
   68: : "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE
   69: : "FLOATING-STACK" S" FLOATING-STACK" ;
   70: "FLOATING" ENVIRONMENT? [IF]
   71:     [IF]
   72:         TRUE
   73:     [ELSE]
   74:         FALSE
   75:     [THEN]
   76: [ELSE]
   77:     FALSE
   78: [THEN] CONSTANT HAS-FLOATING
   79: "FLOATING-STACK" ENVIRONMENT? [IF]
   80:     [IF]
   81:         TRUE
   82:     [ELSE]
   83:         FALSE
   84:     [THEN]
   85: [ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE
   86:     HAS-FLOATING \ IF WE HAVE FLOATING, WE ASSUME IT IS
   87: [THEN] CONSTANT HAS-FLOATING-STACK
   88: 
   89: HAS-FLOATING [IF]
   90:     \ SET THE FOLLOWING TO THE RELATIVE AND ABSOLUTE TOLERANCES YOU
   91:     \ WANT FOR APPROXIMATE FLOAT EQUALITY, TO BE USED WITH F~ IN
   92:     \ FNEARLY=.  KEEP THE SIGNS, BECAUSE F~ NEEDS THEM.
   93:     FVARIABLE FSENSITIVITY DECIMAL 1E-12 HEX FSENSITIVITY F!
   94:     : REL-NEAR FSENSITIVITY ;
   95:     FVARIABLE ABS-NEAR    DECIMAL 0E HEX ABS-NEAR F!
   96: 
   97:     \ WHEN EXACT? IS TRUE, }F USES FEXACTLY=, OTHERWISE FNEARLY=.
   98:     
   99:     TRUE VALUE EXACT?
  100:     : SET-EXACT  ( -- )   TRUE TO EXACT? ;
  101:     : SET-NEAR   ( -- )  FALSE TO EXACT? ;
  102: 
  103:     DECIMAL
  104:     : FEXACTLY=  ( F: X Y -- S: FLAG )
  105:         (
  106:         LEAVE TRUE IF THE TWO FLOATS ARE IDENTICAL.
  107:         )
  108:         0E F~ ;
  109:     HEX
  110:     
  111:     : FABS=  ( F: X Y -- S: FLAG )
  112:         (
  113:         LEAVE TRUE IF THE TWO FLOATS ARE EQUAL WITHIN THE TOLERANCE
  114:         STORED IN ABS-NEAR.
  115:         )
  116:         ABS-NEAR F@ F~ ;
  117:     
  118:     : FREL=  ( F: X Y -- S: FLAG )
  119:         (
  120:         LEAVE TRUE IF THE TWO FLOATS ARE RELATIVELY EQUAL BASED ON THE
  121:         TOLERANCE STORED IN ABS-NEAR.
  122:         )
  123:         REL-NEAR F@ FNEGATE F~ ;
  124: 
  125:     : F2DUP  FOVER FOVER ;
  126:     : F2DROP FDROP FDROP ;
  127:     
  128:     : FNEARLY=  ( F: X Y -- S: FLAG )
  129:         (
  130:         LEAVE TRUE IF THE TWO FLOATS ARE NEARLY EQUAL.  THIS IS A
  131:         REFINEMENT OF DIRK ZOLLER'S FEQ TO ALSO ALLOW X = Y, INCLUDING
  132:         BOTH ZERO, OR TO ALLOW APPROXIMATE EQUALITY WHEN X AND Y ARE TOO
  133:         SMALL TO SATISFY THE RELATIVE APPROXIMATION MODE IN THE F~
  134:         SPECIFICATION.
  135:         )
  136:         F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN
  137:         F2DUP FREL=     IF F2DROP TRUE EXIT THEN
  138:         FABS= ;
  139: 
  140:     : FCONF= ( R1 R2 -- F )
  141:         EXACT? IF
  142:             FEXACTLY=
  143:         ELSE
  144:             FNEARLY=
  145:         THEN ;
  146: [THEN]
  147: 
  148: HAS-FLOATING-STACK [IF]
  149:     VARIABLE ACTUAL-FDEPTH
  150:     CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
  151:     VARIABLE START-FDEPTH
  152:     VARIABLE FCURSOR
  153: 
  154:     : EMPTY-FSTACK ( ... -- ... )
  155:         FDEPTH START-FDEPTH @ < IF
  156:             FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
  157:         THEN
  158:         FDEPTH START-FDEPTH @ > IF
  159:             FDEPTH START-FDEPTH @ DO FDROP LOOP
  160:         THEN ;
  161: 
  162:     : F{ ( -- )
  163:         FDEPTH START-FDEPTH ! 0 FCURSOR ! ;
  164: 
  165:     : F-> ( ... -- ... )
  166:         FDEPTH DUP ACTUAL-FDEPTH !
  167:         START-FDEPTH @ > IF
  168:             FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F! LOOP
  169:         THEN ;
  170: 
  171:     : F} ( ... -- ... )
  172:         FDEPTH ACTUAL-FDEPTH @ = IF
  173:             FDEPTH START-FDEPTH @ > IF
  174:                 FDEPTH START-FDEPTH @ DO
  175:                     ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF
  176:                         S" INCORRECT FP RESULT: " ERROR LEAVE
  177:                     THEN
  178:                 LOOP
  179:             THEN
  180:         ELSE
  181:             S" WRONG NUMBER OF FP RESULTS: " ERROR
  182:         THEN ;
  183: 
  184:     : F...}T ( -- )
  185:         FDEPTH START-FDEPTH @ = 0= IF
  186:             S" WRONG NUMBER OF FP RESULTS" ERROR
  187:         THEN
  188:         FCURSOR @ ACTUAL-FDEPTH @ <> IF
  189:             S" WRONG NUMBER OF FP RESULTS" ERROR
  190:         THEN ;
  191:     
  192:     : FTESTER ( R -- )
  193:         FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ 1+ < OR IF
  194:             S" WRONG NUMBER OF FP RESULTS: " ERROR EXIT
  195:         THEN
  196:         ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
  197:             S" INCORRECT FP RESULT: " ERROR
  198:         THEN
  199:         1 FCURSOR +! ;
  200:         
  201: [ELSE]
  202:     : EMPTY-FSTACK ;
  203:     : F{ ;
  204:     : F-> ;
  205:     : F} ;
  206:     : F...}T ;
  207: 
  208:     : COMPUTE-CELLS-PER-FP ( -- U )
  209:         DEPTH 0E DEPTH >R FDROP R> SWAP - ;
  210: 
  211:     COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP
  212:     
  213:     : FTESTER ( R -- )
  214:         DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ CELLS-PER-FP + < OR IF
  215:             S" WRONG NUMBER OF RESULTS: " ERROR EXIT
  216:         THEN
  217:         ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
  218:             S" INCORRECT FP RESULT: " ERROR
  219:         THEN
  220:         CELLS-PER-FP XCURSOR +! ;
  221:  [THEN]    
  222: 
  223: : EMPTY-STACK	\ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
  224:     DEPTH START-DEPTH @ < IF
  225:         DEPTH START-DEPTH @ SWAP DO 0 LOOP
  226:     THEN
  227:     DEPTH START-DEPTH @ > IF
  228:         DEPTH START-DEPTH @ DO DROP LOOP
  229:     THEN
  230:     EMPTY-FSTACK ;
  231: 
  232: : ERROR1	\ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
  233: 		\ THE LINE THAT HAD THE ERROR.
  234:    TYPE SOURCE TYPE CR			\ DISPLAY LINE CORRESPONDING TO ERROR
  235:    EMPTY-STACK				\ THROW AWAY EVERY THING ELSE
  236: ;
  237: 
  238: ' ERROR1 ERROR-XT !
  239: 
  240: : T{		\ ( -- ) SYNTACTIC SUGAR.
  241:    DEPTH START-DEPTH ! F{ ;
  242: 
  243: : ->		\ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
  244:    DEPTH DUP ACTUAL-DEPTH !		\ RECORD DEPTH
  245:    START-DEPTH @ > IF		\ IF THERE IS SOMETHING ON STACK
  246:        DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
  247:    THEN
  248:    F-> ;
  249: 
  250: : }T		\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
  251: 		\ (ACTUAL) CONTENTS.
  252:    DEPTH ACTUAL-DEPTH @ = IF		\ IF DEPTHS MATCH
  253:       DEPTH START-DEPTH @ > IF		\ IF THERE IS SOMETHING ON THE STACK
  254:          DEPTH START-DEPTH @ DO		\ FOR EACH STACK ITEM
  255: 	    ACTUAL-RESULTS I CELLS + @	\ COMPARE ACTUAL WITH EXPECTED
  256: 	    <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
  257: 	 LOOP
  258:       THEN
  259:    ELSE					\ DEPTH MISMATCH
  260:       S" WRONG NUMBER OF RESULTS: " ERROR
  261:    THEN
  262:    F} ;
  263: 
  264: : ...}T ( -- )
  265:     DEPTH START-DEPTH @ = 0= IF
  266:         S" WRONG NUMBER OF RESULTS" ERROR
  267:     THEN
  268:     XCURSOR @ ACTUAL-DEPTH @ <> IF
  269:         S" WRONG NUMBER OF RESULTS" ERROR
  270:     THEN
  271:     F...}T ;
  272: 
  273: : XTESTER ( X -- )
  274:     DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ 1+ < OR IF
  275:         S" WRONG NUMBER OF RESULTS: " ERROR EXIT
  276:     THEN
  277:     ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF
  278:         S" INCORRECT CELL RESULT: " ERROR
  279:     THEN
  280:     1 XCURSOR +! ;
  281: 
  282: : X}T XTESTER ...}T ;
  283: : R}T FTESTER ...}T ;
  284: : XX}T XTESTER XTESTER ...}T ;
  285: : XR}T FTESTER XTESTER ...}T ;
  286: : RX}T XTESTER FTESTER ...}T ;
  287: : RR}T FTESTER FTESTER ...}T ;
  288: : XXX}T XTESTER XTESTER XTESTER ...}T ;
  289: : XXR}T FTESTER XTESTER XTESTER ...}T ;
  290: : XRX}T XTESTER FTESTER XTESTER ...}T ;
  291: : XRR}T FTESTER FTESTER XTESTER ...}T ;
  292: : RXX}T XTESTER XTESTER FTESTER ...}T ;
  293: : RXR}T FTESTER XTESTER FTESTER ...}T ;
  294: : RRX}T XTESTER FTESTER FTESTER ...}T ;
  295: : RRR}T FTESTER FTESTER FTESTER ...}T ;
  296: : XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ;
  297: : XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ;
  298: : XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ;
  299: : XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ;
  300: : XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ;
  301: : XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ;
  302: : XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ;
  303: : XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ;
  304: : RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ;
  305: : RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ;
  306: : RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ;
  307: : RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ;
  308: : RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ;
  309: : RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ;
  310: : RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ;
  311: : RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ;
  312: 
  313: : TESTING	\ ( -- ) TALKING COMMENT.
  314:    SOURCE VERBOSE @
  315:    IF DUP >R TYPE CR R> >IN !
  316:    ELSE >IN ! DROP
  317:    THEN ;