(    Title:  Tests for ztester
      File:  ztester-test.fs
  Log file:  ztester.log
    Author:  David N. Williams
   License:  Public Domain
   Version:  1.0.0
   Revised:  December 7, 2010
)

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

s" complex.fs" INCLUDED  \ ensures that fp is enabled
2 CONSTANT MAX-FT-INITIALS
s" ttester-xf.fs" INCLUDED

\ debugging
: .depths  ( -- )
  ."   data depth: " depth .  ."   fp depth: " fdepth . cr ;

\ We use a value because we want to make it smaller later:
16 VALUE MAX-ZT-RESULTS

#13 BASE !                \ test ztester BASE invariance
s" ztester.fs" INCLUDED

T{ BASE @  -> #13 }T
decimal
true VERBOSE !

s" tester-display.fs" INCLUDED
\ before the first displayed line
PFE-HOST IFORTH-HOST or [IF] ?.cr [THEN]

PFE-HOST [IF]
  ?." Host is pfe
\ 0 REDEFINED-MSG !
[THEN]
GFORTH-HOST [IF]
  ?." Host is gforth
\ 0 WARNINGS !
[THEN]
IFORTH-HOST [IF]
  ?." Host is iForth
\ 0 WARNING !
[THEN]


\ ***BEGIN ERROR DISPLAY

VARIABLE XT-#ERRORS    0 XT-#ERRORS !
: XT-ERROR1  ( c-addr u -- )
\ Display an error message followed by the line that had the
\ error.
  red-text 1 XT-#ERRORS +! XT-ERROR-DEFAULT normal-text ;
' XT-ERROR1 XT-ERROR-XT !

: xt-a.  ( 'array c-addr u -- )
  blue-text type
  ( 'array) dup >r @ dup
  IF   1- r> cell+ swap cells over +
       DO i @ . -1 cells +LOOP
  ELSE r> 2drop ." none" THEN cr normal-text ;

: XT-ERROR2  ( c-addr u -- )
  XT-ERROR1
  XT-RESULTS s"   xresults: " xt-a.
  XT-GOALS   s"     xgoals: " xt-a. ;

VARIABLE FT-#ERRORS    0 FT-#ERRORS !
: FT-ERROR1  ( c-addr u -- )
\ Display an error message followed by the line that had the
\ error.
  red-text 1 FT-#ERRORS +! FT-ERROR-DEFAULT normal-text ;
' FT-ERROR1 FT-ERROR-XT !

\ fancy error reporting
: ft-a.  ( 'array c-addr u -- )
  blue-text type
  ( 'array) dup @ swap cell+ faligned swap ?dup
  IF   ( n) 1 swap  \ display deepest first 
       DO ( 'floats) i 1- floats over + f@
          i FT-ERROR-INDEX @ =
          IF red-text f. blue-text ELSE f. THEN
       -1 +LOOP
  ELSE ." none" THEN drop cr normal-text ;

: FT-ERROR2  ( c-addr u -- )
  FT-ERROR1
  FT-RESULTS s"   fresults: " ft-a.
  FT-GOALS   s"     fgoals: " ft-a. ;

VARIABLE ZT-#ERRORS    0 ZT-#ERRORS !
: ZT-ERROR1  ( c-addr u -- )
\ Display an error message followed by the line that had the
\ error.
  red-text 1 ZT-#ERRORS +! ZT-ERROR-DEFAULT normal-text ;
' ZT-ERROR1 ZT-ERROR-XT !

\ fancy error reporting
: zt-a.  ( 'a c-addr u -- )
  blue-text type
  ( 'a) dup @ swap cell+ faligned swap ?dup
  IF   ( n) 1 swap  \ display deepest first 
       DO ( 'z1) i 1- 2* floats over + z@
          i ZT-ERROR-INDEX @ =
          IF red-text zs. blue-text ELSE zs. THEN
       -1 +LOOP
  ELSE ." none" THEN drop cr normal-text ;

: ZT-ERROR2  ( c-addr u -- )
  ZT-ERROR1
  ZT-RESULTS s"   zresults: " zt-a.
  ZT-GOALS   s"     zgoals: " zt-a. ;
\ ' ZT-ERROR2 ZT-ERROR-XT !

: ?.errors  ( -- )
  VERBOSE @
  IF blue-text ." Unexpected XT-ERRORS: " normal-text XT-#ERRORS @ . cr
     blue-text ." Unexpected FT-ERRORS: " normal-text FT-#ERRORS @ . cr
     blue-text ." Unexpected ZT-ERRORS: " normal-text ZT-#ERRORS @ .
  THEN ;

\ ***END ERROR DISPLAY


\ *** TESTS

[UNDEFINED] COMPLEXES [IF] : COMPLEXES  2* floats ; [THEN]
[UNDEFINED] COMPLEX+  [IF] : COMPLEX+   2 floats + ; [THEN]

\ scratch
VARIABLE v1   FVARIABLE fv1   ZVARIABLE zv1
VARIABLE v2   FVARIABLE fv2   ZVARIABLE zv2
VARIABLE v3

TESTING  SET-ZT-MODE-ZEXACT ZT-A<> ZT-A@ ZT-A!

\ default is exact 
T{ ZT-XYMODE? -> true }T
T{ ZT-XTEST=-XT @ ZT-YTEST=-XT @ -> ' FT-DATUM= dup }T

T{ false to ZT-XYMODE? 0 ZT-XTEST=-XT ! 0 ZT-YTEST=-XT ! -> }T
T{ SET-ZT-MODE-ZEXACT
   ZT-XTEST=-XT @ ZT-YTEST=-XT @ -> ' FT-DATUM= dup }T

: ZARRAY  ( +n -- ) ( f: zn ... z1 -- )
  CREATE dup , falign here >r complexes allot here r>
  ?DO i z! 1 complexes +LOOP ;

0 ZARRAY z[]
1  0e 0e ZARRAY z[0]
1 10e 0e ZARRAY z[10]
2 11e 0e 10e 0e ZARRAY z[10,11]
2  1e 0e 10e 0e ZARRAY z[10,1]
2 11e 0e  0e 0e ZARRAY z[0,11]
2  1e 0e  0e 0e ZARRAY z[0,1]
3 12e 0e 11e 0e 10e 0e ZARRAY z[10,11,12]
3 12e 0e 11e 0e  1e 0e ZARRAY z[1,11,12]
3 12e 0e  1e 0e  1e 0e ZARRAY z[1,1,12]
3  2e 0e 11e 0e  1e 0e ZARRAY z[1,11,2]

T{ z[] @ -> 0 }T
T{ z[10] @ z[10] cell+ faligned z@ -> 1 10e 0e }T
T{ z[10,11] @ z[10,11] cell+ faligned dup z@ complex+ z@
   -> 2 10e 0e 11e 0e }T

\ different length
T{   z[]  z[10,11,12] ZT-A<> -> -1 }T
T{ z[10]  z[10,1]     ZT-A<> -> -1 }T
T{ z[10]  z[10,11,12] zT-A<> -> -1 }T

\ different at index 1
T{ z[0]    z[10]   ZT-A<> -> 1 }T
T{ z[10,1] z[0,11] ZT-A<> -> 1 }T
T{ z[10,1] z[0,1]  ZT-A<> -> 1 }T
T{ z[10,11,12] z[1,11,12] ZT-A<> -> 1 }T
T{ z[10,11,12] z[1,1,12]  ZT-A<> -> 1 }T

\ different at index 2
T{ z[10,1]   z[10,11]   ZT-A<> -> 2 }T
T{ z[1,1,12] z[1,11,12] ZT-A<> -> 2 }T
T{ z[1,1,12] z[1,11,2]  ZT-A<> -> 2 }T

\ different at index 3
T{ z[1,11,12] z[1,11,2] ZT-A<> -> 3 }T

\ the same
T{ z[]         z[]         ZT-A<> -> 0 }T
T{ z[10]       z[10]       ZT-A<> -> 0 }T
T{ z[10,11,12] z[10,11,12] ZT-A<> -> 0 }T

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

here 1 cells allot falign 3 complexes allot CONSTANT max3zarray
T{ 3e .5e  2e 1e  1e 1.5e 3 max3zarray ZT-A! max3zarray ZT-A@
   ->  3e .5e  2e 1e 1e 1.5e 3 }T
T{ 11e 1e 10e 2e 2 max3zarray ZT-A! max3zarray ZT-A@ -> 11e 1e 10e 2e 2 }T
T{         0e 1e 1 max3zarray ZT-A! max3zarray ZT-A@ ->  0e 1e 1 }T
T{            0 max3zarray ZT-A! max3zarray ZT-A@ ->  0 }T
\ farray overwrite?
T{ -1e 1e -1e 1e -1e 1e 3 max3zarray ZT-A! -> }T
T{         0e 0e  0e 0e 2 max3zarray ZT-A! -> }T
T{ max3zarray cell+ faligned complex+ dup z@ complex+ z@
   -> 0e 0e -1e 1e }T

TESTING  Z{ Z-> }Z

T{ SET-ZT-MODE-ZEXACT -> }T

Z{ Z-> }Z
Z{ 1e -1e Z-> 1e -1e }Z
Z{ 1e -1e 2e -2e 3e -3e 1e -1e Z-> 1e -1e 2e -2e 3e -3e 1e -1e }Z

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

1e Z{ 3e 1e Z-> 3e 1e }Z
fv1 f! fdepth v2 !
T{ fv1 f@ v2 @ -> 1e 0 }T

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

TESTING  ZT-ZABS= SET-ZT-MODE-ZABS ZT-TEST=

T{ SET-ZT-MODE-ZEXACT -> }T
T{ 1e -1e zv1 z! 1.0000000001e -1e zv2 z! -> }T
\ test xy path
T{ zv1 zv2 ZT-TEST= -> false }T
T{ 1e -1e zv2 z! zv1 zv2 ZT-TEST= -> true }T
Z{ 1e -2e Z-> 1e -2e }Z

1.00001e 1e f- FCONSTANT TEST-ZABS-ERR

T{ TEST-ZABS-ERR ZT-ZABS-ERROR f! SET-ZT-MODE-ZABS -> }T
T{ ZT-XYMODE? ZT-ZTEST=-XT @ -> false ' ZT-ZABS= }T

T{ 1e 2e 1e 2e ZT-ZABS= -> true }T
T{ 1e 0e 1.00001e 0e ZT-ZABS= -> false }T  \ test uses F<, not F=
\ test z path
T{ 1e 2e zv1 z! 1e 2e zv2 z!
   zv1 zv2 ZT-TEST= -> true }T
T{ 1e 0e zv1 z! 1.00001e 0e zv2 z!
   zv1 zv2 ZT-TEST= -> false }T  \ test uses F<
Z{ 1e 2e Z-> 1.000009e 2e }Z

ZT-#ERRORS @
?." Expecting two error lines:
Z{ SET-ZT-MODE-ZEXACT 1e -1e Z-> 1.0000000001e -1e }Z
Z{ SET-ZT-MODE-ZABS   1e  2e Z-> 1.00001e 2e }Z \ test uses F<, not F=
ZT-#ERRORS !

TESTING  ZT-REL= SET-ZT-MODE-ZREL

1.00005e 1e f- FCONSTANT TEST-ZREL-ERR

T{ TEST-ZREL-ERR ZT-ZREL-ERROR f! SET-ZT-MODE-ZREL -> }T
T{ ZT-XYMODE? ZT-ZTEST=-XT @ -> false ' ZT-ZREL= }T

T{ 1e12 2e 1e12 2e ZT-ZREL= -> true }T
T{ 1e12 0e 1.00005e12 0e ZT-ZREL= -> true }T \ bigger meas value
T{ 1.00006e12 0e 1e12 0e ZT-ZREL= -> false }T
Z{ 1e12 0e Z-> 1.00005e12 0e }Z \ bigger meas value

ZT-#ERRORS @
?." Expecting one error line:
Z{ SET-ZT-MODE-ZREL 1.00006e12 0e Z-> 1e12 0e }Z
ZT-#ERRORS !

TESTING  SET-ZT-MODE-XEXACT SET-ZT-MODE-YEXACT
?.(          SET-ZT-MODE-XABS   SET-ZT-MODE-YABS) cr
?.(          SET-ZT-MODE-XREL   SET-ZT-MODE-YREL) cr

T{ SET-ZT-MODE-XEXACT 0 ZT-YTEST=-XT !  -> }T
T{ ZT-XYMODE? ZT-XTEST=-XT @ ZT-YTEST=-XT @ -> true ' FT-DATUM= 0 }T

T{ SET-ZT-MODE-YEXACT 0 ZT-XTEST=-XT !  -> }T
T{ ZT-XYMODE? ZT-YTEST=-XT @ ZT-XTEST=-XT @ -> true ' FT-DATUM= 0 }T

T{ SET-ZT-MODE-XABS 0 ZT-YTEST=-XT !  -> }T
T{ ZT-XYMODE? ZT-XTEST=-XT @ ZT-YTEST=-XT @ -> true ' ZT-XABS= 0 }T

T{ SET-ZT-MODE-YABS 0 ZT-XTEST=-XT !  -> }T
T{ ZT-XYMODE? ZT-YTEST=-XT @ ZT-XTEST=-XT @ -> true ' ZT-YABS= 0 }T

T{ SET-ZT-MODE-XREL 0 ZT-YTEST=-XT !  -> }T
T{ ZT-XYMODE? ZT-XTEST=-XT @ ZT-YTEST=-XT @ -> true ' ZT-XREL= 0 }T

T{ SET-ZT-MODE-YREL 0 ZT-XTEST=-XT !  -> }T
T{ ZT-XYMODE? ZT-YTEST=-XT @ ZT-XTEST=-XT @ -> true ' ZT-YREL= 0 }T

TESTING  ZT-XABS= ZT-YABS= ZT-XREL= ZT-YREL=

.0005e              FCONSTANT TEST-XABS-ERR
1.001e 1e f- 1e f/  FCONSTANT TEST-XREL-ERR
.00005e             FCONSTANT TEST-YABS-ERR
1.0001e 1e f- 1e f/ FCONSTANT TEST-YREL-ERR

T{ TEST-XABS-ERR ZT-XABS-ERROR f! -> }T
T{ 1.00025e 1e ZT-XABS= -> true }T
T{ 1.001e   1e ZT-XABS= -> false }T

T{ TEST-YABS-ERR ZT-YABS-ERROR f! -> }T
T{ 1.000025e 1e ZT-YABS= -> true }T
T{ 1.0001e   1e ZT-YABS= -> false }T

T{ TEST-XREL-ERR ZT-XREL-ERROR f! -> }T
T{ 1.0009e10 1e10 ZT-XREL= -> true }T
T{ 1.0011e10 1e10 ZT-XREL= -> false }T
\ next two would be opposite if meas and ref were backwards
T{ 1.001e10 1e10 ZT-XREL= -> false }T \ test uses F<, not F=
T{ 1e10 1.001e10 ZT-XREL= -> true }T

T{ TEST-YREL-ERR ZT-YREL-ERROR f! -> }T
T{ 1.00009e10 1e10 ZT-YREL= -> true }T
T{ 1.00011e10 1e10 ZT-YREL= -> false }T
\ next two would be opposite if meas and ref were backwards
T{ 1.0001e10 1e10 ZT-YREL= -> false }T \ test uses F<, not F=
T{ 1e10 1.0001e10 ZT-YREL= -> true }T

T{ SET-ZT-MODE-XABS SET-ZT-MODE-YEXACT -> }T
T{ TEST-XABS-ERR ZT-XABS-ERROR f! -> }T
Z{ 1.00025e 0e Z-> 1e 0e }Z

T{ SET-ZT-MODE-XEXACT SET-ZT-MODE-YABS -> }T
T{ TEST-YABS-ERR ZT-YABS-ERROR f! -> }T
Z{ 0e 1.000025e Z-> 0e 1e }Z

T{ SET-ZT-MODE-XREL SET-ZT-MODE-YEXACT -> }T
T{ TEST-XREL-ERR ZT-XREL-ERROR f! -> }T
Z{ 1.0009e10 0e Z-> 1e10 0e }Z

T{ SET-ZT-MODE-XEXACT SET-ZT-MODE-YREL -> }T
T{ TEST-YREL-ERR ZT-YREL-ERROR f! -> }T
Z{ 0e 1.00009e10 Z-> 0e 1e10 }Z

\ These assume the tolerances set just above.
ZT-#ERRORS @
?." Expecting four error lines:
T{ SET-ZT-MODE-XABS SET-ZT-MODE-YEXACT -> }T
Z{ 1.001e 0e Z-> 1e 0e }Z
T{ SET-ZT-MODE-XEXACT SET-ZT-MODE-YABS -> }T
Z{ 0e 1.0001e Z-> 0e 1e }Z
T{ SET-ZT-MODE-XREL SET-ZT-MODE-YEXACT -> }T
Z{ 1.0011e10 0e Z-> 1e10 0e }Z
T{ SET-ZT-MODE-XEXACT SET-ZT-MODE-YREL -> }T
Z{ 0e 1.00011e10 Z-> 0e 1e10 }Z
ZT-#ERRORS !

TESTING  exceptions

\ exception code for ABORT" is 2

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

\ MAX-FT-INITIALS overflow

\ 1e 2e 3e Z{ 
T{ 1e 2e 3e ' Z{ CATCH 3 fdrops fdepth -> -2 0 }T

\ odd number of floats
\ 1e 2e 3e Z->
T{ 1e 2e 3e ' Z-> CATCH 3 fdrops fdepth -> -2 0 }T
\ 1e 2e 3e }Z
T{ 1e 2e 3e ' }Z CATCH 3 fdrops fdepth -> -2 0 }T

\ MAX-ZT-RESULTS overflow

1 to MAX-ZT-RESULTS
\ 1e 0e 2e 0e Z->
T{ 1e 0e 2e 0e ' Z-> CATCH 4 fdrops fdepth -> -2 0 }T

\ 1e 0e 2e 0e }Z
T{ 1e 0e 2e 0e ' }Z CATCH 4 fdrops fdepth -> -2 0 }T

\ There's no portable way to CATCH these underflows.  Uncomment
\ one at a time.
\ Z{ fdrop
\ Z-> fdrop

TESTING  errors

2 to MAX-ZT-RESULTS
VERBOSE @ [IF]

ZT-#ERRORS @
?." Inspect two error lines:
Z{ 1e 0e Z->   }Z
Z{   Z-> 1e 0e }Z

?." Inspect three elaborate error reports
' ZT-ERROR2 ZT-ERROR-XT !
SET-ZT-MODE-ZEXACT
Z{ 1e 2e Z-> 1e 3e }Z
3 to MAX-ZT-RESULTS
Z{ 1e 0e 2e 0e 3e 0e Z-> 4e 0e 2e 0e 3e 0e }Z
Z{ 1e 0e Z-> 2e 0e }Z
' ZT-ERROR1 ZT-ERROR-XT !

?." The following is actually a syntax error:
Z{ 1e 0e }Z
' ZT-ERROR1 ZT-ERROR-XT !
[THEN]  \ VERBOSE
ZT-#ERRORS !

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

?.errors GFORTH-HOST [IF] ?.cr [THEN]