File:  [gforth] / gforth / test / ttester.fs
Revision 1.3: download - view: text, annotated - select for diffs
Wed Aug 22 06:34:52 2007 UTC (10 years, 2 months ago) by anton
Branches: MAIN
CVS tags: HEAD
bugfixes

    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
   11: \ approximate equality in Dirk Zoller's float.4th
   12: 
   13: \ This library is free software; you can redistribute it and/or
   14: \ modify it under the terms of the GNU Lesser General Public
   15: \ License as published by the Free Software Foundation; either
   16: \ version 2.1 of the License, or at your option any later version.
   17: 
   18: \ This library is distributed in the hope that it will be useful,
   19: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   20: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
   21: \ Lesser General Public License for more details.
   22: 
   23: \ You should have received a copy of the GNU Lesser General Public
   24: \ License along with this library; if not, write to the Free
   25: \ Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
   26: \ MA 02111-1307 USA.
   27: 
   28: \ for the rest:
   29: \ revised by Anton Ertl 2007-08-12, 2007-08-19
   30: \ public domain
   31: 
   32: \ The original has the following shortcomings:
   33: 
   34: \ - It does not work as expected if the stack is non-empty before the {.
   35: 
   36: \ - It does not check FP results if the system has a separate FP stack.
   37: 
   38: \ - There is a conflict with the use of } for FSL arrays and { for locals.
   39: 
   40: \ I have revised it to address these shortcomings.  You can find the
   41: \ result at
   42: 
   43: \ http://www.forth200x.org/tests/tester.fs
   44: \ http://www.forth200x.org/tests/ttester.fs
   45: 
   46: \ tester.fs is intended to be a drop-in replacement of the original.
   47: \ ttester.fs is a version that uses T{ and }T instead of { and }.
   48: 
   49: \ In spirit of the original, I have strived to avoid any potential
   50: \ non-portabilities and stayed as much within the CORE words as
   51: \ possible; e.g., FLOATING words are used only if the FLOATING wordset
   52: \ is present
   53: 
   54: \ There are a few things to be noted:
   55: 
   56: \ - Following the despicable practice of the original, this version
   57: \ sets the base to HEX for everything that gets loaded later.
   58: \ Floating-point input is ambiguous when the base is not decimal, so
   59: \ you have to set it to decimal yourself when you want to deal with
   60: \ decimal numbers.
   61: 
   62: \ - For FP it is often useful to use approximate equality for checking
   63: \ the results.  You can turn on approximate matching with SET-NEAR
   64: \ (and turn it off (default) with SET-EXACT, and you can tune it by
   65: \ setting the variables REL-NEAR and ABS-NEAR.  If you want your tests
   66: \ to work with a shared stack, you have to specify the types of the
   67: \ elements on the stack by using one of the closing words that specify
   68: \ types, e.g. RRRX}T for checking the stack picture ( r r r x ).
   69: \ There are such words for all combination of R and X with up to 4
   70: \ stack items, and defining more if you need them is straightforward
   71: \ (see source).  If your tests are only intended for a separate-stack
   72: \ system or if you need only exact matching, you can use the plain }T
   73: \ instead.
   74: 
   75: HEX
   76: 
   77: \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
   78: \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
   79: VARIABLE VERBOSE
   80:    FALSE VERBOSE !
   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 ;
   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 FSENSITIVITY DECIMAL 1E-12 HEX FSENSITIVITY F!
  116:     : REL-NEAR FSENSITIVITY ;
  117:     FVARIABLE ABS-NEAR    DECIMAL 0E HEX ABS-NEAR F!
  118: 
  119:     \ WHEN EXACT? IS TRUE, }F USES FEXACTLY=, OTHERWISE FNEARLY=.
  120:     
  121:     TRUE VALUE EXACT?
  122:     : SET-EXACT  ( -- )   TRUE TO EXACT? ;
  123:     : SET-NEAR   ( -- )  FALSE TO EXACT? ;
  124: 
  125:     DECIMAL
  126:     : FEXACTLY=  ( F: X Y -- S: FLAG )
  127:         (
  128:         LEAVE TRUE IF THE TWO FLOATS ARE IDENTICAL.
  129:         )
  130:         0E F~ ;
  131:     HEX
  132:     
  133:     : FABS=  ( F: X Y -- S: FLAG )
  134:         (
  135:         LEAVE TRUE IF THE TWO FLOATS ARE EQUAL WITHIN THE TOLERANCE
  136:         STORED IN ABS-NEAR.
  137:         )
  138:         ABS-NEAR F@ F~ ;
  139:     
  140:     : FREL=  ( F: X Y -- S: FLAG )
  141:         (
  142:         LEAVE TRUE IF THE TWO FLOATS ARE RELATIVELY EQUAL BASED ON THE
  143:         TOLERANCE STORED IN ABS-NEAR.
  144:         )
  145:         REL-NEAR F@ FNEGATE F~ ;
  146: 
  147:     : F2DUP  FOVER FOVER ;
  148:     : F2DROP FDROP FDROP ;
  149:     
  150:     : FNEARLY=  ( F: X Y -- S: FLAG )
  151:         (
  152:         LEAVE TRUE IF THE TWO FLOATS ARE NEARLY EQUAL.  THIS IS A
  153:         REFINEMENT OF DIRK ZOLLER'S FEQ TO ALSO ALLOW X = Y, INCLUDING
  154:         BOTH ZERO, OR TO ALLOW APPROXIMATE EQUALITY WHEN X AND Y ARE TOO
  155:         SMALL TO SATISFY THE RELATIVE APPROXIMATION MODE IN THE F~
  156:         SPECIFICATION.
  157:         )
  158:         F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN
  159:         F2DUP FREL=     IF F2DROP TRUE EXIT THEN
  160:         FABS= ;
  161: 
  162:     : FCONF= ( R1 R2 -- F )
  163:         EXACT? IF
  164:             FEXACTLY=
  165:         ELSE
  166:             FNEARLY=
  167:         THEN ;
  168: [THEN]
  169: 
  170: HAS-FLOATING-STACK [IF]
  171:     VARIABLE ACTUAL-FDEPTH
  172:     CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
  173:     VARIABLE START-FDEPTH
  174:     VARIABLE FCURSOR
  175: 
  176:     : EMPTY-FSTACK ( ... -- ... )
  177:         FDEPTH START-FDEPTH @ < IF
  178:             FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
  179:         THEN
  180:         FDEPTH START-FDEPTH @ > IF
  181:             FDEPTH START-FDEPTH @ DO FDROP LOOP
  182:         THEN ;
  183: 
  184:     : F{ ( -- )
  185:         FDEPTH START-FDEPTH ! 0 FCURSOR ! ;
  186: 
  187:     : F-> ( ... -- ... )
  188:         FDEPTH DUP ACTUAL-FDEPTH !
  189:         START-FDEPTH @ > IF
  190:             FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F! LOOP
  191:         THEN ;
  192: 
  193:     : F} ( ... -- ... )
  194:         FDEPTH ACTUAL-FDEPTH @ = IF
  195:             FDEPTH START-FDEPTH @ > IF
  196:                 FDEPTH START-FDEPTH @ DO
  197:                     ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF
  198:                         S" INCORRECT FP RESULT: " ERROR LEAVE
  199:                     THEN
  200:                 LOOP
  201:             THEN
  202:         ELSE
  203:             S" WRONG NUMBER OF FP RESULTS: " ERROR
  204:         THEN ;
  205: 
  206:     : F...}T ( -- )
  207:         FDEPTH START-FDEPTH @ = 0= IF
  208:             S" WRONG NUMBER OF FP RESULTS" ERROR
  209:         THEN
  210:         FCURSOR @ ACTUAL-FDEPTH @ <> IF
  211:             S" WRONG NUMBER OF FP RESULTS" ERROR
  212:         THEN ;
  213:     
  214:     : FTESTER ( R -- )
  215:         FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ 1+ < OR IF
  216:             S" WRONG NUMBER OF FP RESULTS: " ERROR EXIT
  217:         THEN
  218:         ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
  219:             S" INCORRECT FP RESULT: " ERROR
  220:         THEN
  221:         1 FCURSOR +! ;
  222:         
  223: [ELSE]
  224:     : EMPTY-FSTACK ;
  225:     : F{ ;
  226:     : F-> ;
  227:     : F} ;
  228:     : F...}T ;
  229: 
  230:     DECIMAL
  231:     : COMPUTE-CELLS-PER-FP ( -- U )
  232:         DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ;
  233:     HEX
  234: 
  235:     COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP
  236:     
  237:     : FTESTER ( R -- )
  238:         DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ CELLS-PER-FP + < OR IF
  239:             S" WRONG NUMBER OF RESULTS: " ERROR EXIT
  240:         THEN
  241:         ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
  242:             S" INCORRECT FP RESULT: " ERROR
  243:         THEN
  244:         CELLS-PER-FP XCURSOR +! ;
  245:  [THEN]    
  246: 
  247: : EMPTY-STACK	\ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
  248:     DEPTH START-DEPTH @ < IF
  249:         DEPTH START-DEPTH @ SWAP DO 0 LOOP
  250:     THEN
  251:     DEPTH START-DEPTH @ > IF
  252:         DEPTH START-DEPTH @ DO DROP LOOP
  253:     THEN
  254:     EMPTY-FSTACK ;
  255: 
  256: : ERROR1	\ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
  257: 		\ THE LINE THAT HAD THE ERROR.
  258:    TYPE SOURCE TYPE CR			\ DISPLAY LINE CORRESPONDING TO ERROR
  259:    EMPTY-STACK				\ THROW AWAY EVERY THING ELSE
  260: ;
  261: 
  262: ' ERROR1 ERROR-XT !
  263: 
  264: : T{		\ ( -- ) SYNTACTIC SUGAR.
  265:    DEPTH START-DEPTH ! 0 XCURSOR ! F{ ;
  266: 
  267: : ->		\ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
  268:    DEPTH DUP ACTUAL-DEPTH !		\ RECORD DEPTH
  269:    START-DEPTH @ > IF		\ IF THERE IS SOMETHING ON STACK
  270:        DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
  271:    THEN
  272:    F-> ;
  273: 
  274: : }T		\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
  275: 		\ (ACTUAL) CONTENTS.
  276:    DEPTH ACTUAL-DEPTH @ = IF		\ IF DEPTHS MATCH
  277:       DEPTH START-DEPTH @ > IF		\ IF THERE IS SOMETHING ON THE STACK
  278:          DEPTH START-DEPTH @ DO		\ FOR EACH STACK ITEM
  279: 	    ACTUAL-RESULTS I CELLS + @	\ COMPARE ACTUAL WITH EXPECTED
  280: 	    <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
  281: 	 LOOP
  282:       THEN
  283:    ELSE					\ DEPTH MISMATCH
  284:       S" WRONG NUMBER OF RESULTS: " ERROR
  285:    THEN
  286:    F} ;
  287: 
  288: : ...}T ( -- )
  289:     DEPTH START-DEPTH @ = 0= IF
  290:         S" WRONG NUMBER OF RESULTS" ERROR
  291:     THEN
  292:     XCURSOR @ ACTUAL-DEPTH @ <> IF
  293:         S" WRONG NUMBER OF RESULTS" ERROR
  294:     THEN
  295:     F...}T ;
  296: 
  297: : XTESTER ( X -- )
  298:     DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ 1+ < OR IF
  299:         S" WRONG NUMBER OF RESULTS: " ERROR EXIT
  300:     THEN
  301:     ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF
  302:         S" INCORRECT CELL RESULT: " ERROR
  303:     THEN
  304:     1 XCURSOR +! ;
  305: 
  306: : X}T XTESTER ...}T ;
  307: : R}T FTESTER ...}T ;
  308: : XX}T XTESTER XTESTER ...}T ;
  309: : XR}T FTESTER XTESTER ...}T ;
  310: : RX}T XTESTER FTESTER ...}T ;
  311: : RR}T FTESTER FTESTER ...}T ;
  312: : XXX}T XTESTER XTESTER XTESTER ...}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: : XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ;
  321: : XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ;
  322: : XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ;
  323: : XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ;
  324: : XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ;
  325: : XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ;
  326: : XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ;
  327: : XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ;
  328: : RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ;
  329: : RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ;
  330: : RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ;
  331: : RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ;
  332: : RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ;
  333: : RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ;
  334: : RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ;
  335: : RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ;
  336: 
  337: : TESTING	\ ( -- ) TALKING COMMENT.
  338:    SOURCE VERBOSE @
  339:    IF DUP >R TYPE CR R> >IN !
  340:    ELSE >IN ! DROP
  341:    THEN ;

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