--- gforth/test/tester.fs	1997/05/21 20:40:20	1.1
+++ gforth/test/tester.fs	2007/08/12 13:48:53	1.5
@@ -5,6 +5,48 @@
 \ (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 2007-08-12
+\ The original has two 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.
+
+\ I have revised it to address both shortcomings.  You can find the
+\ result at
+
+\ http://www.forth200x.org/tests/tester.fs
+
+\ It is intended to be a drop-in replacement of the original.
+
+\ 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 and the FP stack is separate.
+
+\ 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.
+\   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.
+
+\ - The separate-FP-stack code has an fvariable FSENSITIVITY that allows
+\   approximate matching of FP results (it's used as the r3 parameter of
+\   F~).  However, that's used only in the separate-fp-stack case.  With
+\   a shared-fp-stack you get exact matching in any case (actually
+\   FSENSITIVITY variable is not even defined in that case).  So if you
+\   define an FP test case and want to support shared-FP-stack systems,
+\   better do the approximate matching yourself.  E.g., instead of
+
+\   -1e-12 fsensitivity f!
+\   { ... computation ... -> 2.345678901e }
+
+\   write
+
+\   { ... computation ... 2.345678901e -1e-12 f~ -> true }
 HEX
 
 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
@@ -12,39 +54,115 @@ HEX
 VARIABLE VERBOSE
    FALSE VERBOSE !
 
+VARIABLE ACTUAL-DEPTH			\ STACK RECORD
+CREATE ACTUAL-RESULTS 20 CELLS ALLOT
+VARIABLE START-DEPTH
+VARIABLE ERROR-XT
+
+: ERROR ERROR-XT @ EXECUTE ;
+
+: "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE
+: "FLOATING-STACK" S" FLOATING-STACK" ;
+"FLOATING" ENVIRONMENT? [IF]
+    [IF]
+        "FLOATING-STACK" ENVIRONMENT? [IF]
+            [IF]
+                TRUE
+            [ELSE]
+                FALSE
+            [THEN]
+        [ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE
+            TRUE \ SAFER CHOICE TO ASSUME IT IS
+        [THEN]  
+    [ELSE]
+        FALSE
+    [THEN]
+[ELSE]
+    FALSE
+[THEN]
+[IF] \ WE HAVE FP WORDS AND A SEPARATE FP STACK
+    FVARIABLE FSENSITIVITY DECIMAL 0E HEX FSENSITIVITY F!
+    VARIABLE ACTUAL-FDEPTH
+    CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
+    VARIABLE START-FDEPTH
+
+    : EMPTY-FSTACK ( ... -- ... )
+        FDEPTH START-FDEPTH @ < IF
+            FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
+        THEN
+        FDEPTH START-FDEPTH @ > IF
+            FDEPTH START-FDEPTH @ DO FDROP LOOP
+        THEN ;
+
+    : F{ ( -- )
+        FDEPTH START-FDEPTH ! ;
+
+    : F-> ( ... -- ... )
+        FDEPTH DUP ACTUAL-FDEPTH !
+        START-FDEPTH @ > IF
+            FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F! LOOP
+        THEN ;
+
+    : F} ( ... -- ... )
+        FDEPTH ACTUAL-FDEPTH @ = IF
+            FDEPTH START-FDEPTH @ > IF
+                FDEPTH START-FDEPTH @ DO
+                    ACTUAL-FRESULTS I FLOATS + F@
+                    FSENSITIVITY F@ F~ INVERT IF
+                        S" INCORRECT RESULT: " ERROR LEAVE
+                    THEN
+                LOOP
+            THEN
+        ELSE
+            S" WRONG NUMBER OF RESULTS: " ERROR
+        THEN ;
+[ELSE]
+    : EMPTY-FSTACK ;
+    : F{ ;
+    : F-> ;
+    : F} ;
+[THEN]    
+
 : EMPTY-STACK	\ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
-   DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;
+    DEPTH START-DEPTH @ < IF
+        DEPTH START-DEPTH @ SWAP DO 0 LOOP
+    THEN
+    DEPTH START-DEPTH @ > IF
+        DEPTH START-DEPTH @ DO DROP LOOP
+    THEN
+    EMPTY-FSTACK ;
 
-: ERROR		\ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
+: 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
 ;
 
-VARIABLE ACTUAL-DEPTH			\ STACK RECORD
-CREATE ACTUAL-RESULTS 20 CELLS ALLOT
+' ERROR1 ERROR-XT !
 
 : {		\ ( -- ) SYNTACTIC SUGAR.
-   ;
+   DEPTH START-DEPTH ! F{ ;
 
 : ->		\ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
    DEPTH DUP ACTUAL-DEPTH !		\ RECORD DEPTH
-   ?DUP IF				\ IF THERE IS SOMETHING ON STACK
-      0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
-   THEN ;
+   START-DEPTH @ > IF		\ IF THERE IS SOMETHING ON STACK
+       DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
+   THEN
+   F-> ;
 
 : }		\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
 		\ (ACTUAL) CONTENTS.
    DEPTH ACTUAL-DEPTH @ = IF		\ IF DEPTHS MATCH
-      DEPTH ?DUP IF			\ IF THERE IS SOMETHING ON THE STACK
-         0 DO				\ FOR EACH STACK ITEM
+      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
 	    <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
 	 LOOP
       THEN
    ELSE					\ DEPTH MISMATCH
       S" WRONG NUMBER OF RESULTS: " ERROR
-   THEN ;
+   THEN
+   F} ;
 
 : TESTING	\ ( -- ) TALKING COMMENT.
    SOURCE VERBOSE @