File:  [gforth] / gforth / test / ttester.fs
Revision 1.6: download - view: text, annotated - select for diffs
Fri Oct 26 12:47:41 2007 UTC (9 years, 11 months ago) by anton
Branches: MAIN
CVS tags: HEAD
ttester bugfix: ...}T now handles non-empty start-depths

    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 2007-08-12, 2007-08-19, 2007-08-28
   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: \ TESTER.FS IS INTENDED TO BE A DROP-IN REPLACEMENT OF THE ORIGINAL.
   33: 
   34: \ TTESTER.FS IS A VERSION THAT USES T{ AND }T INSTEAD OF { AND } AND
   35: \ KEEPS THE BASE AS IT WAS BEFORE LOADING TTESTER.FS
   36: 
   37: \ IN SPIRIT OF THE ORIGINAL, I HAVE STRIVED TO AVOID ANY POTENTIAL
   38: \ NON-PORTABILITIES AND STAYED AS MUCH WITHIN THE CORE WORDS AS
   39: \ POSSIBLE; E.G., FLOATING WORDS ARE USED ONLY IF THE FLOATING WORDSET
   40: \ IS PRESENT
   41: 
   42: \ THERE ARE A FEW THINGS TO BE NOTED:
   43: 
   44: \ - LOADING TTESTER.FS DOES NOT CHANGE BASE.  LOADING TESTER.FS
   45: \ CHANGES BASE TO HEX (LIKE THE ORIGINAL TESTER).  FLOATING-POINT
   46: \ INPUT IS AMBIGUOUS WHEN THE BASE IS NOT DECIMAL, SO YOU HAVE TO SET
   47: \ IT TO DECIMAL YOURSELF WHEN YOU WANT TO DEAL WITH DECIMAL NUMBERS.
   48: 
   49: \ - FOR FP IT IS OFTEN USEFUL TO USE APPROXIMATE EQUALITY FOR CHECKING
   50: \ THE RESULTS.  YOU CAN TURN ON APPROXIMATE MATCHING WITH SET-NEAR
   51: \ (AND TURN IT OFF (DEFAULT) WITH SET-EXACT, AND YOU CAN TUNE IT BY
   52: \ SETTING THE VARIABLES REL-NEAR AND ABS-NEAR.  IF YOU WANT YOUR TESTS
   53: \ TO WORK WITH A SHARED STACK, YOU HAVE TO SPECIFY THE TYPES OF THE
   54: \ ELEMENTS ON THE STACK BY USING ONE OF THE CLOSING WORDS THAT SPECIFY
   55: \ TYPES, E.G. RRRX}T FOR CHECKING THE STACK PICTURE ( R R R X ).
   56: \ THERE ARE SUCH WORDS FOR ALL COMBINATION OF R AND X WITH UP TO 4
   57: \ STACK ITEMS, AND DEFINING MORE IF YOU NEED THEM IS STRAIGHTFORWARD
   58: \ (SEE SOURCE).  IF YOUR TESTS ARE ONLY INTENDED FOR A SEPARATE-STACK
   59: \ SYSTEM OR IF YOU NEED ONLY EXACT MATCHING, YOU CAN USE THE PLAIN }T
   60: \ INSTEAD.
   61: 
   62: BASE @
   63: HEX
   64: 
   65: \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
   66: \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
   67: VARIABLE VERBOSE
   68:    FALSE VERBOSE !
   69: 
   70: VARIABLE ACTUAL-DEPTH			\ STACK RECORD
   71: CREATE ACTUAL-RESULTS 20 CELLS ALLOT
   72: VARIABLE START-DEPTH
   73: VARIABLE XCURSOR \ FOR ...}T
   74: VARIABLE ERROR-XT
   75: 
   76: : ERROR ERROR-XT @ EXECUTE ;
   77: 
   78: : "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE
   79: : "FLOATING-STACK" S" FLOATING-STACK" ;
   80: "FLOATING" ENVIRONMENT? [IF]
   81:     [IF]
   82:         TRUE
   83:     [ELSE]
   84:         FALSE
   85:     [THEN]
   86: [ELSE]
   87:     FALSE
   88: [THEN] CONSTANT HAS-FLOATING
   89: "FLOATING-STACK" ENVIRONMENT? [IF]
   90:     [IF]
   91:         TRUE
   92:     [ELSE]
   93:         FALSE
   94:     [THEN]
   95: [ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE
   96:     HAS-FLOATING \ IF WE HAVE FLOATING, WE ASSUME IT IS
   97: [THEN] CONSTANT HAS-FLOATING-STACK
   98: 
   99: HAS-FLOATING [IF]
  100:     \ SET THE FOLLOWING TO THE RELATIVE AND ABSOLUTE TOLERANCES YOU
  101:     \ WANT FOR APPROXIMATE FLOAT EQUALITY, TO BE USED WITH F~ IN
  102:     \ FNEARLY=.  KEEP THE SIGNS, BECAUSE F~ NEEDS THEM.
  103:     FVARIABLE REL-NEAR DECIMAL 1E-12 HEX REL-NEAR F!
  104:     FVARIABLE ABS-NEAR    DECIMAL 0E HEX ABS-NEAR F!
  105: 
  106:     \ WHEN EXACT? IS TRUE, }F USES FEXACTLY=, OTHERWISE FNEARLY=.
  107:     
  108:     TRUE VALUE EXACT?
  109:     : SET-EXACT  ( -- )   TRUE TO EXACT? ;
  110:     : SET-NEAR   ( -- )  FALSE TO EXACT? ;
  111: 
  112:     DECIMAL
  113:     : FEXACTLY=  ( F: X Y -- S: FLAG )
  114:         (
  115:         LEAVE TRUE IF THE TWO FLOATS ARE IDENTICAL.
  116:         )
  117:         0E F~ ;
  118:     HEX
  119:     
  120:     : FABS=  ( F: X Y -- S: FLAG )
  121:         (
  122:         LEAVE TRUE IF THE TWO FLOATS ARE EQUAL WITHIN THE TOLERANCE
  123:         STORED IN ABS-NEAR.
  124:         )
  125:         ABS-NEAR F@ F~ ;
  126:     
  127:     : FREL=  ( F: X Y -- S: FLAG )
  128:         (
  129:         LEAVE TRUE IF THE TWO FLOATS ARE RELATIVELY EQUAL BASED ON THE
  130:         TOLERANCE STORED IN ABS-NEAR.
  131:         )
  132:         REL-NEAR F@ FNEGATE F~ ;
  133: 
  134:     : F2DUP  FOVER FOVER ;
  135:     : F2DROP FDROP FDROP ;
  136:     
  137:     : FNEARLY=  ( F: X Y -- S: FLAG )
  138:         (
  139:         LEAVE TRUE IF THE TWO FLOATS ARE NEARLY EQUAL.  THIS IS A
  140:         REFINEMENT OF DIRK ZOLLER'S FEQ TO ALSO ALLOW X = Y, INCLUDING
  141:         BOTH ZERO, OR TO ALLOW APPROXIMATE EQUALITY WHEN X AND Y ARE TOO
  142:         SMALL TO SATISFY THE RELATIVE APPROXIMATION MODE IN THE F~
  143:         SPECIFICATION.
  144:         )
  145:         F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN
  146:         F2DUP FREL=     IF F2DROP TRUE EXIT THEN
  147:         FABS= ;
  148: 
  149:     : FCONF= ( R1 R2 -- F )
  150:         EXACT? IF
  151:             FEXACTLY=
  152:         ELSE
  153:             FNEARLY=
  154:         THEN ;
  155: [THEN]
  156: 
  157: HAS-FLOATING-STACK [IF]
  158:     VARIABLE ACTUAL-FDEPTH
  159:     CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
  160:     VARIABLE START-FDEPTH
  161:     VARIABLE FCURSOR
  162: 
  163:     : EMPTY-FSTACK ( ... -- ... )
  164:         FDEPTH START-FDEPTH @ < IF
  165:             FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
  166:         THEN
  167:         FDEPTH START-FDEPTH @ > IF
  168:             FDEPTH START-FDEPTH @ DO FDROP LOOP
  169:         THEN ;
  170: 
  171:     : F{ ( -- )
  172:         FDEPTH START-FDEPTH ! 0 FCURSOR ! ;
  173: 
  174:     : F-> ( ... -- ... )
  175:         FDEPTH DUP ACTUAL-FDEPTH !
  176:         START-FDEPTH @ > IF
  177:             FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F! LOOP
  178:         THEN ;
  179: 
  180:     : F} ( ... -- ... )
  181:         FDEPTH ACTUAL-FDEPTH @ = IF
  182:             FDEPTH START-FDEPTH @ > IF
  183:                 FDEPTH START-FDEPTH @ DO
  184:                     ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF
  185:                         S" INCORRECT FP RESULT: " ERROR LEAVE
  186:                     THEN
  187:                 LOOP
  188:             THEN
  189:         ELSE
  190:             S" WRONG NUMBER OF FP RESULTS: " ERROR
  191:         THEN ;
  192: 
  193:     : F...}T ( -- )
  194:         FDEPTH START-FDEPTH @ = 0= IF
  195:             S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
  196:         THEN
  197:         FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF
  198:             S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPRECIFICATION: " ERROR
  199:         THEN ;
  200:     
  201:     : FTESTER ( R -- )
  202:         FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ START-FDEPTH @ + 1+ < OR IF
  203:             S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
  204:         THEN
  205:         ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
  206:             S" INCORRECT FP RESULT: " ERROR
  207:         THEN
  208:         1 FCURSOR +! ;
  209:         
  210: [ELSE]
  211:     : EMPTY-FSTACK ;
  212:     : F{ ;
  213:     : F-> ;
  214:     : F} ;
  215:     : F...}T ;
  216: 
  217:     DECIMAL
  218:     : COMPUTE-CELLS-PER-FP ( -- U )
  219:         DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ;
  220:     HEX
  221: 
  222:     COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP
  223:     
  224:     : FTESTER ( R -- )
  225:         DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + CELLS-PER-FP + < OR IF
  226:             S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
  227:         THEN
  228:         ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
  229:             S" INCORRECT FP RESULT: " ERROR
  230:         THEN
  231:         CELLS-PER-FP XCURSOR +! ;
  232:  [THEN]    
  233: 
  234: : EMPTY-STACK	\ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
  235:     DEPTH START-DEPTH @ < IF
  236:         DEPTH START-DEPTH @ SWAP DO 0 LOOP
  237:     THEN
  238:     DEPTH START-DEPTH @ > IF
  239:         DEPTH START-DEPTH @ DO DROP LOOP
  240:     THEN
  241:     EMPTY-FSTACK ;
  242: 
  243: : ERROR1	\ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
  244: 		\ THE LINE THAT HAD THE ERROR.
  245:    TYPE SOURCE TYPE CR			\ DISPLAY LINE CORRESPONDING TO ERROR
  246:    EMPTY-STACK				\ THROW AWAY EVERY THING ELSE
  247: ;
  248: 
  249: ' ERROR1 ERROR-XT !
  250: 
  251: : T{		\ ( -- ) SYNTACTIC SUGAR.
  252:    DEPTH START-DEPTH ! 0 XCURSOR ! F{ ;
  253: 
  254: : ->		\ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
  255:    DEPTH DUP ACTUAL-DEPTH !		\ RECORD DEPTH
  256:    START-DEPTH @ > IF		\ IF THERE IS SOMETHING ON STACK
  257:        DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
  258:    THEN
  259:    F-> ;
  260: 
  261: : }T		\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
  262: 		\ (ACTUAL) CONTENTS.
  263:    DEPTH ACTUAL-DEPTH @ = IF		\ IF DEPTHS MATCH
  264:       DEPTH START-DEPTH @ > IF		\ IF THERE IS SOMETHING ON THE STACK
  265:          DEPTH START-DEPTH @ DO		\ FOR EACH STACK ITEM
  266: 	    ACTUAL-RESULTS I CELLS + @	\ COMPARE ACTUAL WITH EXPECTED
  267: 	    <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
  268: 	 LOOP
  269:       THEN
  270:    ELSE					\ DEPTH MISMATCH
  271:       S" WRONG NUMBER OF RESULTS: " ERROR
  272:    THEN
  273:    F} ;
  274: 
  275: : ...}T ( -- )
  276:     DEPTH START-DEPTH @ = 0= IF
  277:         S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
  278:     THEN
  279:     XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF
  280:         S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPRECIFICATION: " ERROR
  281:     THEN
  282:     F...}T ;
  283: 
  284: : XTESTER ( X -- )
  285:     DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF
  286:         S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
  287:     THEN
  288:     ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF
  289:         S" INCORRECT CELL RESULT: " ERROR
  290:     THEN
  291:     1 XCURSOR +! ;
  292: 
  293: : X}T XTESTER ...}T ;
  294: : R}T FTESTER ...}T ;
  295: : XX}T XTESTER XTESTER ...}T ;
  296: : XR}T FTESTER XTESTER ...}T ;
  297: : RX}T XTESTER FTESTER ...}T ;
  298: : RR}T FTESTER FTESTER ...}T ;
  299: : XXX}T XTESTER XTESTER XTESTER ...}T ;
  300: : XXR}T FTESTER XTESTER XTESTER ...}T ;
  301: : XRX}T XTESTER FTESTER XTESTER ...}T ;
  302: : XRR}T FTESTER FTESTER XTESTER ...}T ;
  303: : RXX}T XTESTER XTESTER FTESTER ...}T ;
  304: : RXR}T FTESTER XTESTER FTESTER ...}T ;
  305: : RRX}T XTESTER FTESTER FTESTER ...}T ;
  306: : RRR}T FTESTER FTESTER FTESTER ...}T ;
  307: : XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ;
  308: : XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ;
  309: : XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ;
  310: : XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ;
  311: : XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ;
  312: : XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ;
  313: : XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ;
  314: : XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ;
  315: : RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ;
  316: : RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ;
  317: : RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ;
  318: : RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ;
  319: : RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ;
  320: : RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ;
  321: : RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ;
  322: : RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ;
  323: 
  324: : TESTING	\ ( -- ) TALKING COMMENT.
  325:    SOURCE VERBOSE @
  326:    IF DUP >R TYPE CR R> >IN !
  327:    ELSE >IN ! DROP
  328:    THEN ;
  329: 
  330: BASE !

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