-- This is version 0.3 of a specification compliance test suite for the
-- Generic Complex Elementary Functions. 17-Jan-1993
-- For ISO-IEC/JTC1/SC22/WG9 (Ada) Numerics Rapporteur Group
-- NUMWG Draft 1.1, 17 Jan 1993
-- This is just part 1, exceptions and exact values.

-- The ACVC Ada Compiler Validation Capability philosophy is intended to
-- be used. e.g. This is a test against a specification on a specific
-- implementation. A specific implementation means the combination of three
-- items : 1) a specific Ada compilation system, 2) a specific hardware
-- configuration and 3) a specific Generic Elementary Functions
-- implementation. The specification is interpreted by the NRG
-- the same way ANSI/MIL-STD-1815A is interpreted by the ARG.

-- Note to implementors: Once an initial release of this test suite is
-- released, there may be periodic updates. There is no guarantee that
-- passing any particular version implies passing another version.
-- This is the same philosophy as for ACVC.

--  When the specification says the domain is unbounded, then the test
--  suite checks for no ARGUMENT_ERROR being raised of FLOAT_TYPE'SAFE_LARGE,
--  'SAFE_SMALL and possibly other values. Similarly for a domain of
--  X>0 or X>=0 'SAFE_LARGE and 'SAFE_SMALL are used. Tests are also made
--  to insure no exceptions are raised at a few points inside the domain.
--  No accuracy checks are made in this part of the test, although exact
--  values are checked.

--  The actual tests for each base type are created by the
--  instantiations at the end. Ignore compilation errors for types
--  that do not exists

-- Please report problems or suggested additions to Jon Squire
-- Net mail  squire@cs.umbc.edu , phone (410)765-3748

with TEXT_IO; use TEXT_IO;
with GENERIC_REAL_ARRAYS;
with GENERIC_COMPLEX_TYPES;
with GENERIC_COMPLEX_ARRAYS;
with GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS;
with COMPLEX_IO; -- available for developers debugging
with GENERIC_ELEMENTARY_FUNCTIONS; -- previous standard package

generic
  type REAL is digits <>;
procedure TEST_GENERIC_COMPLEX_ELEMENTARY_FUNCT_1;

procedure TEST_GENERIC_COMPLEX_ELEMENTARY_FUNCT_1 is

  package REAL_ARRAYS is new GENERIC_REAL_ARRAYS ( REAL );
  use REAL_ARRAYS;

  package COMPLEX_TYPES is new GENERIC_COMPLEX_TYPES ( REAL );
  use COMPLEX_TYPES;

  package COMPLEX_ELEMENTARY_FUNCTIONS is new
          GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS(REAL, COMPLEX, IMAGINARY);
  use COMPLEX_ELEMENTARY_FUNCTIONS;

  package COMPLEX_ARRAYS is new GENERIC_COMPLEX_ARRAYS
                                ( REAL, REAL_VECTOR, REAL_MATRIX, COMPLEX );
  use COMPLEX_ARRAYS;

  package CX_IO is new COMPLEX_IO( REAL , COMPLEX ) ;
  use CX_IO;

  package ELEMENTARY_FUNCTIONS is new
                               GENERIC_ELEMENTARY_FUNCTIONS ( REAL ) ;

  ARGUMENT_ERROR : exception renames COMPLEX_TYPES.ARGUMENT_ERROR;

  -- some attributes used below
  EPSILON : constant REAL := REAL'EPSILON;
  LARGE : constant REAL := REAL'SAFE_LARGE/1.415;
  SMALL : constant REAL := REAL'SAFE_SMALL*1.415;

  -- other values used in tests
  ZERO          : REAL    := 0.0;
  ONE           : REAL    := 1.0;
  M_ONE         : REAL    := -1.0;
  LN_LARGE      : REAL    := ELEMENTARY_FUNCTIONS.LOG(LARGE*0.707);
  COMPLEX_ZERO  : COMPLEX := (0.0,0.0);
  COMPLEX_ONE   : COMPLEX := (1.0,0.0);
  COMPLEX_M_ONE : COMPLEX := (-1.0,0.0);
  COMPLEX_I     : COMPLEX := (0.0,1.0);
  COMPLEX_M_I   : COMPLEX := (0.0,-1.0);

  BIG_PP        : COMPLEX := (LARGE,LARGE);
  BIG_PZ        : COMPLEX := (LARGE,0.0);
  BIG_PM        : COMPLEX := (LARGE,-LARGE);
  BIG_MP        : COMPLEX := (-LARGE,LARGE);
  BIG_MZ        : COMPLEX := (-LARGE,0.0);
  BIG_MM        : COMPLEX := (-LARGE,-LARGE);
  BIG_ZP        : COMPLEX := (0.0,LARGE);
  BIG_ZM        : COMPLEX := (0.0,-LARGE);

  SML_PP        : COMPLEX := (SMALL,SMALL);
  SML_PZ        : COMPLEX := (SMALL,0.0);
  SML_PM        : COMPLEX := (SMALL,-SMALL);
  SML_MP        : COMPLEX := (-SMALL,SMALL);
  SML_MZ        : COMPLEX := (-SMALL,0.0);
  SML_MM        : COMPLEX := (-SMALL,-SMALL);
  SML_ZP        : COMPLEX := (0.0,SMALL);
  SML_ZM        : COMPLEX := (0.0,-SMALL);

  LN_RE_PP        : COMPLEX := (LN_LARGE,LARGE);
  LN_RE_PZ        : COMPLEX := (LN_LARGE,0.0);
  LN_RE_PM        : COMPLEX := (LN_LARGE,-LARGE);
  LN_RE_MP        : COMPLEX := (-LN_LARGE,LARGE);
  LN_RE_MZ        : COMPLEX := (-LN_LARGE,0.0);
  LN_RE_MM        : COMPLEX := (-LN_LARGE,-LARGE);
  LN_RE_ZP        : COMPLEX := (0.0,LARGE);
  LN_RE_ZM        : COMPLEX := (0.0,-LARGE);

  LN_IM_PP        : COMPLEX := (LARGE,LN_LARGE);
  LN_IM_PZ        : COMPLEX := (LARGE,0.0);
  LN_IM_PM        : COMPLEX := (LARGE,-LN_LARGE);
  LN_IM_MP        : COMPLEX := (-LARGE,LN_LARGE);
  LN_IM_MZ        : COMPLEX := (-LARGE,0.0);
  LN_IM_MM        : COMPLEX := (-LARGE,-LN_LARGE);
  LN_IM_ZP        : COMPLEX := (0.0,LN_LARGE);
  LN_IM_ZM        : COMPLEX := (0.0,-LN_LARGE);


  BIG_LIST : COMPLEX_VECTOR ( 1..8 ) :=
             ( BIG_PP, BIG_PZ, BIG_PM, BIG_MP, BIG_MZ, BIG_MM, BIG_ZP, BIG_ZM );
  SML_LIST : COMPLEX_VECTOR ( 1..8 ) :=
             ( SML_PP, SML_PZ, SML_PM, SML_MP, SML_MZ, SML_MM, SML_ZP, SML_ZM );
  LN_IM_LIST : COMPLEX_VECTOR ( 1..8 ) :=
               ( LN_IM_PP, LN_IM_PZ, LN_IM_PM, LN_IM_MP, LN_IM_MZ, LN_IM_MM,
               LN_IM_ZP, LN_IM_ZM );
  LN_RE_LIST : COMPLEX_VECTOR ( 1..8 ) :=
               ( LN_RE_PP, LN_RE_PZ, LN_RE_PM, LN_RE_MP, LN_RE_MZ, LN_RE_MM,
               LN_RE_ZP, LN_RE_ZM );

  ALL_LIST : COMPLEX_VECTOR ( 1..16 ) := BIG_LIST & SML_LIST;
  SIN_LIST : COMPLEX_VECTOR ( 1..16 ) := LN_IM_LIST & SML_LIST;
  SINH_LIST : COMPLEX_VECTOR ( 1..16 ) := LN_RE_LIST & SML_LIST;

  -- computed values for checking exceptions
  ONE_PLUS  : REAL := 1.0 + EPSILON ;
  ONE_MINUS : REAL := 1.0 - EPSILON ;

  -- variables used in tests
  ANY_FAIL : BOOLEAN := FALSE;
  Z : COMPLEX;
  RESULT : COMPLEX;

  STOP_ERROR : exception ;

  procedure PASSED ( MESSAGE : STRING := "" ) is
  begin
    null; -- developers may want to uncomment or put some thing here
    -- PUT ( Z ) ; PUT_LINE ( "= Input Parameter to " & MESSAGE );
    -- PUT ( RESULT ) ; PUT_LINE ( " = Result (not useful if exception)" );
    -- NEW_LINE;
  end PASSED;

  procedure FAILED ( MESSAGE : STRING ) is
  begin
    ANY_FAIL := TRUE;
    PUT_LINE("FAILED " & MESSAGE);
    -- PUT ( Z ) ; PUT_LINE ( "= Input Parameter" ); -- developers may uncomment
  end FAILED;

begin
  PUT_LINE("Begin Part 1 of GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS test");
  PUT_LINE("Version 0.2, 11 July 1991, testing conformance of exceptions.");

  begin
    RESULT := COMPLEX_ONE / SIN ( COMPLEX_ZERO );
    FAILED("No exception raised on divide by zero.");
    raise STOP_ERROR;
  exception
    when CONSTRAINT_ERROR =>
      PUT_LINE("Divide by zero exception is CONSTRAINT_ERROR");
    when others =>
      PUT_LINE("Divide by zero exception is unknown");
      PUT_LINE("Globally substitute appropriate exception for CONSTRAINT_ERROR");
      raise STOP_ERROR;
    end;


  PUT_LINE("SQRT testing");
  begin -- expect no exception
    RESULT := SQRT(BIG_PP);
  exception
    when others =>
      FAILED("unexpected exception SQRT(BIG_PP)");
  end;
  begin -- expect no exception
    RESULT := SQRT(SML_PP);
  exception
    when others =>
      FAILED("unexpected exception SQRT(SML_PP)");
  end;


  PUT_LINE("LOG testing");
  begin -- expect CONSTRAINT_ERROR
    RESULT := LOG(COMPLEX_ZERO);
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("LOG exception");
    when others =>
      FAILED("unexpected exception LOG(COMPLEX_ZERO)");
  end;
  begin -- expect no exception
    RESULT := LOG(BIG_PP);
  exception
    when others =>
      FAILED("unexpected exception LOG(BIG_PP)");
  end;
  begin -- expect no exception
    RESULT := LOG(SML_PP);
  exception
    when others =>
      FAILED("unexpected exception LOG(SML_PP)");
  end;


  PUT_LINE("EXP testing");
  begin -- expect CONSTRAINT_ERROR
    RESULT := EXP(BIG_PP);
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("EXP exception");
    when others =>
      FAILED("unexpected exception EXP(BIG_PP)");
  end;
  begin -- expect no exception
    RESULT := EXP(SML_PP);
  exception
    when others =>
      FAILED("unexpected exception EXP(SML_PP)");
  end;


  PUT_LINE("** complex complex testing");
  begin -- expect ARGUMENT_ERROR
    RESULT := COMPLEX_ZERO ** COMPLEX_ZERO;
    FAILED("no exception when one was expected");
  exception
    when ARGUMENT_ERROR =>
      PASSED("** exception");
    when others =>
      FAILED("unexpected exception COMPLEX_ZERO ** COMPLEX_ZERO");
  end;
  begin -- expect CONSTRAINT_ERROR
    RESULT := COMPLEX_ZERO ** COMPLEX_M_ONE;
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("** exception");
    when others =>
      FAILED("unexpected exception COMPLEX_ZERO ** COMPLEX_M_ONE");
  end;
  begin -- expect CONSTRAINT_ERROR
    RESULT := BIG_PP ** BIG_PP;
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("** exception");
    when others =>
      FAILED("unexpected exception BIG_PP ** BIG_PP");
  end;


  PUT_LINE("** complex real testing");
  begin -- expect ARGUMENT_ERROR
    RESULT := COMPLEX_ZERO ** ZERO;
    FAILED("no exception when one was expected");
  exception
    when ARGUMENT_ERROR =>
      PASSED("** exception");
    when others =>
      FAILED("unexpected exception COMPLEX_ZERO ** ZERO");
  end;
  begin -- expect CONSTRAINT_ERROR
    RESULT := COMPLEX_ZERO ** M_ONE;
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("** exception");
    when others =>
      FAILED("unexpected exception COMPLEX_ZERO ** M_ONE");
  end;
  begin -- expect CONSTRAINT_ERROR
    RESULT := BIG_PP ** LARGE;
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("** exception");
    when others =>
      FAILED("unexpected exception BIG_PP ** LARGE");
  end;


  PUT_LINE("** real complex testing");
  begin -- expect ARGUMENT_ERROR
    RESULT := ZERO ** COMPLEX_ZERO;
    FAILED("no exception when one was expected");
  exception
    when ARGUMENT_ERROR =>
      PASSED("** exception");
    when others =>
      FAILED("unexpected exception ZERO ** COMPLEX_ZERO");
  end;
  begin -- expect CONSTRAINT_ERROR
    RESULT := ZERO ** COMPLEX_M_ONE;
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("** exception");
    when others =>
      FAILED("unexpected exception ZERO ** COMPLEX_M_ONE");
  end;
  begin -- expect CONSTRAINT_ERROR
    RESULT := LARGE ** BIG_PP;
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("** exception");
    when others =>
      FAILED("unexpected exception LARGE ** BIG_PP");
  end;


  PUT_LINE("SIN testing");


  PUT_LINE("COS testing");


  PUT_LINE("TAN testing");


  PUT_LINE("COT testing");
  begin -- expect CONSTRAINT_ERROR
    RESULT := COT(COMPLEX_ZERO);
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("COT exception");
    when others =>
      FAILED("unexpected exception COT(COMPLEX_ZERO)");
  end;


  PUT_LINE("ARCSIN testing");


  PUT_LINE("ARCCOS testing");


  PUT_LINE("ARCTAN testing");
  begin -- expect CONSTRAINT_ERROR
    RESULT := ARCTAN(COMPLEX_I);
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("ARCTAN exception");
    when others =>
      FAILED("unexpected exception ARCTAN(COMPLEX_I)");
  end;
  begin -- expect CONSTRAINT_ERROR
    RESULT := ARCTAN(COMPLEX_M_I);
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("ARCTAN exception");
    when others =>
      FAILED("unexpected exception ARCTAN(COMPLEX_M_I)");
  end;


  PUT_LINE("ARCCOT testing");
  begin -- expect CONSTRAINT_ERROR
    RESULT := ARCCOT(COMPLEX_I);
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("ARCCOT exception");
    when others =>
      FAILED("unexpected exception ARCCOT(COMPLEX_I)");
  end;
  begin -- expect CONSTRAINT_ERROR
    RESULT := ARCCOT(COMPLEX_M_I);
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("ARCCOT exception");
    when others =>
      FAILED("unexpected exception ARCCOT(COMPLEX_M_I)");
  end;


  PUT_LINE("SINH testing");


  PUT_LINE("COSH testing");


  PUT_LINE("TANH testing");


  PUT_LINE("COTH testing");
  begin -- expect CONSTRAINT_ERROR
    RESULT := COTH(COMPLEX_ZERO);
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("COTH exception");
    when others =>
      FAILED("unexpected exception COTH(COMPLEX_ZERO)");
  end;


  PUT_LINE("ARCSINH testing");


  PUT_LINE("ARCCOSH testing");


  PUT_LINE("ARCTANH testing");
  begin -- expect CONSTRAINT_ERROR
    RESULT := ARCTANH(COMPLEX_ONE);
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("ARCTANH exception");
    when others =>
      FAILED("unexpected exception ARCTANH(COMPLEX_ONE)");
  end;
  begin -- expect CONSTRAINT_ERROR
    RESULT := ARCTANH(COMPLEX_M_ONE);
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("ARCTANH exception");
    when others =>
      FAILED("unexpected exception ARCTANH(COMPLEX_M_ONE)");
  end;


  PUT_LINE("ARCCOTH testing");
  begin -- expect CONSTRAINT_ERROR
    RESULT := ARCCOTH(COMPLEX_ONE);
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("ARCCOTH exception");
    when others =>
      FAILED("unexpected exception ARCCOTH(COMPLEX_ONE)");
  end;
  begin -- expect CONSTRAINT_ERROR
    RESULT := ARCCOTH(COMPLEX_M_ONE);
    FAILED("no exception when one was expected");
  exception
    when CONSTRAINT_ERROR =>
      PASSED("ARCCOTH exception");
    when others =>
      FAILED("unexpected exception ARCCOTH(COMPLEX_M_ONE)");
  end;

  NEW_LINE;
  PUT("Generic Complex Elementary Functions specification compliance test ");
  if ANY_FAIL then
    PUT_LINE("FAILED");
  else
    PUT_LINE("PASSED");
  end if;
  NEW_LINE;
  PUT_LINE("End Part 1 of GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS test");

exception
  when STOP_ERROR =>
    PUT_LINE("Specialized test is needed because 1.0/0.0 does not" &
             " raise CONSTRAINT_ERROR.");
  when others =>
    PUT_LINE("Test aborted because of unhandled exception.");
end TEST_GENERIC_COMPLEX_ELEMENTARY_FUNCT_1;


-- Even if some of the compilation units below fail, others will compile.
-- The compliance test must be run on all that compile.

with TEST_GENERIC_COMPLEX_ELEMENTARY_FUNCT_1;
procedure TEST_COMPLEX_ELEMENTARY_FUNCT_1 is new
          TEST_GENERIC_COMPLEX_ELEMENTARY_FUNCT_1 ( FLOAT );

with TEST_GENERIC_COMPLEX_ELEMENTARY_FUNCT_1;
procedure TEST_LONG_COMPLEX_ELEMENTARY_FUNCT_1 is new
          TEST_GENERIC_COMPLEX_ELEMENTARY_FUNCT_1 ( LONG_FLOAT );