--- gforth/test/ttester.fs 2007/10/26 12:47:41 1.6 +++ gforth/test/ttester.fs 2009/04/08 19:59:17 1.14 @@ -1,81 +1,93 @@ -\ FOR THE ORIGINAL TESTER -\ FROM: JOHN HAYES S1I -\ SUBJECT: TESTER.FR -\ DATE: MON, 27 NOV 95 13:10:09 PST +\ This file contains the code for ttester, a utility for testing Forth words, +\ as developed by several authors (see below), together with some explanations +\ of its use. + +\ ttester is based on the original tester suite by Hayes: +\ From: John Hayes S1I +\ Subject: tester.fr +\ Date: Mon, 27 Nov 95 13:10:09 PST \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. \ VERSION 1.1 +\ All the subsequent changes have been placed in the public domain. +\ The primary changes from the original are the replacement of "{" by "T{" +\ and "}" by "}T" (to avoid conflicts with the uses of { for locals and } +\ for FSL arrays), modifications so that the stack is allowed to be non-empty +\ before T{, and extensions for the handling of floating point tests. +\ Code for testing equality of floating point values comes +\ from ftester.fs written by David N. Williams, based on the idea of +\ approximate equality in Dirk Zoller's float.4th. +\ Further revisions were provided by Anton Ertl, including the ability +\ to handle either integrated or separate floating point stacks. +\ Revision history and possibly newer versions can be found at +\ http://www.complang.tuwien.ac.at/cvsweb/cgi-bin/cvsweb/gforth/test/ttester.fs +\ Explanatory material and minor reformatting (no code changes) by +\ C. G. Montgomery March 2009, with helpful comments from David Williams +\ and Krishna Myneni. + +\ Usage: + +\ The basic usage takes the form T{ -> }T . +\ This executes and compares the resulting stack contents with +\ the values, and reports any discrepancy between the +\ two sets of values. +\ For example: +\ T{ 1 2 3 swap -> 1 3 2 }T ok +\ T{ 1 2 3 swap -> 1 2 2 }T INCORRECT RESULT: T{ 1 2 3 swap -> 1 2 2 }T ok +\ T{ 1 2 3 swap -> 1 2 }T WRONG NUMBER OF RESULTS: T{ 1 2 3 swap -> 1 2 }T ok + +\ Floating point testing can involve further complications. The code +\ attempts to determine whether floating-point support is present, and +\ if so, whether there is a separate floating-point stack, and behave +\ accordingly. The CONSTANTs HAS-FLOATING and HAS-FLOATING-STACK +\ contain the results of its efforts, so the behavior of the code can +\ be modified by the user if necessary. + +\ Then there are the perennial issues of floating point value +\ comparisons. Exact equality is specified by SET-EXACT (the +\ default). If approximate equality tests are desired, execute +\ SET-NEAR . Then the FVARIABLEs REL-NEAR (default 1E-12) and +\ ABS-NEAR (default 0E) contain the values to be used in comparisons +\ by the (internal) word FNEARLY= . + +\ When there is not a separate floating point stack and you want to +\ use approximate equality for FP values, it is necessary to identify +\ which stack items are floating point quantities. This can be done +\ by replacing the closing }T with a version that specifies this, such +\ as RRXR}T which identifies the stack picture ( r r x r ). The code +\ provides such words for all combinations of R and X with up to four +\ stack items. They can be used with either an integrated or separate +\ floating point stacks. Adding more if you need them is +\ straightforward; see the examples in the source. Here is an example +\ which also illustrates controlling the precision of comparisons: + +\ SET-NEAR +\ 1E-6 REL-NEAR F! +\ T{ S" 3.14159E" >FLOAT -> -1E FACOS TRUE RX}T + +\ The word ERROR is now vectored, so that its action can be changed by +\ the user (for example, to add a counter for the number of errors). +\ The default action ERROR1 can be used as a factor in the display of +\ error reports. -\ FOR THE FNEARLY= STUFF: -\ FROM FTESTER.FS WRITTEN BY DAVID N. WILLIAMS, BASED ON THE IDEA OF -\ APPROXIMATE EQUALITY IN DIRK ZOLLER'S FLOAT.4TH -\ PUBLIC DOMAIN - -\ FOR THE REST: -\ REVISED BY ANTON ERTL 2007-08-12, 2007-08-19, 2007-08-28 -\ PUBLIC DOMAIN - -\ THE ORIGINAL HAS THE FOLLOWING SHORTCOMINGS: - -\ - IT DOES NOT WORK AS EXPECTED IF THE STACK IS NON-EMPTY BEFORE THE {. - -\ - IT DOES NOT CHECK FP RESULTS IF THE SYSTEM HAS A SEPARATE FP STACK. - -\ - THERE IS A CONFLICT WITH THE USE OF } FOR FSL ARRAYS AND { FOR LOCALS. - -\ I HAVE REVISED IT TO ADDRESS THESE SHORTCOMINGS. YOU CAN FIND THE -\ RESULT AT - -\ HTTP://WWW.FORTH200X.ORG/TESTS/TESTER.FS -\ HTTP://WWW.FORTH200X.ORG/TESTS/TTESTER.FS - -\ TESTER.FS IS INTENDED TO BE A DROP-IN REPLACEMENT OF THE ORIGINAL. - -\ TTESTER.FS IS A VERSION THAT USES T{ AND }T INSTEAD OF { AND } AND -\ KEEPS THE BASE AS IT WAS BEFORE LOADING TTESTER.FS - -\ IN SPIRIT OF THE ORIGINAL, I HAVE STRIVED TO AVOID ANY POTENTIAL -\ NON-PORTABILITIES AND STAYED AS MUCH WITHIN THE CORE WORDS AS -\ POSSIBLE; E.G., FLOATING WORDS ARE USED ONLY IF THE FLOATING WORDSET -\ IS PRESENT - -\ THERE ARE A FEW THINGS TO BE NOTED: - -\ - LOADING TTESTER.FS DOES NOT CHANGE BASE. LOADING TESTER.FS -\ CHANGES BASE TO HEX (LIKE THE ORIGINAL TESTER). FLOATING-POINT -\ INPUT IS AMBIGUOUS WHEN THE BASE IS NOT DECIMAL, SO YOU HAVE TO SET -\ IT TO DECIMAL YOURSELF WHEN YOU WANT TO DEAL WITH DECIMAL NUMBERS. - -\ - FOR FP IT IS OFTEN USEFUL TO USE APPROXIMATE EQUALITY FOR CHECKING -\ THE RESULTS. YOU CAN TURN ON APPROXIMATE MATCHING WITH SET-NEAR -\ (AND TURN IT OFF (DEFAULT) WITH SET-EXACT, AND YOU CAN TUNE IT BY -\ SETTING THE VARIABLES REL-NEAR AND ABS-NEAR. IF YOU WANT YOUR TESTS -\ TO WORK WITH A SHARED STACK, YOU HAVE TO SPECIFY THE TYPES OF THE -\ ELEMENTS ON THE STACK BY USING ONE OF THE CLOSING WORDS THAT SPECIFY -\ TYPES, E.G. RRRX}T FOR CHECKING THE STACK PICTURE ( R R R X ). -\ THERE ARE SUCH WORDS FOR ALL COMBINATION OF R AND X WITH UP TO 4 -\ STACK ITEMS, AND DEFINING MORE IF YOU NEED THEM IS STRAIGHTFORWARD -\ (SEE SOURCE). IF YOUR TESTS ARE ONLY INTENDED FOR A SEPARATE-STACK -\ SYSTEM OR IF YOU NEED ONLY EXACT MATCHING, YOU CAN USE THE PLAIN }T -\ INSTEAD. +\ Loading ttester.fs does not change BASE. Remember that floating point input +\ is ambiguous if the base is not decimal. + +\ The file defines some 70 words in all, but in most cases only the +\ ones mentioned above will be needed for successful testing. BASE @ HEX -\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY -\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. -VARIABLE VERBOSE - FALSE VERBOSE ! - -VARIABLE ACTUAL-DEPTH \ STACK RECORD +VARIABLE ACTUAL-DEPTH \ stack record CREATE ACTUAL-RESULTS 20 CELLS ALLOT VARIABLE START-DEPTH -VARIABLE XCURSOR \ FOR ...}T +VARIABLE XCURSOR \ for ...}T VARIABLE ERROR-XT -: ERROR ERROR-XT @ EXECUTE ; +: ERROR ERROR-XT @ EXECUTE ; \ for vectoring of error reporting -: "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE +: "FLOATING" S" FLOATING" ; \ only compiled S" in CORE : "FLOATING-STACK" S" FLOATING-STACK" ; "FLOATING" ENVIRONMENT? [IF] [IF] @@ -92,18 +104,18 @@ VARIABLE ERROR-XT [ELSE] FALSE [THEN] -[ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE - HAS-FLOATING \ IF WE HAVE FLOATING, WE ASSUME IT IS +[ELSE] \ We don't know whether the FP stack is separate. + HAS-FLOATING \ If we have FLOATING, we assume it is. [THEN] CONSTANT HAS-FLOATING-STACK HAS-FLOATING [IF] - \ SET THE FOLLOWING TO THE RELATIVE AND ABSOLUTE TOLERANCES YOU - \ WANT FOR APPROXIMATE FLOAT EQUALITY, TO BE USED WITH F~ IN - \ FNEARLY=. KEEP THE SIGNS, BECAUSE F~ NEEDS THEM. + \ Set the following to the relative and absolute tolerances you + \ want for approximate float equality, to be used with F~ in + \ FNEARLY=. Keep the signs, because F~ needs them. FVARIABLE REL-NEAR DECIMAL 1E-12 HEX REL-NEAR F! FVARIABLE ABS-NEAR DECIMAL 0E HEX ABS-NEAR F! - \ WHEN EXACT? IS TRUE, }F USES FEXACTLY=, OTHERWISE FNEARLY=. + \ When EXACT? is TRUE, }F uses FEXACTLY=, otherwise FNEARLY=. TRUE VALUE EXACT? : SET-EXACT ( -- ) TRUE TO EXACT? ; @@ -112,22 +124,22 @@ HAS-FLOATING [IF] DECIMAL : FEXACTLY= ( F: X Y -- S: FLAG ) ( - LEAVE TRUE IF THE TWO FLOATS ARE IDENTICAL. + Leave TRUE if the two floats are identical. ) 0E F~ ; HEX : FABS= ( F: X Y -- S: FLAG ) ( - LEAVE TRUE IF THE TWO FLOATS ARE EQUAL WITHIN THE TOLERANCE - STORED IN ABS-NEAR. + Leave TRUE if the two floats are equal within the tolerance + stored in ABS-NEAR. ) ABS-NEAR F@ F~ ; : FREL= ( F: X Y -- S: FLAG ) ( - LEAVE TRUE IF THE TWO FLOATS ARE RELATIVELY EQUAL BASED ON THE - TOLERANCE STORED IN ABS-NEAR. + Leave TRUE if the two floats are relatively equal based on the + tolerance stored in ABS-NEAR. ) REL-NEAR F@ FNEGATE F~ ; @@ -136,11 +148,11 @@ HAS-FLOATING [IF] : FNEARLY= ( F: X Y -- S: FLAG ) ( - LEAVE TRUE IF THE TWO FLOATS ARE NEARLY EQUAL. THIS IS A - REFINEMENT OF DIRK ZOLLER'S FEQ TO ALSO ALLOW X = Y, INCLUDING - BOTH ZERO, OR TO ALLOW APPROXIMATE EQUALITY WHEN X AND Y ARE TOO - SMALL TO SATISFY THE RELATIVE APPROXIMATION MODE IN THE F~ - SPECIFICATION. + Leave TRUE if the two floats are nearly equal. This is a + refinement of Dirk Zoller's FEQ to also allow X = Y, including + both zero, or to allow approximately equality when X and Y are too + small to satisfy the relative approximation mode in the F~ + specification. ) F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN F2DUP FREL= IF F2DROP TRUE EXIT THEN @@ -174,13 +186,13 @@ HAS-FLOATING-STACK [IF] : F-> ( ... -- ... ) FDEPTH DUP ACTUAL-FDEPTH ! START-FDEPTH @ > IF - FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F! LOOP + FDEPTH START-FDEPTH @ - 0 DO ACTUAL-FRESULTS I FLOATS + F! LOOP THEN ; : F} ( ... -- ... ) FDEPTH ACTUAL-FDEPTH @ = IF FDEPTH START-FDEPTH @ > IF - FDEPTH START-FDEPTH @ DO + FDEPTH START-FDEPTH @ - 0 DO ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF S" INCORRECT FP RESULT: " ERROR LEAVE THEN @@ -191,20 +203,19 @@ HAS-FLOATING-STACK [IF] THEN ; : F...}T ( -- ) - FDEPTH START-FDEPTH @ = 0= IF - S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR - THEN FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF - S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPRECIFICATION: " ERROR - THEN ; + S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR + ELSE FDEPTH START-FDEPTH @ = 0= IF + S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR + THEN THEN ; + : FTESTER ( R -- ) FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ START-FDEPTH @ + 1+ < OR IF - S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT - THEN - ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF + S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR + ELSE ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF S" INCORRECT FP RESULT: " ERROR - THEN + THEN THEN 1 FCURSOR +! ; [ELSE] @@ -214,24 +225,25 @@ HAS-FLOATING-STACK [IF] : F} ; : F...}T ; + HAS-FLOATING [IF] DECIMAL : COMPUTE-CELLS-PER-FP ( -- U ) DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ; HEX COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP - + : FTESTER ( R -- ) DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + CELLS-PER-FP + < OR IF S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT - THEN - ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF + ELSE ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF S" INCORRECT FP RESULT: " ERROR - THEN + THEN THEN CELLS-PER-FP XCURSOR +! ; - [THEN] + [THEN] +[THEN] -: EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. +: EMPTY-STACK \ ( ... -- ) empty stack; handles underflowed stack too. DEPTH START-DEPTH @ < IF DEPTH START-DEPTH @ SWAP DO 0 LOOP THEN @@ -240,63 +252,64 @@ HAS-FLOATING-STACK [IF] THEN EMPTY-FSTACK ; -: ERROR1 \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY - \ THE LINE THAT HAD THE ERROR. - TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR - EMPTY-STACK \ THROW AWAY EVERY THING ELSE +: ERROR1 \ ( C-ADDR U -- ) display an error message + \ followed by the line that had the error. + TYPE SOURCE TYPE CR \ display line corresponding to error + EMPTY-STACK \ throw away everything else ; ' ERROR1 ERROR-XT ! -: T{ \ ( -- ) SYNTACTIC SUGAR. +: T{ \ ( -- ) syntactic sugar. DEPTH START-DEPTH ! 0 XCURSOR ! F{ ; -: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. - DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH - START-DEPTH @ > IF \ IF THERE IS SOMETHING ON STACK - DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM +: -> \ ( ... -- ) record depth and contents of stack. + DEPTH DUP ACTUAL-DEPTH ! \ record depth + START-DEPTH @ > IF \ if there is something on the stack + DEPTH START-DEPTH @ - 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ save them THEN F-> ; : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED \ (ACTUAL) CONTENTS. - DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH - DEPTH START-DEPTH @ > IF \ IF THERE IS SOMETHING ON THE STACK - DEPTH START-DEPTH @ DO \ FOR EACH STACK ITEM - ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED + DEPTH ACTUAL-DEPTH @ = IF \ if depths match + DEPTH START-DEPTH @ > IF \ if there is something on the stack + DEPTH START-DEPTH @ - 0 DO \ for each stack item + ACTUAL-RESULTS I CELLS + @ \ compare actual with expected <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN LOOP THEN - ELSE \ DEPTH MISMATCH + ELSE \ depth mismatch S" WRONG NUMBER OF RESULTS: " ERROR THEN F} ; : ...}T ( -- ) - DEPTH START-DEPTH @ = 0= IF - S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR - THEN XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF - S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPRECIFICATION: " ERROR - THEN + S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR + ELSE DEPTH START-DEPTH @ = 0= IF + S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR + THEN THEN F...}T ; : XTESTER ( X -- ) DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT - THEN - ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF + ELSE ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF S" INCORRECT CELL RESULT: " ERROR - THEN + THEN THEN 1 XCURSOR +! ; : X}T XTESTER ...}T ; -: R}T FTESTER ...}T ; : XX}T XTESTER XTESTER ...}T ; +: XXX}T XTESTER XTESTER XTESTER ...}T ; +: XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ; + +HAS-FLOATING [IF] +: R}T FTESTER ...}T ; : XR}T FTESTER XTESTER ...}T ; : RX}T XTESTER FTESTER ...}T ; : RR}T FTESTER FTESTER ...}T ; -: XXX}T XTESTER XTESTER XTESTER ...}T ; : XXR}T FTESTER XTESTER XTESTER ...}T ; : XRX}T XTESTER FTESTER XTESTER ...}T ; : XRR}T FTESTER FTESTER XTESTER ...}T ; @@ -304,7 +317,6 @@ HAS-FLOATING-STACK [IF] : RXR}T FTESTER XTESTER FTESTER ...}T ; : RRX}T XTESTER FTESTER FTESTER ...}T ; : RRR}T FTESTER FTESTER FTESTER ...}T ; -: XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ; : XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ; : XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ; : XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ; @@ -320,6 +332,12 @@ HAS-FLOATING-STACK [IF] : RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ; : RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ; : RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ; +[THEN] + +\ Set the following flag to TRUE for more verbose output; this may +\ allow you to tell which test caused your system to hang. +VARIABLE VERBOSE + FALSE VERBOSE ! : TESTING \ ( -- ) TALKING COMMENT. SOURCE VERBOSE @ @@ -328,3 +346,4 @@ HAS-FLOATING-STACK [IF] THEN ; BASE ! +\ end of ttester.fs