(       Title:  Floating point word tester
         File:  ftester-old.fs
  Modified by:  David N. Williams
      License:  LGPL
      Version:  1.1.3
Starting date:  December 12, 2002
Version 1.1.0:  December 12, 2002
Version 1.1.1:  December 14, 2002
Version 1.1.2:  December 16, 2002
      Revised:  January 12, 2005
      Revised:  April 24, 2005
      Revised:  November 7, 2010 [file name change from ftester.fs]

For any code derived from John Hayes' tester program:
)
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
(
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or at your option any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free
Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
MA 02111-1307 USA.

This code extends John Hayes' tester.fr to include a separate
floating point stack, used with a variation on the approximate
equality in Dirk Zoller's float.4th [05Aug93].

There is an ANS Forth environmental dependence on lower case.
)

s" FLOATING-EXT" environment? [IF] ( flag) drop
  s" FLOATING-STACK" environment? [IF]
    ( maxdepth) [IF]

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

\ 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 rel-near    1E-15 rel-near f!  \ absolute values
fvariable abs-near    1E-15 abs-near f!  \ of tolerances

\ When EXACT? is true, }F uses FEXACTLY=, otherwise FNEARLY=.

false value exact?
: set-exact  ( -- )   true to exact? ;
: set-near   ( -- )  false to exact? ;

: f2dup   fover fover ;
: f2drop  fdrop fdrop ;

: empty-stack  ( ... -- )
(
Empty the data stack.  Handles underflow, too.
)
  depth ?dup
  IF dup 0< 
    IF negate 0 DO 0 LOOP
    ELSE 0 DO drop LOOP
    THEN
  THEN ;

: empty-fstack  ( ... -- )
(
Empty the floating point stack.  Handles underflow, too.
)
  fdepth ?dup
  IF dup 0< 
    IF negate 0 DO 0 LOOP
    ELSE 0 DO fdrop LOOP
    THEN
  THEN ;

variable #errors   0 #errors !

: error  ( c-addr u -- )
(
Display an error message followed by the line that had the
error.
)
  1 #errors +!
  type source type cr		\ display line corresponding to error
  empty-stack empty-fstack ;	\ throw away every thing else

\ stack records
variable actual-depth
create actual-results 20 cells allot
variable actual-fdepth
create actual-fresults falign 20 floats allot

\ syntactic sugar
: {    ( -- )  ;
: f{   ( -- )  ;
: (f:  ( -- ) postpone ( ; immediate

: ->  ( ... -- )
(
Record the depth and content of data stack.
)
  depth dup actual-depth !		\ record depth
  ?dup IF				\ if there is something on stack
    0 DO				\ save them
      actual-results i cells + !
    LOOP
  THEN ;

: f->  (f: ... -- )
(
Record depth and content of floating point stack.
)
  fdepth dup actual-fdepth !		\ record depth
  ?dup IF				\ if there is something on stack
     0 DO				\ save them
       actual-fresults faligned i floats + f!
     LOOP
  THEN ;

: }  ( ... -- )
(
Compare the data stack [expected] contents with the 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
        actual-results
	    i cells + @			\ compare actual with expected
	<> IF s" incorrect data result: " error LEAVE THEN
      LOOP
    THEN
  ELSE					\ depth mismatch
    s" wrong number of data results: " error
  THEN ;

: fexactly=  (f: x y -- s: flag )
(
Leave true if the two floats are identical.
)
  0E f~ ;

: fabs=  (f: x y -- s: flag )
(
Leave true if the two floats are equal within the tolerance
stored in ABS-NEAR.
)
  abs-near f@ f~ ;

: frel=  (f: x y -- s: flag )
(
Leave true if the two floats are relatively equal based on the
tolerance stored in ABS-NEAR.
)
  rel-near f@ fnegate f~ ;

: 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.
)
  f2dup fexactly= IF f2drop true EXIT THEN
  f2dup frel=     IF f2drop true EXIT THEN
  fabs= ;

: }f  (f: ... -- )
(
Compare the float stack [expected] contents with the saved
[actual] contents.  If EXACT? is true, use FEXACTLY=, otherwise
use FNEARLY=.
)
  fdepth actual-fdepth @ = IF		\ if depths match
    fdepth ?dup IF			\ if there is something on the stack
      0 DO				\ for each stack item
        actual-fresults faligned
	    i floats + f@		\ compare actual with expected
        exact? IF
	  fexactly= 0= IF s" incorrect exact float result: "
	      error LEAVE THEN
	ELSE
	  fnearly= 0= IF s" incorrect near float result:  "
	      error LEAVE THEN
	THEN
      LOOP
    THEN
  ELSE					\ depth mismatch
    s" wrong number of float results: " error
  THEN ;

: testing  ( -- )  \ talking comment
  source verbose @
  IF dup >r type cr r> >in !
  ELSE >in ! drop
  THEN ;

    [ELSE]
      .( ***This tester works only with a separate floating point stack.)
    [THEN]
  [ELSE]
    .( ***"FLOATING-STACK" environment query undefined.)
  [THEN]
[ELSE]
  .( ***Floating point words not available.)
[THEN]