--- gforth/test/tester.fs	2007/08/12 12:10:35	1.2
+++ gforth/test/tester.fs	2007/08/12 13:13:20	1.3
@@ -1,11 +1,16 @@
 \ From: John Hayes S1I
 \ Subject: tester.fr
 \ Date: Mon, 27 Nov 95 13:10:09 PST  
-\ revised by Anton Ertl 2007-08-12
 
 \ (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
+\   added fp comparisons (note: BASE is HEX after loading this file)
+\         environmental dependency on separate fp stack
+\         the sensitivity of the fp comparison is determined by FSENSITIVITY
+\   added support for non-empty stack at the start
 HEX
 
 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
@@ -13,27 +18,101 @@ 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 -1E-12 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
-VARIABLE START-DEPTH
+' ERROR1 ERROR-XT !
 
 : {		\ ( -- ) SYNTACTIC SUGAR.
-   DEPTH START-DEPTH ! ;
+   DEPTH START-DEPTH ! 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
-   THEN ;
+   THEN
+   F-> ;
 
 : }		\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
 		\ (ACTUAL) CONTENTS.
@@ -46,7 +125,8 @@ VARIABLE START-DEPTH
       THEN
    ELSE					\ DEPTH MISMATCH
       S" WRONG NUMBER OF RESULTS: " ERROR
-   THEN ;
+   THEN
+   F} ;
 
 : TESTING	\ ( -- ) TALKING COMMENT.
    SOURCE VERBOSE @