( Title: A utility for testing Forth
floating-point stack effects
File: ftester.fs
Test file: xftester-test.fs
Log file: xftester.log
License: John Hayes, Public Domain
Version: 1.4.3
Revised: January 18, 2021
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 file revises the code for ttester, a utility for testing Forth
words, as developed by several authors. See the file ttester-xf.fs,
version 1.3.0 or later, for history.
This file extracts the part of ttester-xf that deals with the separated
floating-point stack, hereafter called the fp stack, into an independent
ftester module. The code assumes that floating-point support is
present, and the file will not load unles the fp stack is separated, as
required by the Forth 200x standard. An independent xtester module
extracts the part that deals with the data stack. The file xftester.fs
loads the two components, and is functionally equivalent to
ttester-xf.fs.
Words not declared as public are considered to be private, not
guaranteed to be available in future versions of ftester.
PUBLIC INTERFACE WORDS
tests: F{ F-> }F
FT-ABS-TOLERANCE FT-REL-TOLERANCE FT-AREL-TOLERANCE
SET-FT-MODE-EXACT SET-FT-MODE-ABS
SET-FT-MODE-REL SET-FT-MODE-AREL SET-FT-MODE-REL0
config: MAX-FT-INITIALS MAX-FT-RESULTS
PUBLIC AUXILIARY WORDS
tests: FT-TEST=-XT
FT-DATUM= FT-ABS= FT-REL= FT-AREL= FT-REL0=
errors: FT-ERROR-XT FT-ERROR-DEFAULT FT-ERROR-INDEX
arrays: FT-INITIALS FT-RESULTS FT-GOALS
FT-A@ FT-A! FT-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
FT-ERROR-INDEX. The file ftester-errors.fs does that, and is loaded by
xftester-test.fs.
The basic test usage takes the form:
)
\ ( finitials) F{ F-> }F ( finitials)
(
Angle brackets around an fp stack data designation indicate code that
produces the data. Here finitials stands for possibly nonempty fp stack
contents at the start of the test. The sequence starting with F{ saves
the finitials and removes them from the fp stack, executes the code
that produces the fp stack fresults, saves and removes the
fresults from the fp stack, executes the code that produces the
fp stack fgoals, saves and removes them, compares the saved fresults and
fgoals, reports when there is a discrepancy between the two, and
restores the saved finitials.
For example:
F{ 1E 2E fswap F-> 2E 1E }F ok
F{ 1E 2E fswap F-> 2E 2E }F INCORRECT FRESULT: F{ 1E 2E fswap F-> 2E 2E }F ok
F{ 1E 2E fswap F-> 2E }F WRONG NUMBER OF FRESULTS: F{ 1E 2E fswap F-> 2E }F ok
Effects present or produced on non-fp stacks before F{, F->, or }F are
simply ignored by those words.
More examples can be found in the file xftester-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-FT-MODE-EXACT [the default]. If one of the included
approximate equality tests is desired, execute SET-FT-MODE-ABS,
SET-FT-MODE-REL, SET-FT-MODE-AREL, or SET-FT-MODE-REL0. Corresponding
to these, the public fvariables FT-ABS-TOLERANCE, FT-REL-TOLERANCE, and
FT-AREL-TOLERANCE contain the values to be used in comparisons by the
words FT-ABS=, FT-REL=, and FT-AREL=. FT-REL0= conditionally executes
both FT-ABS= and FT-REL=.
Here is an example which uses FT-REL=:
SET-FT-MODE-REL
1E-6 FT-REL-TOLERANCE F!
F{ S" 3.14159" >FLOAT DROP F-> -1E FACOS }F
Note that comparisons in this mode are not symmetric. Measured values
must be in the fresults, and reference values in the fgoals.
The user may supply a different equality test by storing his own xt in
the public variable FT-TEST=-XT.
Storage of finitials, fresults, and fgoals includes overflow checking.
The user can change the default storage allocation by defining one or
both of the following constants *before* loading this file:
MAX-FT-INITIALS MAX-FT-RESULTS
The default xt's and tolerances can be changed after loading this file.
Loading ftester.fs does not change BASE. Remember that floating-point
input is ambiguous if the base is not decimal.
Ftester uses the same limited set of non-CORE words as the fp stack
section of ttester, plus [UNDEFINED], and 2R>. See xftester.fs for the
list.
TABLE OF CONTENTS
FTESTER
F.1 ERRORS
F.2 COMPARISONS
F.3 ARRAYS
F.4 TESTS
)
BASE @ DECIMAL
\ *** FTESTER
DEPTH 1E DEPTH 1- FDROP = 0=
[IF] .( FLOATING-STACK REQUIRED) ABORT [THEN]
\ *** F.1 ERRORS
(
Error reporting in xftester is unavoidably different from that in
ttester, because xftester does not use a common execution vector for
data and fp stack reports. That of course does not affect compatibility
as long as no errors occur.
)
\ PUBLIC
\ vectored error reporting
VARIABLE FT-ERROR-XT
VARIABLE FT-ERROR-INDEX \ set to zero after unequal array size
\ comparison, or [index+1] after deepest
\ unequal element comparison at index
: FT-ERROR-DEFAULT ( c-addr u -- )
(
Display an error message followed by the line that had the error.
)
TYPE SOURCE TYPE CR ;
' FT-ERROR-DEFAULT FT-ERROR-XT !
\ PRIVATE
: FT-ERROR ( c-addr u -- ) FT-ERROR-XT @ EXECUTE ;
\ *** F.2 COMPARISONS
(
The public words in this section provide an alternative to the ttester
fp equality tests. The xftester default is the same exact equality as
that of ttester.
)
\ PUBLIC
VARIABLE FT-TEST=-XT
\ PRIVATE
: FT-TEST= ( f: x y -- ) ( -- flag ) FT-TEST=-XT @ EXECUTE ;
\ PUBLIC
\ The sign of these tolerances must be plus.
FVARIABLE FT-ABS-TOLERANCE 0E FT-ABS-TOLERANCE F!
FVARIABLE FT-REL-TOLERANCE 1E-12 FT-REL-TOLERANCE F!
FVARIABLE FT-AREL-TOLERANCE 1E-12 FT-AREL-TOLERANCE F!
\ PUBLIC
(
Leave TRUE if the two floats have the same internal representation,
including the IEEE-FP 2008 special data, signed NAN with load, and
signed zero and infinity. Else leave FALSE.
FDATUM= is a candidate for alternate definition.
Whether the specials work with F~ is implementation dependent, according
to DPANS94.
)
[DEFINED] FDATUM= [IF]
: FT-DATUM= ( f: x y -- ) ( -- flag ) FDATUM= ;
[ELSE]
: FT-DATUM= ( f: x y -- ) ( -- flag ) 0E F~ ;
[THEN]
\ |x - y| < eps
: FT-ABS= ( f: x y -- ) ( -- flag ) FT-ABS-TOLERANCE F@ F~ ;
\ |m - r| < eps * |r|
: FT-REL= ( f: meas ref -- ) ( -- flag )
FSWAP FOVER F- FSWAP F/ FABS FT-REL-TOLERANCE F@ F< ;
\ |x - y| < eps * (|x| + |y|)/2
: FT-AREL= ( f: x y -- ) ( -- flag )
FT-AREL-TOLERANCE F@ FNEGATE 2E F/ F~ ;
: FT-REL0= ( f: meas ref -- ) ( -- flag ) \ Krishna Myneni
FDUP F0= IF FT-ABS= ELSE FT-REL= THEN ;
: SET-FT-MODE-EXACT ( -- ) ['] FT-DATUM= FT-TEST=-XT ! ;
: SET-FT-MODE-ABS ( -- ) ['] FT-ABS= FT-TEST=-XT ! ;
: SET-FT-MODE-REL ( -- ) ['] FT-REL= FT-TEST=-XT ! ;
: SET-FT-MODE-AREL ( -- ) ['] FT-AREL= FT-TEST=-XT ! ;
: SET-FT-MODE-REL0 ( -- ) ['] FT-REL0= FT-TEST=-XT ! ;
SET-FT-MODE-EXACT
\ *** F.3 ARRAYS
(
The arrays used for fp stack finitials, fgoals, and fresults are one-
dimensional, with float-sized elements. The first cell contains the
count, followed by the array elements, starting at the next FALIGNED
address. We call this collection the array buffer. Array indices,
referred to as "index" in stack comments, are zero-based. A tick prefix
in stack comments means "address".
)
\ PUBLIC
\ USER CONFIG DEFAULTS
[UNDEFINED] MAX-FT-INITIALS [IF] 32 CONSTANT MAX-FT-INITIALS [THEN]
[UNDEFINED] MAX-FT-RESULTS [IF] 32 CONSTANT MAX-FT-RESULTS [THEN]
\ ARRAY BUFFERS
CREATE FT-INITIALS 1 CELLS ALLOT FALIGN MAX-FT-INITIALS FLOATS ALLOT
CREATE FT-RESULTS 1 CELLS ALLOT FALIGN MAX-FT-RESULTS FLOATS ALLOT
CREATE FT-GOALS 1 CELLS ALLOT FALIGN MAX-FT-RESULTS FLOATS ALLOT
\ Overflow checking to be done elsewhere.
: FT-A! ( +n 'buf -- ) ( f: r_[n-1] ... r_0 -- )
2DUP ! CELL+ FALIGNED SWAP ( 'elems n) DUP
IF FLOATS OVER + SWAP
DO I F! 1 FLOATS +LOOP
ELSE 2DROP THEN ;
: FT-A@ ( 'buf -- +n ) ( f: -- r_[n-1] ... r_0 )
DUP @ DUP >R ( 'buf n r: n)
IF CELL+ FALIGNED R@ 1- FLOATS OVER +
DO I F@ -1 FLOATS +LOOP
ELSE DROP THEN R> ;
[UNDEFINED] FLOAT- [IF]
: FLOAT- ( addr -- addr-float ) [ 1 FLOATS ] LITERAL - ;
[THEN]
: FT-A= ( 'buf1 'buf2 -- 0 true | 0 false | index+1 false )
(
Note that when FT-TEST=-XT is set to FT-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 fp 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
FT-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) 1- >R \ last index = count - 1
CELL+ FALIGNED R@ FLOATS + SWAP
CELL+ FALIGNED R@ FLOATS + 0 R>
( 0 true 'r_last 'm_last 0 last)
DO ( 0 true 'r_i 'm_i) \ i = index
2DUP F@ F@ FT-TEST= 0=
IF \ unequal elements
2DROP ( 0 true) 2DROP I 1+ FALSE 0 0 LEAVE THEN
FLOAT- SWAP FLOAT- SWAP ( 'r_[i-1] 'm_[i-1])
-1 +LOOP
( [0 true | i+1 false] x1 x2) 2DROP ;
\ *** F.4 TESTS
\ PUBLIC
: F{ ( f: finitials -- )
(
Save the fp stack finitials for restoration by }F, leaving the fp stack
empty. Clear fresults and fgoals storage.
)
FDEPTH DUP MAX-FT-INITIALS > ABORT" TOO MANY FINITIALS"
FT-INITIALS FT-A! 0 FT-RESULTS ! 0 FT-GOALS ! ;
: F-> ( f: fresults -- )
(
Save the fp stack fresults, leaving the fp stack empty.
)
FDEPTH DUP MAX-FT-RESULTS > ABORT" TOO MANY FRESULTS"
FT-RESULTS FT-A! ;
: }F ( f: fgoals -- finitials )
(
Save the fp stack fgoals, compare them with the saved fresults, and
restore the finitials. If the number of fresults is not the same as the
number of fgoals, store zero in FT-ERROR-INDEX and execute the FT-ERROR
vector. If the numbers are the same but there is a deepest comparison
failure at the index-th element, store index+1 in FT-ERROR-INDEX and
execute the FT-ERROR vector.
)
FDEPTH DUP MAX-FT-RESULTS > ABORT" TOO MANY FGOALS"
FT-GOALS FT-A!
FT-RESULTS FT-GOALS FT-A= ( 0 true | 0 false | index+1 false)
IF
( 0) DROP
ELSE
DUP FT-ERROR-INDEX !
IF S" INCORRECT FRESULT: " ELSE S" WRONG NUMBER OF FRESULTS: " THEN
FT-ERROR
THEN
FT-INITIALS FT-A@ ( len) DROP ;
BASE !
\ *** END of ftester.fs