 gforth/test/ttester.fs 2007/08/28 19:15:03 1.4
+++ gforth/test/ttester.fs 2009/09/21 15:32:56 1.16
@@ 1,82 +1,93 @@
\ for the original tester
+\ 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

\ for the FNEARLY= stuff:
+\ 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
\ 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
+\ 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.
\ 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
+\ Loading ttester.fs does not change BASE. Remember that floating point input
+\ is ambiguous if the base is not decimal.
\ There are a few things to be noted:

\  Following the despicable practice of the original, this version
\ sets the base to HEX for everything that gets loaded later.
\ 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.
+\ 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 !
+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]
@@ 93,43 +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 FSENSITIVITY DECIMAL 1E12 HEX FSENSITIVITY F!
 : RELNEAR FSENSITIVITY ;
 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~ ;
@@ 138,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
@@ 158,7 +166,7 @@ HASFLOATING [IF]
HASFLOATINGSTACK [IF]
VARIABLE ACTUALFDEPTH
 CREATE ACTUALFRESULTS 20 FLOATS ALLOT
+ CREATE ACTUALFRESULTS 32 FLOATS ALLOT
VARIABLE STARTFDEPTH
VARIABLE FCURSOR
@@ 169,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
@@ 193,20 +201,19 @@ HASFLOATINGSTACK [IF]
THEN ;
: F...}T (  )
 FDEPTH STARTFDEPTH @ = 0= IF
 S" WRONG NUMBER OF FP RESULTS" ERROR
 THEN
 FCURSOR @ ACTUALFDEPTH @ <> IF
 S" WRONG NUMBER OF FP RESULTS" ERROR
 THEN ;
+ FCURSOR @ STARTFDEPTH @ + ACTUALFDEPTH @ <> IF
+ 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 @ 1+ < OR IF
 S" WRONG NUMBER OF FP RESULTS: " ERROR EXIT
 THEN
 ACTUALFRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
+ FDEPTH 0= ACTUALFDEPTH @ FCURSOR @ STARTFDEPTH @ + 1+ < OR 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]
@@ 216,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 @ CELLSPERFP + < OR IF
 S" WRONG NUMBER OF RESULTS: " ERROR EXIT
 THEN
 ACTUALRESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
+ DEPTH CELLSPERFP < ACTUALDEPTH @ XCURSOR @ STARTDEPTH @ + CELLSPERFP + < OR IF
+ S" NUMBER OF RESULTS AFTER '>' BELOW ...}T SPECIFICATION: " ERROR EXIT
+ 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
@@ 242,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" WRONG NUMBER OF RESULTS" ERROR
 THEN
 XCURSOR @ ACTUALDEPTH @ <> IF
 S" WRONG NUMBER OF RESULTS" ERROR
 THEN
+ XCURSOR @ STARTDEPTH @ + ACTUALDEPTH @ <> IF
+ 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 @ 1+ < OR IF
 S" WRONG NUMBER OF RESULTS: " ERROR EXIT
 THEN
 ACTUALRESULTS XCURSOR @ CELLS + @ <> IF
+ DEPTH 0= ACTUALDEPTH @ XCURSOR @ STARTDEPTH @ + 1+ < OR IF
+ S" NUMBER OF CELL RESULTS AFTER '>' BELOW ...}T SPECIFICATION: " ERROR EXIT
+ 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 ;
@@ 306,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 ;
@@ 322,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 @
@@ 329,4 +341,5 @@ HASFLOATINGSTACK [IF]
ELSE >IN ! DROP
THEN ;
BASE !
\ No newline at end of file
+BASE !
+\ end of ttester.fs