File:  [gforth] / gforth / test / ttester.fs
Revision 1.13: download - view: text, annotated - select for diffs
Sat Nov 8 18:34:18 2008 UTC (9 years, 1 month ago) by anton
Branches: MAIN
CVS tags: HEAD
updated ttester.fs documentation

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

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