(   Title:  A utiility for testing %f%stack effects
     File:  %f%tester.fs
   Author:  David N. Williams
  License:  Public Domain, John Hayes
  Version:  1.4.3, January 18, 2021
Generated:  %DATE% from fptester.tmpl

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 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.

The rest is public domain, based on the ttester derivative by Anton Ertl
and its xftester derivative by David N. Williams.  Explanatory material
was provided by C. G. Montgomery in March, 2009, with helpful comments
from Krishna Myneni.
)

\ *** HOW TO GENERATE A NEW FP TESTER
(
This file is a template for generating two Hayes-style testers, for
floating-point words that operate on one of the Forth-gmpfr stacks of
cell-sized record pointers for gmp floats or mpfr reliable floats.  It
is to be translated by substituting replacements for text elements
including a leading and trailing % as in %NAME%, for example, by using
the search and replace function of a text editor, or a script based on
the Forth 2012 words SUBSTITUTE and REPLACES.

There are two essential substitutions, one for %F% and one for %f%,
which are to be replaced by the upper and lower case versions,
respectively, of a text token not containing white space.  The date of
generation can also be substituted for %DATE%, which appears only in the
header above; and the test file for the tester should be substituted for
%TESTER-TEST% in the USAGE section below.

The code assumes that fetch, store, equality, stack depth and a few
other words are defined for the separated stack, with names resulting
from the substitutions in patterns such as %f%@, %f%!, %f%=, and
%f%depth or %F%DEPTH.

There is a little bit of code that is needed to initialize arrays used
to store data from stacks that are consistent with our garbage-collected
record stack scheme.  Although this template is currently applied only
to such stacks, that code is marked as REMOVABLE FOR STACKS WITH NO GC.

This section, HOW TO GENERATE A NEW FP TESTER, should be removed from
the generated file.  In any case, if its text undergoes substitution, it
will become incoherent.  The copyright and license in the header above
should be retained.
)

\ *** USAGE
(
PUBLIC INTERFACE WORDS
 
   tests:  %F%{  %F%->  }%F%
           %F%T-ABS-TOLERANCE  %F%T-REL-TOLERANCE
           %F%T-TEST=-XT
           %F%T-DATUM=  %F%T-ABS=  %F%T-REL=  %F%T-REL0=
           SET-%F%T-MODE-EXACT  SET-%F%T-MODE-ABS  SET-%F%T-MODE-REL
           SET-%F%T-MODE-REL0
  config:  MAX-%F%T-INITIALS  MAX-%F%T-RESULTS
 
  PUBLIC AUXILIARY WODS
 
   tests:  %F%T-TEST=-XT
           %F%T-DATUM=  %F%T-ABS=  %F%T-REL=  %F%T-REL0=
  errors:  %F%T-ERROR-XT  %F%T-ERROR-DEFAULT  %F%T-ERROR-INDEX
  arrays:  %F%T-INITIALS  %F%T-RESULTS  %F%T-GOALS
           %F%T-A@  %F%T-A!  %F%T-A=

The public interface words are all that are needed for normal testing,
including using the built-in fp comparisons and changing their
tolerances.

The public auxiliary words are made available for users who want to add
fp comparisons, or to implement more elaborate error reporting, such as
counting errors, or dumping fp results and goals when something is
wrong, or reporting a particular fp error with the help of
%F%T-ERROR-INDEX.  The file %f%tester-errors.fs does that, and is loaded
by %TESTER-TEST%.fs.

The basic test usage takes the form:
)
\   ( %f%initials) %F%{ <%f%results> %F%-> <%f%goals> }%F% ( %f%initials)
(
Angle brackets around a data designation for a particular stack indicate
code that produces the data.  Here %f%initials stands for possibly
nonempty %f%stack contents at the start of the test.  The sequence
starting with %F%{ saves the %f%initials and removes them from the %f%stack,
executes the code <%f%results> that produces the %f%stack %f%results, saves
and removes the %f%results from the %f%stack, executes the <%f%goals> code
that produces the %f%stack %f%goals, saves and removes them, compares the
saved %f%results and %f%goals, reports when there is a discrepancy between
the two, and restores the saved %f%initials.

The words %F%{, %F%->, and }%F% ignore non-%f%stacks.

Many examples can be found in the file %TESTER-TEST%.

Floating-point testing can involve further complications.  There are the
perennial issues of floating-point value comparisons.  Exact equality is
specified by SET-%F%T-MODE-EXACT [the default].  If one of the included
approximate equality tests is desired, execute SET-%F%T-MODE-ABS,
SET-%F%T-MODE-REL, SET-%F%T-MODE-AREL, or SET-%F%T-MODE-REL0.  Corresponding
to these, the public fvariables %F%T-ABS-TOLERANCE, %F%T-REL-TOLERANCE, and
%F%T-AREL-TOLERANCE contain the values to be used in comparisons by the
words %F%T-ABS=, %F%T-REL=, and %F%T-AREL=.  %F%T-REL0= conditionally executes
both %F%T-ABS= and %F%T-REL=.

Here is an example which uses %F%T-REL= :

  SET-%F%T-MODE-REL
  %f%" 1e-6" %F%T-REL-TOLERANCE %f%!
  %f%{ %f%" 1.414214" %f%-> %f%" 2" %f%-sqrt }%f%

Note that comparisons in this mode are not symmetric.  Measured values
must be in the %f%results, and reference values in the %f%goals.

The user may supply a different equality test by storing his own xt in
the public variable %F%T-TEST=-XT.

Storage of %f%initials, %f%results, and %f%goals includes overflow
checking. The user can change the default storage allocation by defining
one or both of the following CONSTANT's *before* loading this file:

  MAX-%F%T-INITIALS  MAX-%F%T-RESULTS

The default xt's and tolerances can be changed after loading this file.

Loading %f%tester.fs does not change BASE.
)
BASE @ DECIMAL

\ *** ERRORS

VARIABLE %F%T-ERROR-XT
VARIABLE %F%T-ERROR-INDEX  \ set to zero after unequal array size
                           \ comparison, or [index+1] after deepest
                           \ unequal element comparison at index

: %F%T-ERROR-DEFAULT  ( c-addr u -- )
(
Display an error message followed by the line that had the error.
)
  TYPE SOURCE TYPE CR ;
' %F%T-ERROR-DEFAULT %F%T-ERROR-XT !

: %F%T-ERROR %F%T-ERROR-XT @ EXECUTE ;  \ vectored error reporting

\ *** COMPARISONS

VARIABLE %F%T-TEST=-XT

: %F%T-TEST=  (%f%: x y -- ) ( -- flag )  %F%T-TEST=-XT @ EXECUTE ;

\ The sign of these tolerances must be plus.
%f%" 0e0"   %F%CONSTANT %F%T-ABS-TOLERANCE-DEFAULT
%f%" 1e-12" %F%CONSTANT %F%T-REL-TOLERANCE-DEFAULT
%F%VARIABLE %F%T-ABS-TOLERANCE   %F%T-ABS-TOLERANCE-DEFAULT %F%T-ABS-TOLERANCE %f%!
%F%VARIABLE %F%T-REL-TOLERANCE   %F%T-REL-TOLERANCE-DEFAULT %F%T-REL-TOLERANCE %f%!

: %F%T-DATUM=  (%f%: x y -- ) ( -- flag )
(
Leave TRUE if the two %f%loats have equivalent internal representations.
Else leave FALSE.
)
  %f%= ;

\ |x - y| < eps
: %F%T-ABS=  (%f%: x y -- ) ( -- flag )
  %f%- |%f%| %F%T-ABS-TOLERANCE %f%@ %f%<  ;

\ |m - r| < eps * |r|  (note the asymmetry)
: %F%T-REL=  (%f%: meas ref -- ) ( -- flag )
  %f%swap %f%-reldiff |%f%| %F%T-REL-TOLERANCE %f%@ %f%< ;

: %F%T-REL0=  (%f%: meas ref -- ) ( -- flag )
  %f%dup %f%0= IF %F%T-ABS= ELSE %F%T-REL= THEN ;

: SET-%F%T-MODE-EXACT ( -- )  ['] %F%T-DATUM= %F%T-TEST=-XT ! ;
: SET-%F%T-MODE-ABS   ( -- )  ['] %F%T-ABS=   %F%T-TEST=-XT ! ;
: SET-%F%T-MODE-REL   ( -- )  ['] %F%T-REL=   %F%T-TEST=-XT ! ;
: SET-%F%T-MODE-REL0  ( -- )  ['] %F%T-REL0=  %F%T-TEST=-XT ! ;

SET-%F%T-MODE-EXACT

\ *** ARRAYS
(
The first array slot has index zero.  A tick prefix in stack somments
means "address".
)

\ USER CONFIG DEFAULTS
[UNDEFINED] MAX-%F%T-INITIALS [IF] 32 CONSTANT MAX-%F%T-INITIALS [THEN]
[UNDEFINED] MAX-%F%T-RESULTS  [IF] 32 CONSTANT MAX-%F%T-RESULTS  [THEN]

\ Array buffers begin with a cell-sized count.
CREATE %F%T-INITIALS MAX-%F%T-INITIALS 1+ CELLS ALLOT
CREATE %F%T-RESULTS  MAX-%F%T-RESULTS  1+ CELLS ALLOT
CREATE %F%T-GOALS    MAX-%F%T-RESULTS  1+ CELLS ALLOT

\ BEGIN:  REMOVABLE FOR STACKS WITH NO GC
: 0%F%T-A  ( +n 'buf -- )  \ assume n<>0
(
Initialize the array buffer for garbage collection by clearing the count
and n, %f%element addresses.
)
  swap 1+ cells over + swap DO 0 i ! 1 cells +LOOP ;

MAX-%F%T-INITIALS %F%T-INITIALS 0%F%T-A
MAX-%F%T-RESULTS  %F%T-RESULTS  0%F%T-A
MAX-%F%T-RESULTS  %F%T-GOALS    0%F%T-A
\ END:  REMOVABLE FOR STACKS WITH NO GC

\ Overflow checking to be done elsewhere.
: %F%T-A!  ( +n 'buf -- ) ( %f%: %f%_[n-1] ... %f%_0 -- )
  2dup ! cell+ swap ( 'elems n) dup
  IF   cells over + swap
       DO i %f%! 1 cells +LOOP 
  ELSE 2drop THEN ;

: %F%T-A@  ( 'buf -- +n ) ( %f%: -- %f%_[n-1] ... %f%_0 )
  dup @ dup >r ( 'buf n r: n)
  IF   cell+  r@ 1- cells over + 
       DO i %f%@ -1 cells +LOOP
  ELSE drop THEN r> ;

[UNDEFINED] CELL- [IF]
  : CELL-  ( addr -- addr-cell )  [ 1 CELLS ] LITERAL - ;
[THEN]

: %F%T-A=  ( 'buf1 'buf2 -- 0 true | 0 false | index+1 false )
(
Note that when %F%T-TEST=-XT is set to %F%T-REL=, the comparison is not
symmetric; so the elements of the measured and reference array buffers
at 'buf1 and 'buf2, respectively, must be fetched to the %f%stack in
proper order.  In the stack comments below, "m" and "r" stand for
"measured" and "reference", to keep track in case the comparison xt is
 %F%T-REL=.

Returns:
         0 true:  equal size and elements
        0 false:  sizes unequal
  index+1 false:  sizes equal, deepest unequal elements at index
)
  2dup @ swap @ <>
  IF 2drop 0 false EXIT THEN          \ unequal size
  dup @ 0= IF 2drop 0 true EXIT THEN  \ equal size and empty
  2>r 0 true 2r>
  ( 0 true 'buf1 'buf2)
  dup @ ( count) >r    \ last index + 1 = count
  r@ cells + swap   r@ cells +   1 r>
  ( 0 true 'r_last 'm_last 1 last+1)
  DO  ( 0 true 'r_index 'm_index) \ i = index+1
    2dup %f%@ %f%@ ( %f%: m_index r_index) %F%T-TEST= 0=
    IF  \ unequal elements
      2drop ( 0 true) 2drop i false 0 0 LEAVE
    THEN
    cell- swap cell- swap ( 'r_[index-1] 'm_[index-1])
  -1 +LOOP
  ( [0 true | index+1 false] x1 x2) 2drop ;

\ *** TESTS

: %F%{  ( %f%: %f%initials -- )
(
Save the %f%initials for restoration by }%F%, leaving the %f%stack empty. 
Clear %f%results and %f%goals storage.
)
  %f%depth dup MAX-%F%T-INITIALS > ABORT" TOO MANY %F%INITIALS"
  %F%T-INITIALS %F%T-A!   0 %F%T-RESULTS !   0 %F%T-GOALS ! ;

: %F%->  ( %f%: %f%esults -- )
(
Save the %f%results, leaving the %f%stack empty.
)
  %f%depth dup MAX-%F%T-RESULTS > ABORT" TOO MANY %F%RESULTS"
  %F%T-RESULTS %F%T-A! ;

: }%F%  ( %f%: %f%goals -- %f%initials )
(
Save the %f%goals, compare them with the saved %f%results, and restore the
%f%initials.  If the number of %f%results is not the same as the number of
%f%goals, store zero in %F%T-ERROR-INDEX and execute the %F%T-ERROR vector. 
Else, if the numbers are the same but there is a deepest comparison
failure at the index-th element, store index+1 in %F%T-ERROR-INDEX and
execute the %F%T-ERROR vector. 
)
  %f%depth dup MAX-%F%T-RESULTS > ABORT" TOO MANY %F%GOALS"
  %F%T-GOALS %F%T-A!
  %F%T-RESULTS %F%T-GOALS %F%T-A= ( 0 true | 0 false | index+1 false)
  IF
    ( 0) drop
  ELSE
    dup %F%T-ERROR-INDEX !
    IF S" INCORRECT %F%RESULT: " ELSE S" WRONG NUMBER OF %F%RESULTS: " THEN
    %F%T-ERROR
  THEN
  %F%T-INITIALS %F%T-A@ ( len) drop ;

BASE !
\ *** END of %f%tester.fs