 gforth/test/ttester.fs 2007/08/19 21:33:50 1.1
+++ gforth/test/ttester.fs 2007/10/26 12:47:41 1.6
@@ 1,55 +1,65 @@
\ From: John Hayes S1I
\ Subject: tester.fr
\ Date: Mon, 27 Nov 95 13:10:09 PST

+\ FOR THE ORIGINAL TESTER
+\ 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
\ revised by Anton Ertl 20070812, 20070819
\ The original has the following shortcomings:
+\ 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
\  It does not work as expected if the stack is nonempty before the {.
+\ HTTP://WWW.FORTH200X.ORG/TESTS/TESTER.FS
+\ HTTP://WWW.FORTH200X.ORG/TESTS/TTESTER.FS
\  It does not check FP results if the system has a separate FP stack.
+\ TESTER.FS IS INTENDED TO BE A DROPIN REPLACEMENT OF THE ORIGINAL.
\  There is a conflict with the use of } for FSL arrays and { for locals.
+\ TTESTER.FS IS A VERSION THAT USES T{ AND }T INSTEAD OF { AND } AND
+\ KEEPS THE BASE AS IT WAS BEFORE LOADING TTESTER.FS
\ 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 }.

\ 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:

\  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.
+\ 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.
+
+BASE @
HEX
\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
@@ 90,8 +100,7 @@ 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 RELNEAR DECIMAL 1E12 HEX RELNEAR F!
FVARIABLE ABSNEAR DECIMAL 0E HEX ABSNEAR F!
\ WHEN EXACT? IS TRUE, }F USES FEXACTLY=, OTHERWISE FNEARLY=.
@@ 183,15 +192,15 @@ HASFLOATINGSTACK [IF]
: F...}T (  )
FDEPTH STARTFDEPTH @ = 0= IF
 S" WRONG NUMBER OF FP RESULTS" ERROR
+ S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '>' DOES NOT MATCH: " ERROR
THEN
 FCURSOR @ ACTUALFDEPTH @ <> IF
 S" WRONG NUMBER OF FP RESULTS" ERROR
+ FCURSOR @ STARTFDEPTH @ + ACTUALFDEPTH @ <> IF
+ S" NUMBER OF FLOAT RESULTS BEFORE '>' DOES NOT MATCH ...}T SPRECIFICATION: " ERROR
THEN ;
: FTESTER ( R  )
 FDEPTH 0= ACTUALFDEPTH @ FCURSOR @ 1+ < OR IF
 S" WRONG NUMBER OF FP RESULTS: " ERROR EXIT
+ 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" INCORRECT FP RESULT: " ERROR
@@ 205,14 +214,16 @@ HASFLOATINGSTACK [IF]
: F} ;
: F...}T ;
+ DECIMAL
: COMPUTECELLSPERFP (  U )
 DEPTH 0E DEPTH >R FDROP R> SWAP  ;
+ 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
+ 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
S" INCORRECT FP RESULT: " ERROR
@@ 238,7 +249,7 @@ HASFLOATINGSTACK [IF]
' ERROR1 ERRORXT !
: T{ \ (  ) SYNTACTIC SUGAR.
 DEPTH STARTDEPTH ! F{ ;
+ DEPTH STARTDEPTH ! 0 XCURSOR ! F{ ;
: > \ ( ...  ) RECORD DEPTH AND CONTENT OF STACK.
DEPTH DUP ACTUALDEPTH ! \ RECORD DEPTH
@@ 263,16 +274,16 @@ HASFLOATINGSTACK [IF]
: ...}T (  )
DEPTH STARTDEPTH @ = 0= IF
 S" WRONG NUMBER OF RESULTS" ERROR
+ S" NUMBER OF CELL RESULTS BEFORE AND AFTER '>' DOES NOT MATCH: " ERROR
THEN
 XCURSOR @ ACTUALDEPTH @ <> IF
 S" WRONG NUMBER OF RESULTS" ERROR
+ XCURSOR @ STARTDEPTH @ + ACTUALDEPTH @ <> IF
+ S" NUMBER OF CELL RESULTS BEFORE '>' DOES NOT MATCH ...}T SPRECIFICATION: " ERROR
THEN
F...}T ;
: XTESTER ( X  )
 DEPTH 0= ACTUALDEPTH @ XCURSOR @ 1+ < OR IF
 S" WRONG NUMBER OF RESULTS: " ERROR EXIT
+ DEPTH 0= ACTUALDEPTH @ XCURSOR @ STARTDEPTH @ + 1+ < OR IF
+ S" NUMBER OF CELL RESULTS AFTER '>' BELOW ...}T SPECIFICATION: " ERROR EXIT
THEN
ACTUALRESULTS XCURSOR @ CELLS + @ <> IF
S" INCORRECT CELL RESULT: " ERROR
@@ 315,3 +326,5 @@ HASFLOATINGSTACK [IF]
IF DUP >R TYPE CR R> >IN !
ELSE >IN ! DROP
THEN ;
+
+BASE !