(      Title:  A utility for testing Forth
               floating-point stack effects
        File:  ztester.fs
  Test files:  ztester-test.fs
    Log file:  ztester.log
     License:  John Hayes, Public Domain
     Version:  1.0.0
     Revised:  December 6, 2010
  Adapted by:  David N. Williams

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.
(
The rest is public domain.

This code is based on John Hayes' tester.fr, as modified by
Anton Ertl in gforth's ttester.fs, and by us in ftester.fs, to
work with ttester-xf.fs

There is an ANS Forth environmental dependence on lower case.

PUBLIC WORDS

   tests:  Z{  Z->  }Z
           ZT-XABS-ERROR      ZT-YABS-ERROR      ZT-ZABS-ERROR
           ZT-XREL-ERROR      ZT-YREL-ERROR      ZT-ZREL-ERROR
           ZT-XTEST=-XT       ZT-YTEST=-XT       ZT-ZTEST=-XT
           SET-ZT-MODE-XEXACT SET-ZT-MODE-YEXACT SET-ZT-MODE-ZEXACT
           SET-ZT-MODE-XABS   SET-ZT-MODE-YABS   SET-ZT-MODE-ZABS
           SET-ZT-MODE-XREL   SET-ZT-MODE-YREL   SET-ZT-MODE-ZREL
           ZT-XABS=  ZT-YABS=  ZT-ZABS=
           ZT-XREL=  ZT-YREL=  ZT-ZREL=  
           
  errors:  ZT-ERROR-XT  ZT-ERROR-DEFAULT  ZT-ERROR-INDEX

  arrays:  ZT-RESULTS  ZT-GOALS  ZT-A@  ZT-A!  ZT-A<>

  config:  MAX-ZT-RESULTS

The array words can be used for more elaborate error reporting,
for example, to dump the complex results and goals when
something is wrong, or to report a particular complex error with
the help of ZT-ERROR-INDEX.  See the word ZT-A. in
ztester-test.fs, and an example of its use to print complex
results and goals.

The basic test usage takes the form:

  <finitials> Z{ <zresults> Z-> <zgoals> }F <finitials>

where <finitials> are possibly nonempty fp stack contents at the
start of the test.  Note that the complex and fp stacks are integrated,
and that <zresults> and <zgoals> are required to be even numbers of
<fresults> and <fgoals>.

The sequence saves <finitials> and removes them from the fp
stack, executes the code that produces the fp stack <zresults>,
saves and removes the <zresults> from the fp stack, executes the
code that produces the fp stack <zgoals>, saves and removes
them, compares the saved <zresults> and <zgoals>, reports when
there is a discrepancy between the two, and restores the saved
<finitials>.

Effects present or produced on non-fp stacks before Z{, Z->, or
}Z are simply ignored.

More examples can be found in the file ztester-test.fs.

The private word ZT-ERROR is vectored.  It executes the xt held
in the public variable ZT-ERROR-XT, which defaults to the xt of
the public ZT-ERROR-DEFAULT.  For example, the user might change
the action to count the number of complex errors for later reporting,
and use ZT-ERRROR-DEFAULT as a factor, which prints a string and
displays the line on which the error occurs.

Complex comparisons have to take into account the fact that
complex numbers are two floats.  When the real or imaginary part
is supposed to be approximately zero, and the other is not,
different comparisons of the two parts may be appropriate. 
There are also cases where it is appropriate to compare with the
complex absolute value metric, rather than comparing the real
and imaginary parts separately.

A number of built-in comparison modes are supplied, which can be
set with the public words SET-ZT-MODE-XEXACT, etc.  These modes
use the xt's in the corresponding three public variables
ZT-XTEST=-XT, etc., and the tolerances in the corresponding six
public fp variables ZT-XABS-ERROR, etc., all of which can be
changed by the user after this file is loaded.

Note that relative ZT comparisons are not symmetric.  Measured
values must be in the zresults, and reference values in the
zgoals.

Storage of <finitials>, <zresults>, and <zgoals> includes
overflow checking.  The user can change the overflow limits by
defining one or both of the following constants *before* loading
ftester.fs, respectively, ztester.fs:

  MAX-FT-INITIALS  MAX-ZT-RESULTS

Loading ztester.fs does not change BASE.  Remember that
floating-point input is ambiguous if the base is not decimal.
)

BASE @
DECIMAL

\ This file will not load unless complex.fs, complex-kahan.fs,
\ or the pfe COMPLEX-EXT module, and ftester.fs are already
\ loaded.
\ s" complex.fs" INCLUDED
\ s" ftester.fs" INCLUDED


\ *** ERROR REPORTING

\ PUBLIC

VARIABLE ZT-ERROR-XT
: ZT-ERROR   ZT-ERROR-XT @ EXECUTE ;

VARIABLE ZT-ERROR-INDEX  \ holds array index|-1 after error

\ Display an error message followed by the line that had the
\ error.
: ZT-ERROR-DEFAULT  ( c-addr u -- )  FT-ERROR-DEFAULT ;
' ZT-ERROR-DEFAULT ZT-ERROR-XT !


\ *** COMPLEX FP COMPARISONS

\ PUBLIC

VARIABLE ZT-XTEST=-XT
VARIABLE ZT-YTEST=-XT
VARIABLE ZT-ZTEST=-XT

\ PRIVATE

true VALUE ZT-XYMODE?

: ZT-TEST=  ( f: 'z1 'z2 -- ) ( -- flag )
  LOCALS| 'z2 'z1 |
  ZT-XYMODE? IF
    'z1 f@ 'z2 f@ ZT-XTEST=-XT @ EXECUTE
    'z1 float+ f@ 'z2 float+ f@ ZT-YTEST=-XT @ EXECUTE and
  ELSE 'z1 z@ 'z2 z@ ZT-ZTEST=-XT @ EXECUTE THEN ;

\ PUBLIC

\ Currently there are no AREL modes.

\ The sign of these tolerances must be plus.
FVARIABLE ZT-XABS-ERROR   1e-12 ZT-XABS-ERROR  f!
FVARIABLE ZT-XREL-ERROR   1e-12 ZT-XREL-ERROR  f!
FVARIABLE ZT-YABS-ERROR   1e-12 ZT-YABS-ERROR  f!
FVARIABLE ZT-YREL-ERROR   1e-12 ZT-YREL-ERROR  f!
FVARIABLE ZT-ZABS-ERROR   1e-12 ZT-ZABS-ERROR  f!
FVARIABLE ZT-ZREL-ERROR   1e-12 ZT-ZREL-ERROR  f!

\ |z1 - z2| < eps
: ZT-ZABS=  ( f: z1 z2 -- ) ( -- flag )  z- |z| ZT-ZABS-ERROR f@ f< ;

\ |zm - zr| < eps * |zr|
true [IF]
\ This method is more accurate when there's no overflow.
: ZT-ZREL=  ( f: zmeas zref -- ) ( -- flag )
  zswap zover z- |z|^2 -frot |z|^2 f/ ZT-ZREL-ERROR f@ f^2 f< ;
[ELSE]
\ This method can avoid some overflows, depending on the
\ implementation Z/ and |Z|.
: ZT-ZREL=  ( f: zmeas zref -- ) ( -- flag )
  zswap zover z- zswap z/ |z| ZT-ZREL-ERROR f@ f< ;
[THEN]

: ZT-XABS=  ( f: x1 x2 -- ) ( -- flag ) f- fabs ZT-XABS-ERROR f@ f< ;
: ZT-YABS=  ( f: y1 y2 -- ) ( -- flag ) f- fabs ZT-YABS-ERROR f@ f< ;

: ZT-XREL=  ( f: xm xr -- ) ( -- flag )
  fswap fover f- fswap f/ fabs ZT-XREL-ERROR f@ f< ;
: ZT-YREL=  ( f: ym yr -- ) ( -- flag )
  fswap fover f- fswap f/ fabs ZT-YREL-ERROR f@ f< ;

: SET-ZT-MODE-XEXACT ( -- ) true to ZT-XYMODE? ['] FT-DATUM= ZT-XTEST=-XT ! ;
: SET-ZT-MODE-YEXACT ( -- ) true to ZT-XYMODE? ['] FT-DATUM= ZT-YTEST=-XT ! ;
: SET-ZT-MODE-ZEXACT ( -- ) SET-ZT-MODE-XEXACT SET-ZT-MODE-YEXACT ;

: SET-ZT-MODE-XABS ( -- ) true to  ZT-XYMODE? ['] ZT-XABS= ZT-XTEST=-XT ! ;
: SET-ZT-MODE-YABS ( -- ) true to  ZT-XYMODE? ['] ZT-YABS= ZT-YTEST=-XT ! ;
: SET-ZT-MODE-ZABS ( -- ) false to ZT-XYMODE? ['] ZT-ZABS= ZT-ZTEST=-XT ! ;

: SET-ZT-MODE-XREL ( -- ) true to  ZT-XYMODE? ['] ZT-XREL= ZT-XTEST=-XT ! ;
: SET-ZT-MODE-YREL ( -- ) true to  ZT-XYMODE? ['] ZT-YREL= ZT-YTEST=-XT ! ;
: SET-ZT-MODE-ZREL ( -- ) false to ZT-XYMODE? ['] ZT-ZREL= ZT-ZTEST=-XT ! ;

SET-ZT-MODE-ZEXACT


\ *** ARRAY WORDS

\ The first array slot has index one, not zero.

\ PUBLIC

\ USER CONFIG DEFAULTS
[UNDEFINED] MAX-ZT-RESULTS  [IF] 32 CONSTANT MAX-ZT-RESULTS  [THEN]

\ Complex arrays begin with a cell-sized count.
HERE 1 CELLS ALLOT FALIGN MAX-ZT-RESULTS  2* FLOATS ALLOT CONSTANT ZT-RESULTS
HERE 1 CELLS ALLOT FALIGN MAX-ZT-RESULTS  2* FLOATS ALLOT CONSTANT ZT-GOALS

\ 'a 'a1 'a2 are array addresses, 'z 'z1 'z2 are element addresses
\ overflow checking to be done elsewhere

: ZT-A!   ( +n 'a -- ) ( f: zn ... z1 -- )
  2dup ! cell+ faligned swap ( 'z n) DUP
  IF  2* floats over + swap
       DO i z! 2 floats +LOOP 
  ELSE 2drop THEN ;

: ZT-A@   ( 'a -- +n ) ( f: -- zn ... z1 )
  dup @ dup >r ( 'a n r: n)
  IF   cell+ faligned r@ 1- 2* floats over + 
       DO i z@ -2 floats +LOOP
  ELSE drop THEN r> ;

: ZT-A<>  ( 'a1 'a2 -- index|-1|0 )
  2dup @ swap @ <> IF 2drop -1 EXIT THEN
  cell+ faligned swap dup @ swap cell+ faligned
  LOCALS| 'z1 #left 'z2 |
  #left ( dim)
  BEGIN  #left
  WHILE  #left 1- to #left
         'z1 dup 2 floats + to 'z1   'z2 dup 2 floats + to 'z2
         ZT-TEST=
  WHILE
  REPEAT ( dim) #left - ( index)
  ELSE   ( dim) drop 0
  THEN ;


\ *** TEST WORDS

\ PUBLIC

: Z{   ( f: <finitials> -- )
(
Save the fp stack <finitials> for restoration by }Z.  Clear
<zresults> and <zgoals> storage to put it in a defined state
for }Z in case Z-> is missing.
)
  fdepth dup MAX-FT-INITIALS > ABORT" TOO MANY FP INITIALS"
  FT-INITIALS ft-a!   0 ZT-RESULTS !   0 ZT-GOALS ! ;

: Z->  ( f: <zresults> -- )
(
Record the depth and content of the fp stack, considered to
consist only of complex floats.  ABORT if the depth is not even.
)
  fdepth dup 1 and ABORT" NONCOMPLEX RESULT"
  dup MAX-ZT-RESULTS 2* > ABORT" TOO MANY COMPLEX RESULTS"
  2/ ZT-RESULTS zt-a! ;

: }Z   ( f: <zgoals> -- <finitials> )
(
Throw an exception if the depth of the fp stack is not even.
Save the fp stack <zgoals>, compare them with the saved
<zresults>, and restore the <finitials>.  Note that when the
comparison corresponds to one of the REL modes, the measured
values must be zresults and the reference values must be zgoals.
)
  fdepth dup 1 and ABORT" NONCOMPLEX GOAL"
  dup MAX-ZT-RESULTS 2* > ABORT" TOO MANY COMPLEX GOALS"
  2/ ZT-GOALS zt-a!
  ZT-RESULTS ZT-GOALS zt-a<> dup ZT-ERROR-INDEX !
  ?dup IF -1 =
    IF   S" WRONG NUMBER OF COMPLEX RESULTS: "
    ELSE S" INCORRECT COMPLEX RESULT: " THEN
    ZT-ERROR
  THEN
  FT-INITIALS ft-a@ ( len) DROP ;

BASE !
\ *** END of ztester.fs