 gforth/test/ttester.fs 2007/10/26 12:47:41 1.6
+++ gforth/test/ttester.fs 2009/09/21 15:32:56 1.16
@@ 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 nonempty
+\ 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/cgibin/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 floatingpoint support is present, and
+\ if so, whether there is a separate floatingpoint stack, and behave
+\ accordingly. The CONSTANTs HASFLOATING and HASFLOATINGSTACK
+\ 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 SETEXACT (the
+\ default). If approximate equality tests are desired, execute
+\ SETNEAR . Then the FVARIABLEs RELNEAR (default 1E12) and
+\ ABSNEAR (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:
+
+\ SETNEAR
+\ 1E6 RELNEAR 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 20070812, 20070819, 20070828
\ PUBLIC DOMAIN

\ THE ORIGINAL HAS THE FOLLOWING SHORTCOMINGS:

\  IT DOES NOT WORK AS EXPECTED IF THE STACK IS NONEMPTY 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 DROPIN 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
\ NONPORTABILITIES 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). FLOATINGPOINT
\ 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 SETNEAR
\ (AND TURN IT OFF (DEFAULT) WITH SETEXACT, AND YOU CAN TUNE IT BY
\ SETTING THE VARIABLES RELNEAR AND ABSNEAR. 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 SEPARATESTACK
\ 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.
BASE @
HEX
+\ The file defines some 70 words in all, but in most cases only the
+\ ones mentioned above will be needed for successful testing.
\ 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 !
+BASE @
+DECIMAL
VARIABLE ACTUALDEPTH \ STACK RECORD
CREATE ACTUALRESULTS 20 CELLS ALLOT
+VARIABLE ACTUALDEPTH \ stack record
+CREATE ACTUALRESULTS 32 CELLS ALLOT
VARIABLE STARTDEPTH
VARIABLE XCURSOR \ FOR ...}T
+VARIABLE XCURSOR \ for ...}T
VARIABLE ERRORXT
: ERROR ERRORXT @ EXECUTE ;
+: ERROR ERRORXT @ EXECUTE ; \ for vectoring of error reporting
: "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE
+: "FLOATING" S" FLOATING" ; \ only compiled S" in CORE
: "FLOATINGSTACK" S" FLOATINGSTACK" ;
"FLOATING" ENVIRONMENT? [IF]
[IF]
@@ 92,42 +104,40 @@ VARIABLE ERRORXT
[ELSE]
FALSE
[THEN]
[ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE
 HASFLOATING \ IF WE HAVE FLOATING, WE ASSUME IT IS
+[ELSE] \ We don't know whether the FP stack is separate.
+ HASFLOATING \ If we have FLOATING, we assume it is.
[THEN] CONSTANT HASFLOATINGSTACK
HASFLOATING [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.
 FVARIABLE RELNEAR DECIMAL 1E12 HEX RELNEAR F!
 FVARIABLE ABSNEAR DECIMAL 0E HEX ABSNEAR F!
+ \ 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 RELNEAR 1E12 RELNEAR F!
+ FVARIABLE ABSNEAR 0E ABSNEAR F!
 \ WHEN EXACT? IS TRUE, }F USES FEXACTLY=, OTHERWISE FNEARLY=.
+ \ When EXACT? is TRUE, }F uses FEXACTLY=, otherwise FNEARLY=.
TRUE VALUE EXACT?
: SETEXACT (  ) TRUE TO EXACT? ;
: SETNEAR (  ) FALSE TO EXACT? ;
 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 ABSNEAR.
+ Leave TRUE if the two floats are equal within the tolerance
+ stored in ABSNEAR.
)
ABSNEAR F@ F~ ;
: FREL= ( F: X Y  S: FLAG )
(
 LEAVE TRUE IF THE TWO FLOATS ARE RELATIVELY EQUAL BASED ON THE
 TOLERANCE STORED IN ABSNEAR.
+ Leave TRUE if the two floats are relatively equal based on the
+ tolerance stored in ABSNEAR.
)
RELNEAR F@ FNEGATE F~ ;
@@ 136,11 +146,11 @@ HASFLOATING [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
@@ 156,7 +166,7 @@ HASFLOATING [IF]
HASFLOATINGSTACK [IF]
VARIABLE ACTUALFDEPTH
 CREATE ACTUALFRESULTS 20 FLOATS ALLOT
+ CREATE ACTUALFRESULTS 32 FLOATS ALLOT
VARIABLE STARTFDEPTH
VARIABLE FCURSOR
@@ 167,20 +177,20 @@ HASFLOATINGSTACK [IF]
FDEPTH STARTFDEPTH @ > IF
FDEPTH STARTFDEPTH @ DO FDROP LOOP
THEN ;

+
: F{ (  )
FDEPTH STARTFDEPTH ! 0 FCURSOR ! ;
: F> ( ...  ... )
FDEPTH DUP ACTUALFDEPTH !
STARTFDEPTH @ > IF
 FDEPTH STARTFDEPTH @ DO ACTUALFRESULTS I FLOATS + F! LOOP
+ FDEPTH STARTFDEPTH @  0 DO ACTUALFRESULTS I FLOATS + F! LOOP
THEN ;
: F} ( ...  ... )
FDEPTH ACTUALFDEPTH @ = IF
FDEPTH STARTFDEPTH @ > IF
 FDEPTH STARTFDEPTH @ DO
+ FDEPTH STARTFDEPTH @  0 DO
ACTUALFRESULTS I FLOATS + F@ FCONF= INVERT IF
S" INCORRECT FP RESULT: " ERROR LEAVE
THEN
@@ 191,20 +201,19 @@ HASFLOATINGSTACK [IF]
THEN ;
: F...}T (  )
 FDEPTH STARTFDEPTH @ = 0= IF
 S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '>' DOES NOT MATCH: " ERROR
 THEN
FCURSOR @ STARTFDEPTH @ + ACTUALFDEPTH @ <> 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 STARTFDEPTH @ = 0= IF
+ S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '>' DOES NOT MATCH: " ERROR
+ THEN THEN ;
+
: FTESTER ( R  )
FDEPTH 0= ACTUALFDEPTH @ FCURSOR @ STARTFDEPTH @ + 1+ < OR IF
 S" NUMBER OF FLOAT RESULTS AFTER '>' BELOW ...}T SPECIFICATION: " ERROR EXIT
 THEN
 ACTUALFRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
+ S" NUMBER OF FLOAT RESULTS AFTER '>' BELOW ...}T SPECIFICATION: " ERROR
+ ELSE ACTUALFRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
S" INCORRECT FP RESULT: " ERROR
 THEN
+ THEN THEN
1 FCURSOR +! ;
[ELSE]
@@ 214,24 +223,23 @@ HASFLOATINGSTACK [IF]
: F} ;
: F...}T ;
 DECIMAL
+ HASFLOATING [IF]
: COMPUTECELLSPERFP (  U )
DEPTH 0E DEPTH 1 >R FDROP R> SWAP  ;
 HEX
COMPUTECELLSPERFP CONSTANT CELLSPERFP

+
: FTESTER ( R  )
DEPTH CELLSPERFP < ACTUALDEPTH @ XCURSOR @ STARTDEPTH @ + CELLSPERFP + < OR IF
S" NUMBER OF RESULTS AFTER '>' BELOW ...}T SPECIFICATION: " ERROR EXIT
 THEN
 ACTUALRESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
+ ELSE ACTUALRESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
S" INCORRECT FP RESULT: " ERROR
 THEN
+ THEN THEN
CELLSPERFP XCURSOR +! ;
 [THEN]
+ [THEN]
+[THEN]
: EMPTYSTACK \ ( ...  ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
+: EMPTYSTACK \ ( ...  ) empty stack; handles underflowed stack too.
DEPTH STARTDEPTH @ < IF
DEPTH STARTDEPTH @ SWAP DO 0 LOOP
THEN
@@ 240,63 +248,64 @@ HASFLOATINGSTACK [IF]
THEN
EMPTYFSTACK ;
: ERROR1 \ ( CADDR U  ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
 \ THE LINE THAT HAD THE ERROR.
 TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR
 EMPTYSTACK \ THROW AWAY EVERY THING ELSE
+: ERROR1 \ ( CADDR U  ) display an error message
+ \ followed by the line that had the error.
+ TYPE SOURCE TYPE CR \ display line corresponding to error
+ EMPTYSTACK \ throw away everything else
;
' ERROR1 ERRORXT !
: T{ \ (  ) SYNTACTIC SUGAR.
+: T{ \ (  ) syntactic sugar.
DEPTH STARTDEPTH ! 0 XCURSOR ! F{ ;
: > \ ( ...  ) RECORD DEPTH AND CONTENT OF STACK.
 DEPTH DUP ACTUALDEPTH ! \ RECORD DEPTH
 STARTDEPTH @ > IF \ IF THERE IS SOMETHING ON STACK
 DEPTH STARTDEPTH @ DO ACTUALRESULTS I CELLS + ! LOOP \ SAVE THEM
+: > \ ( ...  ) record depth and contents of stack.
+ DEPTH DUP ACTUALDEPTH ! \ record depth
+ STARTDEPTH @ > IF \ if there is something on the stack
+ DEPTH STARTDEPTH @  0 DO ACTUALRESULTS I CELLS + ! LOOP \ save them
THEN
F> ;
: }T \ ( ...  ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
\ (ACTUAL) CONTENTS.
 DEPTH ACTUALDEPTH @ = IF \ IF DEPTHS MATCH
 DEPTH STARTDEPTH @ > IF \ IF THERE IS SOMETHING ON THE STACK
 DEPTH STARTDEPTH @ DO \ FOR EACH STACK ITEM
 ACTUALRESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED
+ DEPTH ACTUALDEPTH @ = IF \ if depths match
+ DEPTH STARTDEPTH @ > IF \ if there is something on the stack
+ DEPTH STARTDEPTH @  0 DO \ for each stack item
+ ACTUALRESULTS 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 STARTDEPTH @ = 0= IF
 S" NUMBER OF CELL RESULTS BEFORE AND AFTER '>' DOES NOT MATCH: " ERROR
 THEN
XCURSOR @ STARTDEPTH @ + ACTUALDEPTH @ <> 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 STARTDEPTH @ = 0= IF
+ S" NUMBER OF CELL RESULTS BEFORE AND AFTER '>' DOES NOT MATCH: " ERROR
+ THEN THEN
F...}T ;
: XTESTER ( X  )
DEPTH 0= ACTUALDEPTH @ XCURSOR @ STARTDEPTH @ + 1+ < OR IF
S" NUMBER OF CELL RESULTS AFTER '>' BELOW ...}T SPECIFICATION: " ERROR EXIT
 THEN
 ACTUALRESULTS XCURSOR @ CELLS + @ <> IF
+ ELSE ACTUALRESULTS 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 ;
+
+HASFLOATING [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 +313,6 @@ HASFLOATINGSTACK [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 +328,12 @@ HASFLOATINGSTACK [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 +342,4 @@ HASFLOATINGSTACK [IF]
THEN ;
BASE !
+\ end of ttester.fs