(    Title:  Tests for xftester and ttester-xf
      File:  xftester-test.fs
  Log file:  xftester.log
    Author:  David N. Williams
   License:  Public Domain
   Version:  1.4.3
   Revised:  January 22, 2021

These tests are not as strict about minimizing the use of non-CORE
words, or non-FLOATING words for floating point, as is ttester-xf
itself.
)
decimal


\ *** USER CONFIG

\ Tester signatures.  Uncomment exactly one line.
   : TTESTER-XF ;  \ includes deprecated comparison words
\ : XFTESTER ;
\ : XFR-TESTER ;   \ FDATUM= does not use F~

[DEFINED] -VERBOSEINCLUDE [IF] -VERBOSEINCLUDE [THEN]  \ vfx

\ Forth host detection, VERBOSE initialization, comment support.
INCLUDE tester-display.fs
REDEFINED-WARNING-OFF
true VERBOSE !

?.FIRST-CR  \ before the first displayed line
?." Host: " host-s ?type ?.cr


\ *** DEBUGGING

[UNDEFINED] \\ [IF]
: \\  ( -- )  -1 parse 2drop BEGIN refill 0= UNTIL ; [THEN]
[UNDEFINED] .# [IF]
: .#  ( n -- )  cr ." #" . cr ; [THEN]


\ *** INCLUDES

 2 CONSTANT MAX-XT-INITIALS
 2 CONSTANT MAX-FT-INITIALS
\ We use values because we want to make these smaller later:
16 VALUE MAX-XT-RESULTS   16 VALUE MAX-FT-RESULTS

\ to test BASE invariance
13 CONSTANT thirteen  thirteen BASE !

[DEFINED] TTESTER-XF [IF]
INCLUDE ttester-xf.fs   ?." Using ttester-xf.fs.
[THEN]
[DEFINED] XFTESTER [IF]
INCLUDE xftester.fs     ?." Using xftester.fs.
[THEN]
[DEFINED] XFR-TESTER  [IF]
INCLUDE xfr-tester.fs   ?." Using xfr-tester.fs.
[THEN]
INCLUDE xtester-errors.fs
HAS-FLOATING [IF]
INCLUDE ftester-errors.fs
[THEN]

X{ BASE @ X-> thirteen }X
T{ BASE @  -> thirteen }T
decimal

: ?.errors  ( -- )
  blue-text s" Unexpected " ?type ?.xt-errors ?.cr
[ HAS-FLOATING ] [IF]
  blue-text s" Unexpected " ?type ?.ft-errors ?.cr
[THEN] ;

\ less elaborate errors
\ ' XT-ERROR1 XT-ERROR-XT !
\ HAS-FLOATING [IF] ' FT-ERROR1 FT-ERROR-XT ! [THEN]


\ *** TESTS

\ scratch
VARIABLE v1  VARIABLE v2  VARIABLE v3
HAS-FLOATING [IF] FVARIABLE fv1  FVARIABLE fv2 [THEN]

TESTING  HAS-FLOATING
(
The following test passes when HAS-FLOATING is a well-formed flag.  The
false case can be tested with PFE by commenting out both LOADM lines
near the top of this file.
)

T{ [DEFINED] F+ -> HAS-FLOATING }T

(
The tests in the next two sections are copies of tests in
xfarray-test.fs that already passed with the gforth cvs version 1.1.6 of
ttester.  Failure would mean a bug in a component of T{, ->, or }T.
)

TESTING  XT-A= XT-A@ XT-A!

CREATE []         0 ,
CREATE [0]        1 ,  0 ,
CREATE [10]       1 , 10 ,
CREATE [10,11]    2 , 10 , 11 ,
CREATE [10,1]     2 , 10 ,  1 ,
CREATE [0,11]     2 ,  0 , 11 ,
CREATE [0,1]      2 ,  0 ,  1 ,
CREATE [10,11,12] 3 , 10 , 11 , 12 ,
CREATE [1,11,12]  3 ,  1 , 11 , 12 ,
CREATE [1,1,12]   3 ,  1 ,  1 , 12 ,
CREATE [1,11,2]   3 ,  1 , 11 ,  2 ,

\ XT-A= Returns
\         0 true:  equal size and elements
\        0 false:  sizes unequal
\  index+1 false:  sizes equal, deepest unequal elements at index

\ different length
T{ []    [10,11,12] XT-A= -> 0 false }T
T{ [10]  [10,1]     XT-A= -> 0 false }T
T{ [10]  [10,11,12] XT-A= -> 0 false }T

\ last different at index 0
T{ [0]        [10]      XT-A= -> 1 false }T
T{ [10,1]     [0,1]     XT-A= -> 1 false }T
T{ [10,11,12] [1,11,12] XT-A= -> 1 false }T

\ last different at index 1
T{ [10,1]     [10,11]   XT-A= -> 2 false }T
T{ [10,1]     [0,11]    XT-A= -> 2 false }T
T{ [1,1,12]   [1,11,12] XT-A= -> 2 false }T
T{ [10,11,12] [1,1,12]  XT-A= -> 2 false }T

\ last different at index 2
T{ [1,11,12] [1,11,2] XT-A= -> 3 false }T
T{ [1,1,12]  [1,11,2] XT-A= -> 3 false }T

\ the same
T{ []         []         XT-A= -> 0 true }T
T{ [10]       [10]       XT-A= -> 0 true }T
T{ [10,11,12] [10,11,12] XT-A= -> 0 true }T

T{ []         XT-A@ -> 0 }T
T{ [10]       XT-A@ -> 10 1 }T
T{ [10,11]    XT-A@ -> 11 10 2 }T
T{ [10,11,12] XT-A@ -> 12 11 10 3 }T

create max3array 4 cells allot
T{ 3  2  1 3 max3array XT-A! max3array XT-A@ -> 3  2  1 3 }T
T{   11 10 2 max3array XT-A! max3array XT-A@ -> 11 10 2 }T
T{       0 1 max3array XT-A! max3array XT-A@ -> 0 1 }T
T{         0 max3array XT-A! max3array XT-A@ -> 0 }T
\ xarray overwrite?
T{ -1 -1 -1 3 max3array XT-A! -> }T
T{     0  0 2 max3array XT-A! -> }T
T{ max3array 2 cells + 2@ -> -1 0 }T

HAS-FLOATING [IF]

TESTING  SET-FT-MODE-EXACT FT-A= FT-A@ FT-A!

\ default is exact 
T{ FT-TEST=-XT @ -> ' FT-DATUM= }T

0 FT-TEST=-XT !
T{ SET-FT-MODE-EXACT FT-TEST=-XT @ -> ' FT-DATUM= }T

: FARRAY  ( +n -- ) ( f: x_[n-1] ... x_0 -- )
  CREATE dup , falign here >r floats allot here r>
  ?DO i f! 1 floats +LOOP ;

0             FARRAY f[]
1 0E          FARRAY f[0]
1 10E         FARRAY f[10]
2 11E 10E     FARRAY f[10,11]
2  1E 10E     FARRAY f[10,1]
2 11E  0E     FARRAY f[0,11]
2  1E  0E     FARRAY f[0,1]
3 12E 11E 10E FARRAY f[10,11,12]
3 12E 11E  1E FARRAY f[1,11,12]
3 12E  1E  1E FARRAY f[1,1,12]
3  2E 11E  1E FARRAY f[1,11,2]
3  1E  1E  1E FARRAY f[1,1,1]
3  2E  2E  2E FARRAY f[2,2,2]
3  1E  2E  2E FARRAY f[2,2,1]
3  1E  1E  2E FARRAY f[2,1,1]

\ FT-A= Returns
\        0 true:  equal size and elements
\       0 false:  sizes unequal
\ index+1 false:  sizes equal, deepest unequal elements at index

\ different length
T{ f[]    f[10,11,12] FT-A= -> 0 false }T
T{ f[10]  f[10,1]     FT-A= -> 0 false }T
T{ f[10]  f[10,11,12] FT-A= -> 0 false }T

\ last different at index 0
T{ f[0]        f[10]      FT-A= -> 1 false }T
T{ f[10,1]     f[0,1]     FT-A= -> 1 false }T
T{ f[10,11,12] f[1,11,12] FT-A= -> 1 false }T

\ last different at index 1
T{ f[10,1]     f[10,11]   FT-A= -> 2 false }T
T{ f[10,1]     f[0,11]    FT-A= -> 2 false }T
T{ f[1,1,12]   f[1,11,12] FT-A= -> 2 false }T
T{ f[10,11,12] f[1,1,12]  FT-A= -> 2 false }T

\ last different at index 2
T{ f[1,11,12] f[1,11,2] FT-A= -> 3 false }T
T{ f[1,1,12]  f[1,11,2] FT-A= -> 3 false }T

\ the same
T{ f[]         f[]         FT-A= -> 0 true }T
T{ f[10]       f[10]       FT-A= -> 0 true }T
T{ f[10,11,12] f[10,11,12] FT-A= -> 0 true }T

T{ f[]         FT-A@ -> 0 }T
T{ f[10]       FT-A@ -> 10E 1 }T
T{ f[10,11]    FT-A@ -> 11E 10E 2 }T
T{ f[10,11,12] FT-A@ -> 12E 11E 10E 3 }T

CREATE max3farray 1 cells allot falign 3 floats allot
T{ 3E  2E  1E 3 max3farray FT-A! max3farray FT-A@ ->  3E  2E  1E 3 }T
T{    11E 10E 2 max3farray FT-A! max3farray FT-A@ -> 11E 10E 2 }T
T{         0E 1 max3farray FT-A! max3farray FT-A@ ->  0E 1 }T
T{            0 max3farray FT-A! max3farray FT-A@ ->  0 }T
\ farray overwrite?
T{ -1E -1E -1E 3 max3farray FT-A! -> }T
T{      0E  0E 2 max3farray FT-A! -> }T
T{ max3farray cell+ faligned float+ dup f@ float+ f@ -> 0E -1E }T

TESTING  proper relative comparison order for FT-A= 
(
Test whether FT-A= keeps the proper order for successive non-symmetric
array element comparisons when FT-TEST-XT is set to FT-REL-ERROR.

  when meas = 1 and ref = 2:
  rel_error = |1 - 2| / 2 = 0.5 < 0.75

  when meas = 2 and ref = 1:
  rel_error = |2 - 1| / 1 = 1.0 > 0.75
)

[THEN]  \ HAS-FLOATING

TESTING  X{ X-> }X

X{ X-> }X
X{ 1 X-> 1 }X
X{ 1 2 3 1 X-> 1 2 3 1 }X

\ initial data stack preservation up to MAX-XT-INITIALS
X{ 3 X-> 3 }X
depth v1 ! X{ v1 @ X-> 0 }X
1 X{ 3 X-> 3 }X
v1 ! depth v2 !
X{ v1 @ v2 @ X-> 1 0 }X
1 2 X{ 3 X-> 3 }X
v1 ! v2 ! depth v3 !
X{ v1 @ v2 @ v3 @ X-> 2 1 0 }X

HAS-FLOATING [IF]

TESTING  F{ F-> }F

T{ SET-FT-MODE-EXACT -> }T

F{ F-> }F
F{ 1E F-> 1E }F
F{ 1E 2E 3E 1E F-> 1E 2E 3E 1E }F

\ initial fp stack preservation up to MAX-FT-INITIALS
F{ 3E F-> 3E }F
fdepth v1 !
X{ v1 @ X-> 0 }X

1E F{ 3E F-> 3E }F
fv1 f! fdepth v2 !
T{ fv1 f@ v2 @ -> 1E 0 }T

1E 2E F{ 3E F-> 3E }F
fv1 f! fv2 f! fdepth v1 !
T{ fv1 f@ fv2 f@ v1 @ -> 2E 1E 0 }T

[THEN]  \ HAS-FLOATING

TESTING  T{ -> }T

T{ -> }T
T{ 1 -> 1 }T

HAS-FLOATING [IF]
SET-FT-MODE-EXACT

T{ 1E -> 1E }T
T{ 1 1E -> 1E 1 }T

depth v1 ! fdepth v2 !
T{ v1 @ v2 @ -> 0 0 }T
11 T{ 1 1E -> 1E 1 }T
v1 ! depth v2 ! fdepth v3 !
T{ v1 @ v2 @ v3 @ -> 11 0 0 }T

11E T{ 2 2E -> 2 2E }T
fv1 f! depth v1 ! fdepth v2 !
T{ fv1 f@ v1 @ v2 @ -> 11E 0 0 }T

12E 12 13E 13 T{ 3E 3 -> 3E 3 }T
fv1 f! fv2 f! v1 ! v2 !
T{ fv1 f@ fv2 f@ v1 @ v2 @ -> 13E 12E 13 12 }T
depth v1 ! fdepth v2 !
T{ v1 @ v2 @ -> 0 0 }T

TESTING  FT-TEST= FT-DATUM=

T{ 1E 1.0000000001E FT-DATUM= -> false }T
T{ 1E 1E            FT-DATUM= -> true }T
T{ 1E 1.0000000001E FT-TEST= -> false }T
T{ 1E 1E            FT-TEST= -> true }T

VERBOSE @ [IF]
FT-#ERRORS @
?." Inspect the error line:
T{ SET-FT-MODE-EXACT 1E -> 1.0000000001E }T
FT-#ERRORS !
T{ 1E -> 1E }T
[THEN]  \ VERBOSE

\ Comment this section out for systems without IEEE 754 support. 
true [IF]
T{ 0E fnegate fdup       FT-DATUM= -> true }T
T{ 0E fdup fnegate       FT-DATUM= -> false }T
T{ 1E 0E f/ fdup         FT-DATUM= -> true }T
T{ 1E 0E f/ fdup fnegate FT-DATUM= -> false }T
T{ 0E 0E f/ fdup         FT-DATUM= -> true }T
T{ 0E 0E f/ fdup fnegate FT-DATUM= -> false }T
[THEN]

\ This section assumes systems with IEEE 754 support.
VERBOSE @ [IF]
XT-#ERRORS @   FT-#ERRORS @
?." Inspect 3 error lines:
T{ 0E -> -0E }T
T{ 1E 0E f/ -> -1E 0E f/ }T
T{ 0E 0E f/ -> 0E 0E f/ fnegate }T
FT-#ERRORS !   XT-#ERRORS !
[THEN]  \ VERBOSE

TESTING  FT-ABS= FT-REL= FT-AREL= FT-REL0=
?.(          SET-FT-MODE-ABS SET-FT-MODE-REL SET-FT-MOD-AREL SET-FT-MODE-REL0)
?.cr

: ?.FT-MAX-ERRORS
  VERBOSE @ IF blue-text
    ." Using FT-ABS-TOLERANCE:  " FT-ABS-TOLERANCE  f@ fs. cr
    ."       FT-REL-TOLERANCE:  " FT-REL-TOLERANCE  f@ fs. cr
    ."       FT-AREL-TOLERANCE: " FT-AREL-TOLERANCE f@ fs. cr
    normal-text THEN ;

.0005E                    FCONSTANT TEST-ABS-TOL
1.001E 1E f- 1E f/        FCONSTANT TEST-REL-TOL
1.0001E 1E f- 1.00005E f/ FCONSTANT TEST-AREL-TOL

TEST-ABS-TOL  FT-ABS-TOLERANCE f!
TEST-REL-TOL  FT-REL-TOLERANCE f!
TEST-AREL-TOL FT-AREL-TOLERANCE f!
?.FT-MAX-ERRORS

T{ 1.00025E 1E FT-ABS= -> true }T
T{ 1.001E 1E   FT-ABS= -> false }T
T{ 1.0009E10 1E10 FT-REL= -> true }T
T{ 1.0011E10 1E10 FT-REL= -> false }T
\ next two would be opposite if meas and ref were backwards
IFORTH-HOST 0= [IF]
T{ 1.001E10  1E10 FT-REL= -> false }T  \ must be less, not equal to eps
[ELSE]  \ VERBOSE
\ decimal conversion roundoff workaround
T{ 1.00100000000000000001E10 1E10 FT-REL= -> false }T
[THEN]
T{ 1E10 1.001E10 FT-REL= -> true }T
T{ 1.00009E12 1E12 FT-AREL= -> true }T
T{ 1.00011E12 1E12 FT-AREL= -> false }T

T{ SET-FT-MODE-ABS 1.00025E -> 1E }T
T{ FT-TEST=-XT @ -> ' FT-ABS= }T
T{ SET-FT-MODE-REL 1.0009E10 -> 1E10 }T
T{ FT-TEST=-XT @ -> ' FT-REL= }T
T{ SET-FT-MODE-AREL 1.00009E12 -> 1E12 }T
T{ FT-TEST=-XT @ -> ' FT-AREL= }T
T{ SET-FT-MODE-REL0 1.00025E 1.0009E10 -> 1E 1E10 }T
T{ FT-TEST=-XT @ -> ' FT-REL0= }T

VERBOSE @ [IF]
FT-#ERRORS @
?." Inspect 5 error lines:
T{ SET-FT-MODE-ABS  1.001E     -> 1E }T
\ next tolerance fails because it's equal, not less
T{ SET-FT-MODE-REL  1.001E10   -> 1E10 }T
T{ SET-FT-MODE-AREL 1.00011E12 -> 1E12 }T
T{ SET-FT-MODE-REL0 1.001E     -> 1E }T
T{ SET-FT-MODE-REL0 1.001E10   -> 1E10 }T
FT-#ERRORS !
[THEN]  \ VERBOSE

TESTING  ttester-xf fp example

SET-FT-MODE-REL
1E-6 FT-REL-TOLERANCE F!
F{ S" 3.14159" >FLOAT DROP F-> -1E FACOS }F
\ One less digit in the results (measured) fails:
\ F{ S" 3.1416" >FLOAT F-> -1E FACOS TRUE }F

[UNDEFINED] TTESTER-XF [IF]
?." Skipping deprecated comparison words.
[ELSE]  \ DEPRECATED WORDS
TESTING  FT~ABS= FT~REL= FT-NEARLY= FT-CONF= SET-EXACT SET-NEAR
(
These are tests for ttester words that are deprecated in ttester-xf and
absent in xftester.
)

T{ SET-EXACT 1E 1.0000000001E FT-CONF= -> false }T
T{ FT-TEST=-XT @ FT-EXACT? -> ' FT-CONF= true }T
T{ 1E 1E FT-CONF= -> true }T
T{ 1E -> 1E }T

TEST-AREL-TOL 2E f/ FCONSTANT TEST-REL-NEAR

TEST-ABS-TOL  ABS-NEAR f!
TEST-REL-NEAR REL-NEAR f!

T{ SET-NEAR 1.00025E -> 1E }T
T{ FT-TEST=-XT @ FT-EXACT? -> ' FT-CONF= false }T
T{ 1.00025E 1E FT~ABS= -> true }T
T{ 1.001E 1E   FT~ABS= -> false }T
T{ 1.00009E12 1E12 FT~REL= -> true }T
T{ 1.00011E12 1E12 FT~REL= -> false }T

SET-NEAR
0E ABS-NEAR f!   0E REL-NEAR f!
T{ 1E -> 1E }T
TEST-ABS-TOL ABS-NEAR f!   0E REL-NEAR f!
T{ 1E -> 1E }T
T{ 1.00025E -> 1E }T
0E ABS-NEAR f!   TEST-REL-NEAR REL-NEAR f!
T{ 1E -> 1E }T
T{ 1.00009E12 -> 1E12 }T

VERBOSE @ [IF]
FT-#ERRORS @
?." Inspect 4 error lines:
T{ SET-EXACT 1E -> 1.0000000001E }T
0E ABS-NEAR f!   0E REL-NEAR f!
T{ SET-NEAR  1E -> 1.0000000001E }T \ exact
TEST-ABS-TOL ABS-NEAR f!   0E REL-NEAR f!
T{ SET-NEAR  1.001E -> 1E }T        \ abs
0E ABS-NEAR f!   TEST-REL-NEAR REL-NEAR f!
T{ SET-NEAR  1.00011E12 -> 1E12 }T  \ rel
FT-#ERRORS !
[THEN]  \ VERBOSE

[THEN]  \ DEPRECATED WORDS
[THEN]  \ HAS-FLOATING

[UNDEFINED] CATCH [IF]
?." CATCH not defined, can't test exceptions.
[ELSE]

TESTING  exceptions

[UNDEFINED] drops [IF]
  : drops  ( xn ... x1 n -- )  0 ?DO drop LOOP ;
[THEN]

HAS-FLOATING [IF]
[UNDEFINED] fdrops [IF]
  : fdrops  ( f: xn ... x1 -- ) ( n -- )  0 ?DO fdrop LOOP ;
[THEN]
[THEN]  \ HAS-FLOATING

\ MAX-XT-INITIALS overflow
\ 1 2 3 T{ 
1 2 3 ' T{ CATCH v1 ! 3 drops depth v2 !
T{ v1 @ v2 @ -> -2 0 }T

\ MAX-XT-RESULTS overflow
2 to MAX-XT-RESULTS
\ 1 2 3 ->
1 2 3 ' -> CATCH v1 ! 3 drops depth v2 !
T{ v1 @ v2 @ -> -2 0 }T

\ MAX-XT-GOALS overflow
\ 1 2 3 }T
1 2 3 ' }T CATCH v1 ! 3 drops depth v2 !
T{ v1 @ v2 @ -> -2 0 }T

HAS-FLOATING [IF]
SET-FT-MODE-EXACT

\ MAX-FT-INITIALS overflow
\ 1E 2E 3E T{
X{ 1E 2E 3E ' F{ CATCH 3 fdrops fdepth X-> -2 0 }X

\ MAX-FT-RESULTS overflow
1 to MAX-FT-RESULTS
\ 1E 2E ->
X{ 1E 2E ' F-> CATCH 2 fdrops fdepth X-> -2 0 }X

\ MAX-FT-GOALS overflow
\ 1E 2E }T
X{ 1E 2E ' }F CATCH 2 fdrops fdepth X-> -2 0 }X

[THEN]  \ HAS-FLOATING
IFORTH-HOST [IF] ?.cr [THEN]  \ CR after exception stack dump
[THEN]  \ [UNDEFINED] CATCH

\ There's no portable way to CATCH these underflows.  Uncomment
\ one at a time.
\ X{ drop
\ X-> drop
HAS-FLOATING [IF]
\ F{ fdrop
\ F-> fdrop
[THEN]  \ HAS-FLOATING

TESTING  errors
VERBOSE @ [IF]

XT-#ERRORS @ 
HAS-FLOATING [IF]
FT-#ERRORS @
2 to MAX-FT-RESULTS
[THEN]  \ HAS-FLOATING

?." Inspect the error lines:
T{ 1 ->   }T
T{   -> 1 }T
T{ 1 -> 2 }T
HAS-FLOATING [IF]
T{ 1E ->    }T
T{    -> 1E }T
T{ 1E -> 2E  }T
T{ 1 -> 2 3E }T
T{ 2 3E -> 1 }T
T{ 1E -> 2E 3 }T
T{ 2E 3 -> 1E }T
[THEN]  \ HAS-FLOATING

?." Inspect the more elaborate error reports:
' XT-ERROR3 XT-ERROR-XT !
T{ 1 2 -> 3 2 }T
3 to MAX-XT-RESULTS
T{ 1 2 3 -> 4 2 3 }T
T{ 1 2 3 -> 3 4 3 }T
T{ 1 2 -> 3 2 }T
3 to MAX-XT-RESULTS
T{ 1 2 3 -> 4 2 3 }T
T{ 1 2 3 -> 3 4 3 }T

HAS-FLOATING [IF]
' FT-ERROR3 FT-ERROR-XT !
T{ 1E 2E -> 1E 3E 3 4 }T
T{ 1E 2E 3 4 -> 1E 3E }T
3 to MAX-FT-RESULTS
T{ 1E 2E 3E -> 4E 2E 3E }T
T{ 1E 2E 3E -> 3E 4E 3E }T
T{ 1E -> 2E }T
' FT-ERROR1 FT-ERROR-XT !

0.75E FT-REL-TOLERANCE f!
SET-FT-MODE-REL
T{ f[1,1,1] f[2,2,2] FT-A= -> 0 true }T
T{ f[2,2,2] f[1,1,1] FT-A= -> 3 false }T
T{ f[2,2,1] f[1,1,1] FT-A= -> 2 false }T
T{ f[2,1,1] f[1,1,1] FT-A= -> 1 false }T
T{ f[1,1,1] f[1,1,1] FT-A= -> 0 true }T

[THEN]  \ HAS-FLOATING

' XT-ERROR1 XT-ERROR-XT !
?." The following are actually syntax errors:
T{ 1 }T
HAS-FLOATING [IF]
T{ 1E }T
FT-#ERRORS !
[THEN]  \ HAS-FLOATING
XT-#ERRORS !
[THEN]  \ VERBOSE

?." This syntax error is not reported: T{ }T
T{ }T

true VERBOSE !
?.errors GFORTH-HOST [IF] ?.cr [THEN]