(   Title:  A utiility for testing rfstack effects
     File:  rftester.fs
   Author:  David N. Williams
  License:  Public Domain, John Hayes
  Version:  1.4.3, January 18, 2021
Generated:  January 18, 2021 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.
)

\ *** USAGE
(
PUBLIC INTERFACE WORDS
 
   tests:  RF{  RF->  }RF
           RFT-ABS-TOLERANCE  RFT-REL-TOLERANCE
           RFT-TEST=-XT
           RFT-DATUM=  RFT-ABS=  RFT-REL=  RFT-REL0=
           SET-RFT-MODE-EXACT  SET-RFT-MODE-ABS  SET-RFT-MODE-REL
           SET-RFT-MODE-REL0
  config:  MAX-RFT-INITIALS  MAX-RFT-RESULTS
 
  PUBLIC AUXILIARY WODS
 
   tests:  RFT-TEST=-XT
           RFT-DATUM=  RFT-ABS=  RFT-REL=  RFT-REL0=
  errors:  RFT-ERROR-XT  RFT-ERROR-DEFAULT  RFT-ERROR-INDEX
  arrays:  RFT-INITIALS  RFT-RESULTS  RFT-GOALS
           RFT-A@  RFT-A!  RFT-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
RFT-ERROR-INDEX.  The file rftester-errors.fs does that, and is loaded
by gmpfr-test.fs.

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

The words RF{, RF->, and }RF ignore non-rfstacks.

Many examples can be found in the file gmpfr-test.fs.

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

Here is an example which uses RFT-REL= :

  SET-RFT-MODE-REL
  rf" 1e-6" RFT-REL-TOLERANCE rf!
  rf{ rf" 1.414214" rf-> rf" 2" rf-sqrt }rf

Note that comparisons in this mode are not symmetric.  Measured values
must be in the rfresults, and reference values in the rfgoals.

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

Storage of rfinitials, rfresults, and rfgoals 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-RFT-INITIALS  MAX-RFT-RESULTS

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

Loading rftester.fs does not change BASE.
)
BASE @ DECIMAL

\ *** ERRORS

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

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

: RFT-ERROR RFT-ERROR-XT @ EXECUTE ;  \ vectored error reporting

\ *** COMPARISONS

VARIABLE RFT-TEST=-XT

: RFT-TEST=  (rf: x y -- ) ( -- flag )  RFT-TEST=-XT @ EXECUTE ;

\ The sign of these tolerances must be plus.
rf" 0e0"   RFCONSTANT RFT-ABS-TOLERANCE-DEFAULT
rf" 1e-12" RFCONSTANT RFT-REL-TOLERANCE-DEFAULT
RFVARIABLE RFT-ABS-TOLERANCE   RFT-ABS-TOLERANCE-DEFAULT RFT-ABS-TOLERANCE rf!
RFVARIABLE RFT-REL-TOLERANCE   RFT-REL-TOLERANCE-DEFAULT RFT-REL-TOLERANCE rf!

: RFT-DATUM=  (rf: x y -- ) ( -- flag )
(
Leave TRUE if the two rfloats have equivalent internal representations.
Else leave FALSE.
)
  rf= ;

\ |x - y| < eps
: RFT-ABS=  (rf: x y -- ) ( -- flag )
  rf- |rf| RFT-ABS-TOLERANCE rf@ rf<  ;

\ |m - r| < eps * |r|  (note the asymmetry)
: RFT-REL=  (rf: meas ref -- ) ( -- flag )
  rfswap rf-reldiff |rf| RFT-REL-TOLERANCE rf@ rf< ;

: RFT-REL0=  (rf: meas ref -- ) ( -- flag )
  rfdup rf0= IF RFT-ABS= ELSE RFT-REL= THEN ;

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

SET-RFT-MODE-EXACT

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

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

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

: 0RFT-A  ( +n 'buf -- )  \ assume n<>0
(
Initialize the array buffer for garbage collection by clearing the count
and n, rfelement addresses.
)
  swap 1+ cells over + swap DO 0 i ! 1 cells +LOOP ;

MAX-RFT-INITIALS RFT-INITIALS 0RFT-A
MAX-RFT-RESULTS  RFT-RESULTS  0RFT-A
MAX-RFT-RESULTS  RFT-GOALS    0RFT-A

\ Overflow checking to be done elsewhere.
: RFT-A!  ( +n 'buf -- ) ( rf: rf_[n-1] ... rf_0 -- )
  2dup ! cell+ swap ( 'elems n) dup
  IF   cells over + swap
       DO i rf! 1 cells +LOOP 
  ELSE 2drop THEN ;

: RFT-A@  ( 'buf -- +n ) ( rf: -- rf_[n-1] ... rf_0 )
  dup @ dup >r ( 'buf n r: n)
  IF   cell+  r@ 1- cells over + 
       DO i rf@ -1 cells +LOOP
  ELSE drop THEN r> ;

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

: RFT-A=  ( 'buf1 'buf2 -- 0 true | 0 false | index+1 false )
(
Note that when RFT-TEST=-XT is set to RFT-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 rfstack 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
 RFT-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 rf@ rf@ ( rf: m_index r_index) RFT-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

: RF{  ( rf: rfinitials -- )
(
Save the rfinitials for restoration by }RF, leaving the rfstack empty. 
Clear rfresults and rfgoals storage.
)
  rfdepth dup MAX-RFT-INITIALS > ABORT" TOO MANY RFINITIALS"
  RFT-INITIALS RFT-A!   0 RFT-RESULTS !   0 RFT-GOALS ! ;

: RF->  ( rf: rfesults -- )
(
Save the rfresults, leaving the rfstack empty.
)
  rfdepth dup MAX-RFT-RESULTS > ABORT" TOO MANY RFRESULTS"
  RFT-RESULTS RFT-A! ;

: }RF  ( rf: rfgoals -- rfinitials )
(
Save the rfgoals, compare them with the saved rfresults, and restore the
rfinitials.  If the number of rfresults is not the same as the number of
rfgoals, store zero in RFT-ERROR-INDEX and execute the RFT-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 RFT-ERROR-INDEX and
execute the RFT-ERROR vector. 
)
  rfdepth dup MAX-RFT-RESULTS > ABORT" TOO MANY RFGOALS"
  RFT-GOALS RFT-A!
  RFT-RESULTS RFT-GOALS RFT-A= ( 0 true | 0 false | index+1 false)
  IF
    ( 0) drop
  ELSE
    dup RFT-ERROR-INDEX !
    IF S" INCORRECT RFRESULT: " ELSE S" WRONG NUMBER OF RFRESULTS: " THEN
    RFT-ERROR
  THEN
  RFT-INITIALS RFT-A@ ( len) drop ;

BASE !
\ *** END of rftester.fs