OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

Compare Revisions

  • This comparison shows the changes necessary to convert path 
    /openrisc/tags/gnu-src/gcc-4.5.1/gcc-4.5.1-or32-1.0rc1/gcc/testsuite/ada/acats/tests/cxg
    from Rev 294 to Rev 338
    ↔ Reverse comparison
  •

Rev 294 → Rev 338

/cxg1001.a
0,0 → 1,276
-- CXG1001.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the subprograms defined in the package
-- Ada.Numerics.Generic_Complex_Types provide correct results.
-- Specifically, check the functions Re, Im (both versions), procedures
-- Set_Re, Set_Im (both versions), functions Compose_From_Cartesian (all
-- versions), Compose_From_Polar, Modulus, Argument, and "abs".
--
-- TEST DESCRIPTION:
-- The generic package Generic_Complex_Types
-- is instantiated with a real type (new Float), and the results
-- produced by the specified subprograms are verified.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 15 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1.
-- Modified subtest for Compose_From_Polar.
-- 29 Sep 96 SAIC Incorporated reviewer comments.
--
--!
 
with Ada.Numerics.Generic_Complex_Types;
with Report;
 
procedure CXG1001 is
 
begin
 
Report.Test ("CXG1001", "Check that the subprograms defined in " &
"the package Ada.Numerics.Generic_Complex_Types " &
"provide correct results");
 
Test_Block:
declare
 
type Real_Type is new Float;
 
package Complex_Pack is new
Ada.Numerics.Generic_Complex_Types(Real_Type);
 
use type Complex_Pack.Complex;
 
-- Declare a zero valued complex number.
Complex_Zero : constant Complex_Pack.Complex := (0.0, 0.0);
 
TC_Complex : Complex_Pack.Complex := Complex_Zero;
TC_Imaginary : Complex_Pack.Imaginary;
 
begin
 
-- Check that the procedures Set_Re and Set_Im (both versions) provide
-- correct results.
 
declare
TC_Complex_Real_Field : Complex_Pack.Complex := (5.0, 0.0);
TC_Complex_Both_Fields : Complex_Pack.Complex := (5.0, 7.0);
begin
 
Complex_Pack.Set_Re(X => TC_Complex, Re => 5.0);
 
if TC_Complex /= TC_Complex_Real_Field then
Report.Failed("Incorrect results from Procedure Set_Re");
end if;
 
Complex_Pack.Set_Im(X => TC_Complex, Im => 7.0);
 
if TC_Complex.Re /= 5.0 or
TC_Complex.Im /= 7.0 or
TC_Complex /= TC_Complex_Both_Fields
then
Report.Failed("Incorrect results from Procedure Set_Im " &
"with Complex argument");
end if;
 
Complex_Pack.Set_Im(X => TC_Imaginary, Im => 3.0);
 
 
if Complex_Pack.Im(TC_Imaginary) /= 3.0 then
Report.Failed("Incorrect results returned following the use " &
"of Procedure Set_Im with Imaginary argument");
end if;
 
end;
 
 
-- Check that the functions Re and Im (both versions) provide
-- correct results.
 
declare
TC_Complex_1 : Complex_Pack.Complex := (1.0, 0.0);
TC_Complex_2 : Complex_Pack.Complex := (0.0, 2.0);
TC_Complex_3 : Complex_Pack.Complex := (4.0, 3.0);
begin
 
-- Function Re.
 
if Complex_Pack.Re(X => TC_Complex_1) /= 1.0 or
Complex_Pack.Re(X => TC_Complex_2) /= 0.0 or
Complex_Pack.Re(X => TC_Complex_3) /= 4.0
then
Report.Failed("Incorrect results from Function Re");
end if;
 
-- Function Im; version with Complex argument.
 
if Complex_Pack.Im(X => TC_Complex_1) /= 0.0 or
Complex_Pack.Im(X => TC_Complex_2) /= 2.0 or
Complex_Pack.Im(X => TC_Complex_3) /= 3.0
then
Report.Failed("Incorrect results from Function Im " &
"with Complex argument");
end if;
 
 
-- Function Im; version with Imaginary argument.
 
if Complex_Pack.Im(Complex_Pack.i) /= 1.0 or
Complex_Pack.Im(Complex_Pack.j) /= 1.0
then
Report.Failed("Incorrect results from use of Function Im " &
"when used with an Imaginary argument");
end if;
 
end;
 
 
-- Verify the results of the three versions of Function
-- Compose_From_Cartesian
 
declare
 
Zero : constant Real_Type := 0.0;
Six : constant Real_Type := 6.0;
 
TC_Complex_1 : Complex_Pack.Complex := (3.0, 8.0);
TC_Complex_2 : Complex_Pack.Complex := (Six, Zero);
TC_Complex_3 : Complex_Pack.Complex := (Zero, 1.0);
 
begin
 
TC_Complex := Complex_Pack.Compose_From_Cartesian(3.0, 8.0);
 
if TC_Complex /= TC_Complex_1 then
Report.Failed("Incorrect results from Function " &
"Compose_From_Cartesian - 1");
end if;
 
-- If only one component is given, the other component is
-- implicitly zero (Both components are set by the following two
-- function calls).
 
TC_Complex := Complex_Pack.Compose_From_Cartesian(Re => 6.0);
 
if TC_Complex /= TC_Complex_2 then
Report.Failed("Incorrect results from Function " &
"Compose_From_Cartesian - 2");
end if;
 
TC_Complex :=
Complex_Pack.Compose_From_Cartesian(Im => Complex_Pack.i);
 
if TC_Complex /= TC_Complex_3 then
Report.Failed("Incorrect results from Function " &
"Compose_From_Cartesian - 3");
end if;
 
end;
 
 
-- Verify the results of Function Compose_From_Polar, Modulus, "abs",
-- and Argument.
 
declare
 
use Complex_Pack;
 
TC_Modulus,
TC_Argument : Real_Type := 0.0;
 
 
Angle_0 : constant Real_Type := 0.0;
Angle_90 : constant Real_Type := 90.0;
Angle_180 : constant Real_Type := 180.0;
Angle_270 : constant Real_Type := 270.0;
Angle_360 : constant Real_Type := 360.0;
 
begin
 
-- Verify the result of Function Compose_From_Polar.
-- When the value of the parameter Modulus is zero, the
-- Compose_From_Polar function yields a result of zero.
 
if Compose_From_Polar(0.0, 30.0, 360.0) /= Complex_Zero
then
Report.Failed("Incorrect result from Function " &
"Compose_From_Polar - 1");
end if;
 
-- When the value of the parameter Argument is equal to a multiple
-- of the quarter cycle, the result of the Compose_From_Polar
-- function with specified cycle lies on one of the axes.
 
if Compose_From_Polar( 5.0, Angle_0, Angle_360) /= (5.0, 0.0) or
Compose_From_Polar( 5.0, Angle_90, Angle_360) /= (0.0, 5.0) or
Compose_From_Polar(-5.0, Angle_180, Angle_360) /= (5.0, 0.0) or
Compose_From_Polar(-5.0, Angle_270, Angle_360) /= (0.0, 5.0) or
Compose_From_Polar(-5.0, Angle_90, Angle_360) /= (0.0, -5.0) or
Compose_From_Polar( 5.0, Angle_270, Angle_360) /= (0.0, -5.0)
then
Report.Failed("Incorrect result from Function " &
"Compose_From_Polar - 2");
end if;
 
-- When the parameter to Function Argument represents a point on
-- the non-negative real axis, the function yields a zero result.
 
if Argument(Complex_Zero, Angle_360) /= 0.0 then
Report.Failed("Incorrect result from Function Argument");
end if;
 
-- Function Modulus
 
if Modulus(Complex_Zero) /= 0.0 or
Modulus(Compose_From_Polar( 5.0, Angle_90, Angle_360)) /= 5.0 or
Modulus(Compose_From_Polar(-5.0, Angle_180, Angle_360)) /= 5.0
then
Report.Failed("Incorrect results from Function Modulus");
end if;
 
-- Function "abs", a rename of Function Modulus.
 
if "abs"(Complex_Zero) /= 0.0 or
"abs"(Compose_From_Polar( 5.0, Angle_90, Angle_360)) /= 5.0 or
"abs"(Compose_From_Polar(-5.0, Angle_180, Angle_360)) /= 5.0
then
Report.Failed("Incorrect results from Function abs");
end if;
 
end;
 
exception
when others => Report.Failed ("Exception raised in Test_Block");
end Test_Block;
 
Report.Result;
 
end CXG1001;
/cxg1002.a
0,0 → 1,198
-- CXG1002.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the subprograms defined in the package
-- Ada.Numerics.Generic_Complex_Types provide the prescribed results.
-- Specifically, check the various versions of functions "+" and "-".
--
-- TEST DESCRIPTION:
-- This test checks that the subprograms "+" and "-" defined in the
-- Generic_Complex_Types package provide the results prescribed for the
-- evaluation of these complex arithmetic operations. The functions
-- Re and Im are used to extract the appropriate component of the
-- complex result, in order that the prescribed result component can be
-- verified.
-- The generic package is instantiated with a real type (new Float),
-- and the results produced by the specified subprograms are verified.
--
-- SPECIAL REQUIREMENTS:
-- This test can be run in either "relaxed" or "strict" mode.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
with Ada.Numerics.Generic_Complex_Types;
with Report;
 
procedure CXG1002 is
 
begin
 
Report.Test ("CXG1002", "Check that the subprograms defined in " &
"the package Ada.Numerics.Generic_Complex_Types " &
"provide the prescribed results");
 
Test_Block:
declare
 
type Real_Type is new Float;
 
package Complex_Pack is new
Ada.Numerics.Generic_Complex_Types(Real_Type);
use Complex_Pack;
 
-- Declare a zero valued complex number using the record
-- aggregate approach.
 
Complex_Zero : constant Complex_Pack.Complex := (0.0, 0.0);
 
TC_Complex,
TC_Complex_Right,
TC_Complex_Left : Complex_Pack.Complex := Complex_Zero;
 
TC_Real : Real_Type := 0.0;
 
TC_Imaginary : Complex_Pack.Imaginary;
 
begin
 
 
-- Check that the imaginary component of the result of a binary addition
-- operator that yields a result of complex type is exact when either
-- of its operands is of pure-real type.
 
TC_Complex := Compose_From_Cartesian(2.0, 3.0);
TC_Real := 3.0;
 
if Im("+"(Left => TC_Complex, Right => TC_Real)) /= 3.0 or
Im("+"(TC_Complex, 6.0)) /= 3.0 or
Im(TC_Complex + TC_Real) /= 3.0 or
Im(TC_Complex + 5.0) /= 3.0 or
Im((7.0, 2.0) + 1.0) /= 2.0 or
Im((7.0, 5.0) + (-2.0)) /= 5.0 or
Im((-7.0, -2.0) + 1.0) /= -2.0 or
Im((-7.0, -3.0) + (-3.0)) /= -3.0
then
Report.Failed("Incorrect results from Function ""+"" with " &
"one Complex and one Real argument - 1");
end if;
 
if Im("+"(Left => TC_Real, Right => TC_Complex)) /= 3.0 or
Im("+"(4.0, TC_Complex)) /= 3.0 or
Im(TC_Real + TC_Complex) /= 3.0 or
Im(9.0 + TC_Complex) /= 3.0 or
Im(1.0 + (7.0, -9.0)) /= -9.0 or
Im((-2.0) + (7.0, 2.0)) /= 2.0 or
Im(1.0 + (-7.0, -5.0)) /= -5.0 or
Im((-3.0) + (-7.0, 16.0)) /= 16.0
then
Report.Failed("Incorrect results from Function ""+"" with " &
"one Complex and one Real argument - 2");
end if;
 
 
-- Check that the imaginary component of the result of a binary
-- subtraction operator that yields a result of complex type is exact
-- when its right operand is of pure-real type.
 
TC_Complex := (8.0, -4.0);
TC_Real := 2.0;
 
if Im("-"(Left => TC_Complex, Right => TC_Real)) /= -4.0 or
Im("-"(TC_Complex, 5.0)) /= -4.0 or
Im(TC_Complex - TC_Real) /= -4.0 or
Im(TC_Complex - 4.0) /= -4.0 or
Im((6.0, 5.0) - 1.0) /= 5.0 or
Im((6.0, 13.0) - 7.0) /= 13.0 or
Im((-5.0, 3.0) - (2.0)) /= 3.0 or
Im((-5.0, -6.0) - (-3.0)) /= -6.0
then
Report.Failed("Incorrect results from Function ""-"" with " &
"one Complex and one Real argument");
end if;
 
 
-- Check that the real component of the result of a binary addition
-- operator that yields a result of complex type is exact when either
-- of its operands is of pure-imaginary type.
 
TC_Complex := (5.0, 0.0);
 
if Re("+"(Left => TC_Complex, Right => i)) /= 5.0 or
Re("+"(Complex_Pack.j, TC_Complex)) /= 5.0 or
Re((-8.0, 5.0) + ( 2.0*i)) /= -8.0 or
Re((2.0, 5.0) + (-2.0*i)) /= 2.0 or
Re((-20.0, -5.0) + ( 3.0*i)) /= -20.0 or
Re((6.0, -5.0) + (-3.0*i)) /= 6.0
then
Report.Failed("Incorrect results from Function ""+"" with " &
"one Complex and one Imaginary argument");
end if;
 
 
-- Check that the real component of the result of a binary
-- subtraction operator that yields a result of complex type is exact
-- when its right operand is of pure-imaginary type.
 
TC_Complex := TC_Complex + i; -- Should produce (5.0, 1.0)
 
if Re("-"(TC_Complex, i)) /= 5.0 or
Re((-4.0, 4.0) - ( 2.0*i)) /= -4.0 or
Re((9.0, 4.0) - ( 5.0*i)) /= 9.0 or
Re((16.0, -5.0) - ( 3.0*i)) /= 16.0 or
Re((-3.0, -5.0) - (-4.0*i)) /= -3.0
then
Report.Failed("Incorrect results from Function ""-"" with " &
"one Complex and one Imaginary argument");
end if;
 
 
-- Check that the result of a binary addition operation is exact when
-- one of its operands is of real type and the other is of
-- pure-imaginary type; the operator is analogous to the
-- Compose_From_Cartesian function; it performs no arithmetic.
 
TC_Complex := Complex_Pack."+"(5.0, Complex_Pack.i);
 
if TC_Complex /= (5.0, 1.0) or
(4.0 + i) /= (4.0, 1.0) or
"+"(Left => j, Right => 3.0) /= (3.0, 1.0)
then
Report.Failed("Incorrect results from Function ""+"" with " &
"one Real and one Imaginary argument");
end if;
 
 
exception
when others => Report.Failed ("Exception raised in Test_Block");
end Test_Block;
 
Report.Result;
 
end CXG1002;
/cxg2001.a
0,0 → 1,322
-- CXG2001.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the floating point attributes Model_Mantissa,
-- Machine_Mantissa, Machine_Radix, and Machine_Rounds
-- are properly reported.
--
-- TEST DESCRIPTION:
-- This test uses a generic package to compute and check the
-- values of the Machine_ attributes listed above. The
-- generic package is instantiated with the standard FLOAT
-- type and a floating point type for the maximum number
-- of digits of precision.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
--
--
-- CHANGE HISTORY:
-- 26 JAN 96 SAIC Initial Release for 2.1
--
--!
 
-- References:
--
-- "Algorithms To Reveal Properties of Floating-Point Arithmetic"
-- Michael A. Malcolm; CACM November 1972; pgs 949-951.
--
-- Software Manual for Elementary Functions; W. J. Cody and W. Waite;
-- Prentice-Hall; 1980
-----------------------------------------------------------------------
--
-- This test relies upon the fact that
-- (A+2.0)-A is not necessarily 2.0. If A is large enough then adding
-- a small value to A does not change the value of A. Consider the case
-- where we have a decimal based floating point representation with 4
-- digits of precision. A floating point number would logically be
-- represented as "DDDD * 10 ** exp" where D is a value in the range 0..9.
-- The first loop of the test starts A at 2.0 and doubles it until
-- ((A+1.0)-A)-1.0 is no longer zero. For our decimal floating point
-- number this will be 1638 * 10**1 (the value 16384 rounded or truncated
-- to fit in 4 digits).
-- The second loop starts B at 2.0 and keeps doubling B until (A+B)-A is
-- no longer 0. This will keep looping until B is 8.0 because that is
-- the first value where rounding (assuming our machine rounds and addition
-- employs a guard digit) will change the upper 4 digits of the result:
-- 1638_
-- + 8
-- -------
-- 1639_
-- Without rounding the second loop will continue until
-- B is 16:
-- 1638_
-- + 16
-- -------
-- 1639_
--
-- The radix is then determined by (A+B)-A which will give 10.
--
-- The use of Tmp and ITmp in the test is to force values to be
-- stored into memory in the event that register precision is greater
-- than the stored precision of the floating point values.
--
--
-- The test for rounding is (ignoring the temporary variables used to
-- get the stored precision) is
-- Rounds := A + Radix/2.0 - A /= 0.0 ;
-- where A is the value determined in the first step that is the smallest
-- power of 2 such that A + 1.0 = A. This means that the true value of
-- A has one more digit in its value than 'Machine_Mantissa.
-- This check will detect the case where a value is always rounded.
-- There is an additional case where values are rounded to the nearest
-- even value. That is referred to as IEEE style rounding in the test.
--
-----------------------------------------------------------------------
 
with System;
with Report;
with Ada.Numerics.Generic_Elementary_Functions;
procedure CXG2001 is
Verbose : constant Boolean := False;
 
-- if one of the attribute computation loops exceeds Max_Iterations
-- it is most likely due to the compiler reordering an expression
-- that should not be reordered.
Illegal_Optimization : exception;
Max_Iterations : constant := 10_000;
 
generic
type Real is digits <>;
package Chk_Attrs is
procedure Do_Test;
end Chk_Attrs;
 
package body Chk_Attrs is
package EF is new Ada.Numerics.Generic_Elementary_Functions (Real);
function Log (X : Real) return Real renames EF.Log;
 
 
-- names used in paper
Radix : Integer; -- Beta
Mantissa_Digits : Integer; -- t
Rounds : Boolean; -- RND
 
-- made global to Determine_Attributes to help thwart optimization
A, B : Real := 2.0;
Tmp, Tmpa, Tmp1 : Real;
ITmp : Integer;
Half_Radix : Real;
 
-- special constants - not declared as constants so that
-- the "stored" precision will be used instead of a "register"
-- precision.
Zero : Real := 0.0;
One : Real := 1.0;
Two : Real := 2.0;
 
 
procedure Thwart_Optimization is
-- the purpose of this procedure is to reference the
-- global variables used by Determine_Attributes so
-- that the compiler is not likely to keep them in
-- a higher precision register for their entire lifetime.
begin
if Report.Ident_Bool (False) then
-- never executed
A := A + 5.0;
B := B + 6.0;
Tmp := Tmp + 1.0;
Tmp1 := Tmp1 + 2.0;
Tmpa := Tmpa + 2.0;
One := 12.34; Two := 56.78; Zero := 90.12;
end if;
end Thwart_Optimization;
 
 
-- determines values for Radix, Mantissa_Digits, and Rounds
-- This is mostly a straight translation of the C code.
-- The only significant addition is the iteration count
-- to prevent endless looping if things are really screwed up.
procedure Determine_Attributes is
Iterations : Integer;
begin
Rounds := True;
 
Iterations := 0;
Tmp := Real'Machine (((A + One) - A) - One);
while Tmp = Zero loop
A := Real'Machine(A + A);
Tmp := Real'Machine(A + One);
Tmp1 := Real'Machine(Tmp - A);
Tmp := Real'Machine(Tmp1 - One);
 
Iterations := Iterations + 1;
if Iterations > Max_Iterations then
raise Illegal_Optimization;
end if;
end loop;
 
Iterations := 0;
Tmp := Real'Machine(A + B);
ITmp := Integer (Tmp - A);
while ITmp = 0 loop
B := Real'Machine(B + B);
Tmp := Real'Machine(A + B);
ITmp := Integer (Tmp - A);
 
Iterations := Iterations + 1;
if Iterations > Max_Iterations then
raise Illegal_Optimization;
end if;
end loop;
 
Radix := ITmp;
 
Mantissa_Digits := 0;
B := 1.0;
Tmp := Real'Machine(((B + One) - B) - One);
Iterations := 0;
while (Tmp = Zero) loop
Mantissa_Digits := Mantissa_Digits + 1;
B := B * Real (Radix);
Tmp := Real'Machine(B + One);
Tmp1 := Real'Machine(Tmp - B);
Tmp := Real'Machine(Tmp1 - One);
 
Iterations := Iterations + 1;
if Iterations > Max_Iterations then
raise Illegal_Optimization;
end if;
end loop;
 
Rounds := False;
Half_Radix := Real (Radix) / Two;
Tmp := Real'Machine(A + Half_Radix);
Tmp1 := Real'Machine(Tmp - A);
if (Tmp1 /= Zero) then
Rounds := True;
end if;
Tmpa := Real'Machine(A + Real (Radix));
Tmp := Real'Machine(Tmpa + Half_Radix);
if not Rounds and (Tmp - TmpA /= Zero) then
Rounds := True;
if Verbose then
Report.Comment ("IEEE style rounding");
end if;
end if;
 
exception
when others =>
Thwart_Optimization;
raise;
end Determine_Attributes;
 
 
procedure Do_Test is
Show_Results : Boolean := Verbose;
Min_Mantissa_Digits : Integer;
begin
-- compute the actual Machine_* attribute values
Determine_Attributes;
 
if Real'Machine_Radix /= Radix then
Report.Failed ("'Machine_Radix incorrectly reports" &
Integer'Image (Real'Machine_Radix));
Show_Results := True;
end if;
 
if Real'Machine_Mantissa /= Mantissa_Digits then
Report.Failed ("'Machine_Mantissa incorrectly reports" &
Integer'Image (Real'Machine_Mantissa));
Show_Results := True;
end if;
 
if Real'Machine_Rounds /= Rounds then
Report.Failed ("'Machine_Rounds incorrectly reports " &
Boolean'Image (Real'Machine_Rounds));
Show_Results := True;
end if;
 
if Show_Results then
Report.Comment ("computed Machine_Mantissa is" &
Integer'Image (Mantissa_Digits));
Report.Comment ("computed Radix is" &
Integer'Image (Radix));
Report.Comment ("computed Rounds is " &
Boolean'Image (Rounds));
end if;
 
-- check the model attributes against the machine attributes
-- G.2.2(3)/3;6.0
if Real'Model_Mantissa > Real'Machine_Mantissa then
Report.Failed ("model mantissa > machine mantissa");
end if;
 
-- G.2.2(3)/2;6.0
-- 'Model_Mantissa >= ceiling(d*log(10)/log(radix))+1
Min_Mantissa_Digits :=
Integer (
Real'Ceiling (
Real(Real'Digits) * Log(10.0) / Log(Real(Real'Machine_Radix))
) ) + 1;
if Real'Model_Mantissa < Min_Mantissa_Digits then
Report.Failed ("Model_Mantissa [" &
Integer'Image (Real'Model_Mantissa) &
"] < minimum mantissa digits [" &
Integer'Image (Min_Mantissa_Digits) &
"]");
end if;
 
exception
when Illegal_Optimization =>
Report.Failed ("illegal optimization of" &
" floating point expression");
end Do_Test;
end Chk_Attrs;
 
package Chk_Float is new Chk_Attrs (Float);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
package Chk_A_Long_Float is new Chk_Attrs (A_Long_Float);
begin
Report.Test ("CXG2001",
"Check the attributes Model_Mantissa," &
" Machine_Mantissa, Machine_Radix," &
" and Machine_Rounds");
 
Report.Comment ("checking Standard.Float");
Chk_Float.Do_Test;
 
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
Chk_A_Long_Float.Do_Test;
 
Report.Result;
end CXG2001;
/cxg2010.a
0,0 → 1,892
-- CXG2010.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the exp function returns
-- results that are within the error bound allowed.
--
-- TEST DESCRIPTION:
-- This test contains three test packages that are almost
-- identical. The first two packages differ only in the
-- floating point type that is being tested. The first
-- and third package differ only in whether the generic
-- elementary functions package or the pre-instantiated
-- package is used.
-- The test package is not generic so that the arguments
-- and expected results for some of the test values
-- can be expressed as universal real instead of being
-- computed at runtime.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex and where the Machine_Radix is 2, 4, 8, or 16.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 1 Mar 96 SAIC Initial release for 2.1
-- 2 Sep 96 SAIC Improved check routine
--
--!
 
--
-- References:
--
-- Software Manual for the Elementary Functions
-- William J. Cody, Jr. and William Waite
-- Prentice-Hall, 1980
--
-- CRC Standard Mathematical Tables
-- 23rd Edition
--
-- Implementation and Testing of Function Software
-- W. J. Cody
-- Problems and Methodologies in Mathematical Software Production
-- editors P. C. Messina and A. Murli
-- Lecture Notes in Computer Science Volume 142
-- Springer Verlag, 1982
--
 
--
-- Notes on derivation of error bound for exp(p)*exp(-p)
--
-- Let a = true value of exp(p) and ac be the computed value.
-- Then a = ac(1+e1), where |e1| <= 4*Model_Epsilon.
-- Similarly, let b = true value of exp(-p) and bc be the computed value.
-- Then b = bc(1+e2), where |e2| <= 4*ME.
--
-- The product of x and y is (x*y)(1+e3), where |e3| <= 1.0ME
--
-- Hence, the computed ab is [ac(1+e1)*bc(1+e2)](1+e3) =
-- (ac*bc)[1 + e1 + e2 + e3 + e1e2 + e1e3 + e2e3 + e1e2e3).
--
-- Throwing away the last four tiny terms, we have (ac*bc)(1 + eta),
--
-- where |eta| <= (4+4+1)ME = 9.0Model_Epsilon.
 
with System;
with Report;
with Ada.Numerics.Generic_Elementary_Functions;
with Ada.Numerics.Elementary_Functions;
procedure CXG2010 is
Verbose : constant Boolean := False;
Max_Samples : constant := 1000;
Accuracy_Error_Reported : Boolean := False;
 
package Float_Check is
subtype Real is Float;
procedure Do_Test;
end Float_Check;
 
package body Float_Check is
package Elementary_Functions is new
Ada.Numerics.Generic_Elementary_Functions (Real);
function Sqrt (X : Real) return Real renames
Elementary_Functions.Sqrt;
function Exp (X : Real) return Real renames
Elementary_Functions.Exp;
 
 
-- The following value is a lower bound on the accuracy
-- required. It is normally 0.0 so that the lower bound
-- is computed from Model_Epsilon. However, for tests
-- where the expected result is only known to a certain
-- amount of precision this bound takes on a non-zero
-- value to account for that level of precision.
Error_Low_Bound : Real := 0.0;
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real) is
Max_Error : Real;
Rel_Error : Real;
Abs_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon
-- instead of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
-- take into account the low bound on the error
if Max_Error < Error_Low_Bound then
Max_Error := Error_Low_Bound;
end if;
 
if abs (Actual - Expected) > Max_Error then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Argument_Range_Check_1 (A, B : Real;
Test : String) is
-- test a evenly distributed selection of
-- arguments selected from the range A to B.
-- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
-- The parameter One_Minus_Exp_Minus_V is the value
-- 1.0 - Exp (-V)
-- accurate to machine precision.
-- This procedure is a translation of part of Cody's test
X : Real;
Y : Real;
ZX, ZY : Real;
V : constant := 1.0 / 16.0;
One_Minus_Exp_Minus_V : constant := 6.058693718652421388E-2;
 
begin
Accuracy_Error_Reported := False;
for I in 1..Max_Samples loop
X := (B - A) * Real (I) / Real (Max_Samples) + A;
Y := X - V;
if Y < 0.0 then
X := Y + V;
end if;
 
ZX := Exp (X);
ZY := Exp (Y);
 
-- ZX := Exp(X) - Exp(X) * (1 - Exp(-V);
-- which simplifies to ZX := Exp (X-V);
ZX := ZX - ZX * One_Minus_Exp_Minus_V;
 
-- note that since the expected value is computed, we
-- must take the error in that computation into account.
Check (ZY, ZX,
"test " & Test & " -" &
Integer'Image (I) &
" exp (" & Real'Image (X) & ")",
9.0);
exit when Accuracy_Error_Reported;
end loop;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in argument range check 1");
when others =>
Report.Failed ("exception in argument range check 1");
end Argument_Range_Check_1;
 
 
 
procedure Argument_Range_Check_2 (A, B : Real;
Test : String) is
-- test a evenly distributed selection of
-- arguments selected from the range A to B.
-- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
-- The parameter One_Minus_Exp_Minus_V is the value
-- 1.0 - Exp (-V)
-- accurate to machine precision.
-- This procedure is a translation of part of Cody's test
X : Real;
Y : Real;
ZX, ZY : Real;
V : constant := 45.0 / 16.0;
-- 1/16 - Exp(45/16)
Coeff : constant := 2.4453321046920570389E-3;
 
begin
Accuracy_Error_Reported := False;
for I in 1..Max_Samples loop
X := (B - A) * Real (I) / Real (Max_Samples) + A;
Y := X - V;
if Y < 0.0 then
X := Y + V;
end if;
 
ZX := Exp (X);
ZY := Exp (Y);
 
-- ZX := Exp(X) * 1/16 - Exp(X) * Coeff;
-- where Coeff is 1/16 - Exp(45/16)
-- which simplifies to ZX := Exp (X-V);
ZX := ZX * 0.0625 - ZX * Coeff;
 
-- note that since the expected value is computed, we
-- must take the error in that computation into account.
Check (ZY, ZX,
"test " & Test & " -" &
Integer'Image (I) &
" exp (" & Real'Image (X) & ")",
9.0);
exit when Accuracy_Error_Reported;
end loop;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in argument range check 2");
when others =>
Report.Failed ("exception in argument range check 2");
end Argument_Range_Check_2;
 
 
procedure Do_Test is
begin
 
--- test 1 ---
declare
Y : Real;
begin
Y := Exp(1.0);
-- normal accuracy requirements
Check (Y, Ada.Numerics.e, "test 1 -- exp(1)", 4.0);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 1");
when others =>
Report.Failed ("exception in test 1");
end;
 
--- test 2 ---
declare
Y : Real;
begin
Y := Exp(16.0) * Exp(-16.0);
Check (Y, 1.0, "test 2 -- exp(16)*exp(-16)", 9.0);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 2");
when others =>
Report.Failed ("exception in test 2");
end;
 
--- test 3 ---
declare
Y : Real;
begin
Y := Exp (Ada.Numerics.Pi) * Exp (-Ada.Numerics.Pi);
Check (Y, 1.0, "test 3 -- exp(pi)*exp(-pi)", 9.0);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 3");
when others =>
Report.Failed ("exception in test 3");
end;
 
--- test 4 ---
declare
Y : Real;
begin
Y := Exp(0.0);
Check (Y, 1.0, "test 4 -- exp(0.0)",
0.0); -- no error allowed
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 4");
when others =>
Report.Failed ("exception in test 4");
end;
 
--- test 5 ---
-- constants used here only have 19 digits of precision
if Real'Digits > 19 then
Error_Low_Bound := 0.00000_00000_00000_0001;
Report.Comment ("exp accuracy checked to 19 digits");
end if;
 
Argument_Range_Check_1 ( 1.0/Sqrt(Real(Real'Machine_Radix)),
1.0,
"5");
Error_Low_Bound := 0.0; -- reset
 
--- test 6 ---
-- constants used here only have 19 digits of precision
if Real'Digits > 19 then
Error_Low_Bound := 0.00000_00000_00000_0001;
Report.Comment ("exp accuracy checked to 19 digits");
end if;
 
Argument_Range_Check_2 (1.0,
Sqrt(Real(Real'Machine_Radix)),
"6");
Error_Low_Bound := 0.0; -- reset
 
end Do_Test;
end Float_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
 
 
package A_Long_Float_Check is
subtype Real is A_Long_Float;
procedure Do_Test;
end A_Long_Float_Check;
 
package body A_Long_Float_Check is
package Elementary_Functions is new
Ada.Numerics.Generic_Elementary_Functions (Real);
function Sqrt (X : Real) return Real renames
Elementary_Functions.Sqrt;
function Exp (X : Real) return Real renames
Elementary_Functions.Exp;
 
 
-- The following value is a lower bound on the accuracy
-- required. It is normally 0.0 so that the lower bound
-- is computed from Model_Epsilon. However, for tests
-- where the expected result is only known to a certain
-- amount of precision this bound takes on a non-zero
-- value to account for that level of precision.
Error_Low_Bound : Real := 0.0;
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real) is
Max_Error : Real;
Rel_Error : Real;
Abs_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon
-- instead of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
-- take into account the low bound on the error
if Max_Error < Error_Low_Bound then
Max_Error := Error_Low_Bound;
end if;
 
if abs (Actual - Expected) > Max_Error then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Argument_Range_Check_1 (A, B : Real;
Test : String) is
-- test a evenly distributed selection of
-- arguments selected from the range A to B.
-- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
-- The parameter One_Minus_Exp_Minus_V is the value
-- 1.0 - Exp (-V)
-- accurate to machine precision.
-- This procedure is a translation of part of Cody's test
X : Real;
Y : Real;
ZX, ZY : Real;
V : constant := 1.0 / 16.0;
One_Minus_Exp_Minus_V : constant := 6.058693718652421388E-2;
 
begin
Accuracy_Error_Reported := False;
for I in 1..Max_Samples loop
X := (B - A) * Real (I) / Real (Max_Samples) + A;
Y := X - V;
if Y < 0.0 then
X := Y + V;
end if;
 
ZX := Exp (X);
ZY := Exp (Y);
 
-- ZX := Exp(X) - Exp(X) * (1 - Exp(-V);
-- which simplifies to ZX := Exp (X-V);
ZX := ZX - ZX * One_Minus_Exp_Minus_V;
 
-- note that since the expected value is computed, we
-- must take the error in that computation into account.
Check (ZY, ZX,
"test " & Test & " -" &
Integer'Image (I) &
" exp (" & Real'Image (X) & ")",
9.0);
exit when Accuracy_Error_Reported;
end loop;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in argument range check 1");
when others =>
Report.Failed ("exception in argument range check 1");
end Argument_Range_Check_1;
 
 
 
procedure Argument_Range_Check_2 (A, B : Real;
Test : String) is
-- test a evenly distributed selection of
-- arguments selected from the range A to B.
-- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
-- The parameter One_Minus_Exp_Minus_V is the value
-- 1.0 - Exp (-V)
-- accurate to machine precision.
-- This procedure is a translation of part of Cody's test
X : Real;
Y : Real;
ZX, ZY : Real;
V : constant := 45.0 / 16.0;
-- 1/16 - Exp(45/16)
Coeff : constant := 2.4453321046920570389E-3;
 
begin
Accuracy_Error_Reported := False;
for I in 1..Max_Samples loop
X := (B - A) * Real (I) / Real (Max_Samples) + A;
Y := X - V;
if Y < 0.0 then
X := Y + V;
end if;
 
ZX := Exp (X);
ZY := Exp (Y);
 
-- ZX := Exp(X) * 1/16 - Exp(X) * Coeff;
-- where Coeff is 1/16 - Exp(45/16)
-- which simplifies to ZX := Exp (X-V);
ZX := ZX * 0.0625 - ZX * Coeff;
 
-- note that since the expected value is computed, we
-- must take the error in that computation into account.
Check (ZY, ZX,
"test " & Test & " -" &
Integer'Image (I) &
" exp (" & Real'Image (X) & ")",
9.0);
exit when Accuracy_Error_Reported;
end loop;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in argument range check 2");
when others =>
Report.Failed ("exception in argument range check 2");
end Argument_Range_Check_2;
 
 
procedure Do_Test is
begin
 
--- test 1 ---
declare
Y : Real;
begin
Y := Exp(1.0);
-- normal accuracy requirements
Check (Y, Ada.Numerics.e, "test 1 -- exp(1)", 4.0);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 1");
when others =>
Report.Failed ("exception in test 1");
end;
 
--- test 2 ---
declare
Y : Real;
begin
Y := Exp(16.0) * Exp(-16.0);
Check (Y, 1.0, "test 2 -- exp(16)*exp(-16)", 9.0);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 2");
when others =>
Report.Failed ("exception in test 2");
end;
 
--- test 3 ---
declare
Y : Real;
begin
Y := Exp (Ada.Numerics.Pi) * Exp (-Ada.Numerics.Pi);
Check (Y, 1.0, "test 3 -- exp(pi)*exp(-pi)", 9.0);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 3");
when others =>
Report.Failed ("exception in test 3");
end;
 
--- test 4 ---
declare
Y : Real;
begin
Y := Exp(0.0);
Check (Y, 1.0, "test 4 -- exp(0.0)",
0.0); -- no error allowed
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 4");
when others =>
Report.Failed ("exception in test 4");
end;
 
--- test 5 ---
-- constants used here only have 19 digits of precision
if Real'Digits > 19 then
Error_Low_Bound := 0.00000_00000_00000_0001;
Report.Comment ("exp accuracy checked to 19 digits");
end if;
 
Argument_Range_Check_1 ( 1.0/Sqrt(Real(Real'Machine_Radix)),
1.0,
"5");
Error_Low_Bound := 0.0; -- reset
 
--- test 6 ---
-- constants used here only have 19 digits of precision
if Real'Digits > 19 then
Error_Low_Bound := 0.00000_00000_00000_0001;
Report.Comment ("exp accuracy checked to 19 digits");
end if;
 
Argument_Range_Check_2 (1.0,
Sqrt(Real(Real'Machine_Radix)),
"6");
Error_Low_Bound := 0.0; -- reset
 
end Do_Test;
end A_Long_Float_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
package Non_Generic_Check is
procedure Do_Test;
subtype Real is Float;
end Non_Generic_Check;
 
package body Non_Generic_Check is
 
package Elementary_Functions renames
Ada.Numerics.Elementary_Functions;
function Sqrt (X : Real) return Real renames
Elementary_Functions.Sqrt;
function Exp (X : Real) return Real renames
Elementary_Functions.Exp;
 
 
-- The following value is a lower bound on the accuracy
-- required. It is normally 0.0 so that the lower bound
-- is computed from Model_Epsilon. However, for tests
-- where the expected result is only known to a certain
-- amount of precision this bound takes on a non-zero
-- value to account for that level of precision.
Error_Low_Bound : Real := 0.0;
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real) is
Max_Error : Real;
Rel_Error : Real;
Abs_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon
-- instead of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
-- take into account the low bound on the error
if Max_Error < Error_Low_Bound then
Max_Error := Error_Low_Bound;
end if;
 
if abs (Actual - Expected) > Max_Error then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Argument_Range_Check_1 (A, B : Real;
Test : String) is
-- test a evenly distributed selection of
-- arguments selected from the range A to B.
-- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
-- The parameter One_Minus_Exp_Minus_V is the value
-- 1.0 - Exp (-V)
-- accurate to machine precision.
-- This procedure is a translation of part of Cody's test
X : Real;
Y : Real;
ZX, ZY : Real;
V : constant := 1.0 / 16.0;
One_Minus_Exp_Minus_V : constant := 6.058693718652421388E-2;
 
begin
Accuracy_Error_Reported := False;
for I in 1..Max_Samples loop
X := (B - A) * Real (I) / Real (Max_Samples) + A;
Y := X - V;
if Y < 0.0 then
X := Y + V;
end if;
 
ZX := Exp (X);
ZY := Exp (Y);
 
-- ZX := Exp(X) - Exp(X) * (1 - Exp(-V);
-- which simplifies to ZX := Exp (X-V);
ZX := ZX - ZX * One_Minus_Exp_Minus_V;
 
-- note that since the expected value is computed, we
-- must take the error in that computation into account.
Check (ZY, ZX,
"test " & Test & " -" &
Integer'Image (I) &
" exp (" & Real'Image (X) & ")",
9.0);
exit when Accuracy_Error_Reported;
end loop;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in argument range check 1");
when others =>
Report.Failed ("exception in argument range check 1");
end Argument_Range_Check_1;
 
 
 
procedure Argument_Range_Check_2 (A, B : Real;
Test : String) is
-- test a evenly distributed selection of
-- arguments selected from the range A to B.
-- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
-- The parameter One_Minus_Exp_Minus_V is the value
-- 1.0 - Exp (-V)
-- accurate to machine precision.
-- This procedure is a translation of part of Cody's test
X : Real;
Y : Real;
ZX, ZY : Real;
V : constant := 45.0 / 16.0;
-- 1/16 - Exp(45/16)
Coeff : constant := 2.4453321046920570389E-3;
 
begin
Accuracy_Error_Reported := False;
for I in 1..Max_Samples loop
X := (B - A) * Real (I) / Real (Max_Samples) + A;
Y := X - V;
if Y < 0.0 then
X := Y + V;
end if;
 
ZX := Exp (X);
ZY := Exp (Y);
 
-- ZX := Exp(X) * 1/16 - Exp(X) * Coeff;
-- where Coeff is 1/16 - Exp(45/16)
-- which simplifies to ZX := Exp (X-V);
ZX := ZX * 0.0625 - ZX * Coeff;
 
-- note that since the expected value is computed, we
-- must take the error in that computation into account.
Check (ZY, ZX,
"test " & Test & " -" &
Integer'Image (I) &
" exp (" & Real'Image (X) & ")",
9.0);
exit when Accuracy_Error_Reported;
end loop;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in argument range check 2");
when others =>
Report.Failed ("exception in argument range check 2");
end Argument_Range_Check_2;
 
 
procedure Do_Test is
begin
 
--- test 1 ---
declare
Y : Real;
begin
Y := Exp(1.0);
-- normal accuracy requirements
Check (Y, Ada.Numerics.e, "test 1 -- exp(1)", 4.0);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 1");
when others =>
Report.Failed ("exception in test 1");
end;
 
--- test 2 ---
declare
Y : Real;
begin
Y := Exp(16.0) * Exp(-16.0);
Check (Y, 1.0, "test 2 -- exp(16)*exp(-16)", 9.0);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 2");
when others =>
Report.Failed ("exception in test 2");
end;
 
--- test 3 ---
declare
Y : Real;
begin
Y := Exp (Ada.Numerics.Pi) * Exp (-Ada.Numerics.Pi);
Check (Y, 1.0, "test 3 -- exp(pi)*exp(-pi)", 9.0);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 3");
when others =>
Report.Failed ("exception in test 3");
end;
 
--- test 4 ---
declare
Y : Real;
begin
Y := Exp(0.0);
Check (Y, 1.0, "test 4 -- exp(0.0)",
0.0); -- no error allowed
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 4");
when others =>
Report.Failed ("exception in test 4");
end;
 
--- test 5 ---
-- constants used here only have 19 digits of precision
if Real'Digits > 19 then
Error_Low_Bound := 0.00000_00000_00000_0001;
Report.Comment ("exp accuracy checked to 19 digits");
end if;
 
Argument_Range_Check_1 ( 1.0/Sqrt(Real(Real'Machine_Radix)),
1.0,
"5");
Error_Low_Bound := 0.0; -- reset
 
--- test 6 ---
-- constants used here only have 19 digits of precision
if Real'Digits > 19 then
Error_Low_Bound := 0.00000_00000_00000_0001;
Report.Comment ("exp accuracy checked to 19 digits");
end if;
 
Argument_Range_Check_2 (1.0,
Sqrt(Real(Real'Machine_Radix)),
"6");
Error_Low_Bound := 0.0; -- reset
 
end Do_Test;
end Non_Generic_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
begin
Report.Test ("CXG2010",
"Check the accuracy of the exp function");
 
-- the test only applies to machines with a radix of 2,4,8, or 16
case Float'Machine_Radix is
when 2 | 4 | 8 | 16 => null;
when others =>
Report.Not_Applicable ("only applicable to binary radix");
Report.Result;
return;
end case;
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking non-generic package");
end if;
 
Non_Generic_Check.Do_Test;
 
Report.Result;
end CXG2010;
/cxg2020.a
0,0 → 1,351
-- CXG2020.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the complex SQRT function returns
-- a result that is within the error bound allowed.
--
-- TEST DESCRIPTION:
-- This test consists of a generic package that is
-- instantiated to check complex numbers based upon
-- both Float and a long float type.
-- The test for each floating point type is divided into
-- several parts:
-- Special value checks where the result is a known constant.
-- Checks that use an identity for determining the result.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 24 Mar 96 SAIC Initial release for 2.1
-- 17 Aug 96 SAIC Incorporated reviewer comments.
-- 03 Jun 98 EDS Added parens to ensure that the expression is not
-- evaluated by multiplying its two large terms
-- together and overflowing.
--!
 
--
-- References:
--
-- W. J. Cody
-- CELEFUNT: A Portable Test Package for Complex Elementary Functions
-- Algorithm 714, Collected Algorithms from ACM.
-- Published in Transactions On Mathematical Software,
-- Vol. 19, No. 1, March, 1993, pp. 1-21.
--
-- CRC Standard Mathematical Tables
-- 23rd Edition
--
 
with System;
with Report;
with Ada.Numerics.Generic_Complex_Types;
with Ada.Numerics.Generic_Complex_Elementary_Functions;
procedure CXG2020 is
Verbose : constant Boolean := False;
-- Note that Max_Samples is the number of samples taken in
-- both the real and imaginary directions. Thus, for Max_Samples
-- of 100 the number of values checked is 10000.
Max_Samples : constant := 100;
 
E : constant := Ada.Numerics.E;
Pi : constant := Ada.Numerics.Pi;
 
-- CRC Standard Mathematical Tables; 23rd Edition; pg 738
Sqrt2 : constant :=
1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
Sqrt3 : constant :=
1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
 
generic
type Real is digits <>;
package Generic_Check is
procedure Do_Test;
end Generic_Check;
 
package body Generic_Check is
package Complex_Type is new
Ada.Numerics.Generic_Complex_Types (Real);
use Complex_Type;
 
package CEF is new
Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type);
 
function Sqrt (X : Complex) return Complex renames CEF.Sqrt;
 
-- flag used to terminate some tests early
Accuracy_Error_Reported : Boolean := False;
 
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real) is
Max_Error : Real;
Rel_Error : Real;
Abs_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon
-- instead of Model_Epsilon and Expected.
Rel_Error := MRE * (abs Expected * Real'Model_Epsilon);
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual - Expected) > Max_Error then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Check (Actual, Expected : Complex;
Test_Name : String;
MRE : Real) is
begin
Check (Actual.Re, Expected.Re, Test_Name & " real part", MRE);
Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", MRE);
end Check;
 
 
procedure Special_Value_Test is
-- In the following tests the expected result is accurate
-- to the machine precision so the minimum guaranteed error
-- bound can be used if the argument is exact.
--
-- One or i is added to the actual and expected results in
-- order to prevent the expected result from having a
-- real or imaginary part of 0. This is to allow a reasonable
-- relative error for that component.
Minimum_Error : constant := 6.0;
Z1, Z2 : Complex;
begin
Check (Sqrt(9.0+0.0*i) + i,
3.0+1.0*i,
"sqrt(9+0i)+i",
Minimum_Error);
Check (Sqrt (-2.0 + 0.0 * i) + 1.0,
1.0 + Sqrt2 * i,
"sqrt(-2)+1 ",
Minimum_Error);
 
-- make sure no exception occurs when taking the sqrt of
-- very large and very small values.
 
Z1 := (Real'Safe_Last * 0.9, Real'Safe_Last * 0.9);
Z2 := Sqrt (Z1);
begin
Check (Z2 * Z2,
Z1,
"sqrt((big,big))",
Minimum_Error + 5.0); -- +5 for multiply
exception
when others =>
Report.Failed ("unexpected exception in sqrt((big,big))");
end;
Z1 := (Real'Model_Epsilon * 10.0, Real'Model_Epsilon * 10.0);
Z2 := Sqrt (Z1);
begin
Check (Z2 * Z2,
Z1,
"sqrt((little,little))",
Minimum_Error + 5.0); -- +5 for multiply
exception
when others =>
Report.Failed ("unexpected exception in " &
"sqrt((little,little))");
end;
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in special value test");
when others =>
Report.Failed ("exception in special value test");
end Special_Value_Test;
 
 
 
procedure Exact_Result_Test is
No_Error : constant := 0.0;
begin
-- G.1.2(36);6.0
Check (Sqrt(0.0 + 0.0*i), 0.0 + 0.0 * i, "sqrt(0+0i)", No_Error);
 
-- G.1.2(37);6.0
Check (Sqrt(1.0 + 0.0*i), 1.0 + 0.0 * i, "sqrt(1+0i)", No_Error);
 
-- G.1.2(38-39);6.0
Check (Sqrt(-1.0 + 0.0*i), 0.0 + 1.0 * i, "sqrt(-1+0i)", No_Error);
 
-- G.1.2(40);6.0
if Real'Signed_Zeros then
Check (Sqrt(-1.0-0.0*i), 0.0 - 1.0 * i, "sqrt(-1-0i)", No_Error);
end if;
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in Exact_Result Test");
when others =>
Report.Failed ("exception in Exact_Result Test");
end Exact_Result_Test;
 
 
procedure Identity_Test (RA, RB, IA, IB : Real) is
-- Tests an identity over a range of values specified
-- by the 4 parameters. RA and RB denote the range for the
-- real part while IA and IB denote the range for the
-- imaginary part of the result.
--
-- For this test we use the identity
-- Sqrt(Z*Z) = Z
--
 
Scale : Real := Real (Real'Machine_Radix) ** (Real'Mantissa / 2 + 4);
W, X, Y, Z : Real;
CX : Complex;
Actual, Expected : Complex;
begin
Accuracy_Error_Reported := False; -- reset
for II in 1..Max_Samples loop
X := (RB - RA) * Real (II) / Real (Max_Samples) + RA;
for J in 1..Max_Samples loop
Y := (IB - IA) * Real (J) / Real (Max_Samples) + IA;
-- purify the arguments to minimize roundoff error.
-- We construct the values so that the products X*X,
-- Y*Y, and X*Y are all exact machine numbers.
-- See Cody page 7 and CELEFUNT code.
Z := X * Scale;
W := Z + X;
X := W - Z;
Z := Y * Scale;
W := Z + Y;
Y := W - Z;
-- G.1.2(21);6.0 - real part of result is non-negative
Expected := Compose_From_Cartesian( abs X,Y);
Z := X*X - Y*Y;
W := X*Y;
CX := Compose_From_Cartesian(Z,W+W);
-- The arguments are now ready so on with the
-- identity computation.
Actual := Sqrt(CX);
Check (Actual, Expected,
"Identity_1_Test " & Integer'Image (II) &
Integer'Image (J) & ": Sqrt((" &
Real'Image (CX.Re) & ", " &
Real'Image (CX.Im) & ")) ",
8.5); -- 6.0 from sqrt, 2.5 from argument.
-- See Cody pg 7-8 for analysis of additional error amount.
 
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
end loop;
end loop;
 
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Identity_Test" &
" for X=(" & Real'Image (X) &
", " & Real'Image (X) & ")");
when others =>
Report.Failed ("exception in Identity_Test" &
" for X=(" & Real'Image (X) &
", " & Real'Image (X) & ")");
end Identity_Test;
 
 
procedure Do_Test is
begin
Special_Value_Test;
Exact_Result_Test;
-- ranges where the sign is the same and where it
-- differs.
Identity_Test ( 0.0, 10.0, 0.0, 10.0);
Identity_Test ( 0.0, 100.0, -100.0, 0.0);
end Do_Test;
end Generic_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
package Float_Check is new Generic_Check (Float);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
package A_Long_Float_Check is new Generic_Check (A_Long_Float);
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
 
begin
Report.Test ("CXG2020",
"Check the accuracy of the complex SQRT function");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
 
Report.Result;
end CXG2020;
/cxg1003.a
0,0 → 1,478
-- CXG1003.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the subprograms defined in the package Text_IO.Complex_IO
-- provide correct results.
--
-- TEST DESCRIPTION:
-- The generic package Ada.Numerics.Generic_Complex_Types is instantiated
-- with a real type (new Float). The resulting new package is used as
-- the generic actual to package Complex_IO.
-- Two different versions of Put and Get are examined in this test,
-- those that input/output complex data values from/to Text_IO files,
-- and those that input/output complex data values from/to strings.
-- Two procedures are defined to perform the file data manipulations;
-- one to place complex data into the file, and one to retrieve the data
-- from the file and verify its correctness.
-- Complex data is also put into string variables using the Procedure
-- Put for strings, and this data is then retrieved and reconverted into
-- complex values using the Get procedure.
--
--
-- APPLICABILITY CRITERIA:
-- This test is only applicable to implementations that:
-- support Annex G,
-- support Text_IO and external files
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 29 Dec 94 SAIC Modified Width parameter in Get function calls.
-- 16 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1.
-- 29 Sep 96 SAIC Incorporated reviewer comments.
--
--!
 
with Ada.Text_IO.Complex_IO;
with Ada.Numerics.Generic_Complex_Types;
with Report;
 
procedure CXG1003 is
begin
 
Report.Test ("CXG1003", "Check that the subprograms defined in " &
"the package Text_IO.Complex_IO " &
"provide correct results");
 
Test_for_Text_IO_Support:
declare
use Ada;
 
Data_File : Ada.Text_IO.File_Type;
Data_Filename : constant String := Report.Legal_File_Name;
 
begin
 
-- An application creates a text file in mode Out_File, with the
-- intention of entering complex data into the file as appropriate.
-- In the event that the particular environment where the application
-- is running does not support Text_IO, Use_Error or Name_Error will be
-- raised on calls to Text_IO operations. Either of these exceptions
-- will be handled to produce a Not_Applicable result.
 
Text_IO.Create (File => Data_File,
Mode => Ada.Text_IO.Out_File,
Name => Data_Filename);
 
Test_Block:
declare
 
TC_Verbose : Boolean := False;
 
type Real_Type is new Float;
 
package Complex_Pack is new
Ada.Numerics.Generic_Complex_Types(Real_Type);
 
package C_IO is new Ada.Text_IO.Complex_IO(Complex_Pack);
 
use Ada.Text_IO, C_IO;
use type Complex_Pack.Complex;
 
Number_Of_Complex_Items : constant := 6;
Number_Of_Error_Items : constant := 2;
 
TC_Complex : Complex_Pack.Complex;
TC_Last_Character_Read : Positive;
 
Complex_Array : array (1..Number_Of_Complex_Items)
of Complex_Pack.Complex := ( (3.0, 9.0),
(4.0, 7.0),
(5.0, 6.0),
(6.0, 3.0),
(2.0, 5.0),
(3.0, 7.0) );
 
 
procedure Load_Data_File (The_File : in out Text_IO.File_Type) is
use Ada.Text_IO;
begin
-- This procedure does not create, open, or close the data file;
-- The_File file object must be Open at this point.
-- This procedure is designed to load complex data into a data
-- file twice, first using Text_IO, then Complex_IO. In this
-- first case, the complex data values are entered as strings,
-- assuming a variety of legal formats, as provided in the
-- reference manual.
 
Put_Line(The_File, "(3.0, 9.0)");
Put_Line(The_File, "+4. +7."); -- Relaxed real literal format.
Put_Line(The_File, "(5.0 6.)");
Put_Line(The_File, "6., 3.0");
Put_Line(The_File, " ( 2.0 , 5.0 ) ");
Put_Line(The_File, "("); -- Complex data separated over
Put_Line(The_File, "3.0"); -- several (5) lines.
Put_Line(The_File, " , ");
Put_Line(The_File, "7.0 ");
Put_Line(The_File, ")");
 
if TC_Verbose then
Report.Comment("Complex values entered into data file using " &
"Text_IO, Procedure Load_Data_File");
end if;
 
-- Use the Complex_IO procedure Put to enter Complex data items
-- into the data file.
-- Note: Data is being entered into the file for the *second* time
-- at this point. (Using Complex_IO here, Text_IO above)
 
for i in 1..Number_Of_Complex_Items loop
C_IO.Put(File => The_File,
Item => Complex_Array(i),
Fore => 1,
Aft => 1,
Exp => 0);
end loop;
 
if TC_Verbose then
Report.Comment("Complex values entered into data file using " &
"Complex_IO, Procedure Load_Data_File");
end if;
 
Put_Line(The_File, "(5A,3)"); -- data to raise Data_Error.
Put_Line(The_File, "(3.0,,8.0)"); -- data to raise Data_Error.
 
end Load_Data_File;
 
 
 
procedure Process_Data_File (The_File : in out Text_IO.File_Type) is
TC_Complex : Complex_Pack.Complex := (0.0, 0.0);
TC_Width : Integer := 0;
begin
-- This procedure does not create, open, or close the data file;
-- The_File file object must be Open at this point.
-- Use procedure Get (for Files) to extract the complex data from
-- the Text_IO file. This data was placed into the file using
-- Text_IO.
 
 
for i in 1..Number_Of_Complex_Items loop
C_IO.Get(The_File, TC_Complex, TC_Width);
 
if TC_Complex /= Complex_Array(i) then
Report.Failed("Incorrect complex data read from file " &
"when using Text_IO procedure Get, " &
"data item #" & Integer'Image(i));
end if;
end loop;
 
if TC_Verbose then
Report.Comment("First set of complex values extracted " &
"from data file using Complex_IO, " &
"Procedure Process_Data_File");
end if;
 
-- Use procedure Get (for Files) to extract the complex data from
-- the Text_IO file. This data was placed into the file using
-- procedure Complex_IO.Put.
-- Note: Data is being extracted from the file for the *second*
-- time at this point (Using Complex_IO here, Text_IO above)
 
for i in 1..Number_Of_Complex_Items loop
C_IO.Get(The_File, TC_Complex, TC_Width);
if TC_Complex /= Complex_Array(i) then
Report.Failed("Incorrect complex data read from file " &
"when using Complex_IO procedure Get, " &
"data item #" & Integer'Image(i));
end if;
end loop;
 
if TC_Verbose then
Report.Comment("Second set of complex values extracted " &
"from data file using Complex_IO, " &
"Procedure Process_Data_File");
end if;
 
-- The final items in the Data_File are complex values with
-- incorrect syntax, which should raise Data_Error on an attempt
-- to read them from the file.
TC_Width := 10;
for i in 1..Number_Of_Error_Items loop
begin
C_IO.Get(The_File, TC_Complex, TC_Width);
Report.Failed
("Exception Data_Error not raised when Complex_IO.Get " &
"was used to read complex data with incorrect " &
"syntax from the Data_File, data item #" &
Integer'Image(i));
exception
when Ada.Text_IO.Data_Error => -- OK, expected exception.
Text_IO.Skip_Line(The_File);
when others =>
Report.Failed
("Unexpected exception raised when Complex_IO.Get " &
"was used to read complex data with incorrect " &
"syntax from the Data_File, data item #" &
Integer'Image(i));
end;
end loop;
 
if TC_Verbose then
Report.Comment("Erroneous set of complex values extracted " &
"from data file using Complex_IO, " &
"Procedure Process_Data_File");
end if;
 
 
exception
when others =>
Report.Failed
("Unexpected exception raised in Process_Data_File");
end Process_Data_File;
 
 
 
begin -- Test_Block.
 
-- Place complex values into data file.
 
Load_Data_File(Data_File);
Text_IO.Close(Data_File);
 
if TC_Verbose then
Report.Comment("Data file loaded with Complex values");
end if;
 
-- Read complex values from data file.
 
Text_IO.Open(Data_File, Text_IO.In_File, Data_Filename);
Process_Data_File(Data_File);
 
if TC_Verbose then
Report.Comment("Complex values extracted from data file");
end if;
 
 
 
-- Verify versions of Procedures Put and Get for Strings.
 
declare
TC_String_Array : array (1..Number_Of_Complex_Items)
of String(1..15) := (others =>(others => ' '));
begin
 
-- Place complex values into strings using the Procedure Put.
 
for i in 1..Number_Of_Complex_Items loop
C_IO.Put(To => TC_String_Array(i),
Item => Complex_Array(i),
Aft => 1,
Exp => 0);
end loop;
 
if TC_Verbose then
Report.Comment("Complex values placed into string array");
end if;
 
-- Check the format of the strings containing a complex number.
-- The resulting strings are of 15 character length, with the
-- real component left justified within the string, followed by
-- a comma, and with the imaginary component and closing
-- parenthesis right justified in the string, with blank fill
-- for the balance of the string.
 
if TC_String_Array(1) /= "(3.0, 9.0)" or
TC_String_Array(2) /= "(4.0, 7.0)" or
TC_String_Array(3) /= "(5.0, 6.0)" or
TC_String_Array(4) /= "(6.0, 3.0)" or
TC_String_Array(5) /= "(2.0, 5.0)" or
TC_String_Array(6) /= "(3.0, 7.0)"
then
Report.Failed("Incorrect format for complex values that " &
"have been placed into string variables " &
"using the Complex_IO.Put procedure for " &
"strings");
end if;
 
if TC_Verbose then
Report.Comment("String format of Complex values verified");
end if;
 
-- Get complex values from strings using the Procedure Get.
-- Compare with expected complex values.
 
for i in 1..Number_Of_Complex_Items loop
 
C_IO.Get(From => TC_String_Array(i),
Item => TC_Complex,
Last => TC_Last_Character_Read);
 
if TC_Complex /= Complex_Array(i) then
Report.Failed("Incorrect complex data value obtained " &
"from String following use of Procedures " &
"Put and Get from Strings, Complex_Array " &
"item #" & Integer'Image(i));
end if;
end loop;
if TC_Verbose then
Report.Comment("Complex values removed from String array");
end if;
 
-- Verify that Layout_Error is raised if the given string is
-- too short to hold the formatted output.
Layout_Error_On_Put:
declare
Much_Too_Short : String(1..2);
Complex_Value : Complex_Pack.Complex := (5.0, 0.0);
begin
C_IO.Put(Much_Too_Short, Complex_Value);
Report.Failed("Layout_Error not raised by Procedure Put " &
"when the given string was too short to " &
"hold the formatted output");
exception
when Layout_Error => null; -- OK, expected exception.
when others =>
Report.Failed
("Unexpected exception raised by Procedure Put when " &
"the given string was too short to hold the " &
"formatted output");
end Layout_Error_On_Put;
 
if TC_Verbose then
Report.Comment("Layout Errors verified");
end if;
 
exception
when others =>
Report.Failed("Unexpected exception raised during the " &
"evaluation of Put and Get for Strings");
end;
 
 
-- Place complex values into strings using a variety of legal
-- complex data formats.
declare
 
type String_Ptr is access String;
 
TC_Complex_String_Array :
array (1..Number_Of_Complex_Items) of String_Ptr :=
(new String'( "(3.0, 9.0 )" ),
new String'( "+4.0 +7.0" ),
new String'( "(5.0 6.0)" ),
new String'( "6.0, 3.0" ),
new String'( " ( 2.0 , 5.0 ) " ),
new String'( "(3.0 7.0)" ));
 
-- The following array contains Positive values that correspond
-- to the last character that will be read by Procedure Get when
-- given each of the above strings as input.
 
TC_Last_Char_Array : array (1..Number_Of_Complex_Items)
of Positive := (12,10,9,8,20,22);
 
begin
 
-- Get complex values from strings using the Procedure Get.
-- Compare with expected complex values.
 
for i in 1..Number_Of_Complex_Items loop
 
C_IO.Get(TC_Complex_String_Array(i).all,
TC_Complex,
TC_Last_Character_Read);
 
if TC_Complex /= Complex_Array(i) then
Report.Failed
("Incorrect complex data value obtained from " &
"Procedure Get with complex data input of: " &
TC_Complex_String_Array(i).all);
end if;
 
if TC_Last_Character_Read /= TC_Last_Char_Array(i) then
Report.Failed
("Incorrect value returned as the last character of " &
"the input string processed by Procedure Get, " &
"string value : " & TC_Complex_String_Array(i).all &
" expected last character value read : " &
Positive'Image(TC_Last_Char_Array(i)) &
" last character value read : " &
Positive'Image(TC_Last_Character_Read));
end if;
 
end loop;
 
if TC_Verbose then
Report.Comment("Complex values removed from strings and " &
"verified against expected values");
end if;
 
exception
when others =>
Report.Failed("Unexpected exception raised during the " &
"evaluation of Get for Strings");
end;
 
exception
when others => Report.Failed ("Exception raised in Test_Block");
end Test_Block;
 
 
-- Delete the external file.
if Ada.Text_IO.Is_Open(Data_File) then
Ada.Text_IO.Delete(Data_File);
else
Ada.Text_IO.Open(Data_File,
Ada.Text_IO.In_File,
Data_Filename);
Ada.Text_IO.Delete(Data_File);
end if;
 
exception
 
-- Since Use_Error can be raised if, for the specified mode,
-- the environment does not support Text_IO operations, the
-- following handlers are included:
 
when Ada.Text_IO.Use_Error =>
Report.Not_Applicable ("Use_Error raised on Text_IO Create");
 
when Ada.Text_IO.Name_Error =>
Report.Not_Applicable ("Name_Error raised on Text_IO Create");
 
when others =>
Report.Failed ("Unexpected exception raised on text file Create");
 
end Test_for_Text_IO_Support;
 
Report.Result;
 
end CXG1003;
/cxg2002.a
0,0 → 1,468
-- CXG2002.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the complex "abs" or modulus function returns
-- results that are within the error bound allowed.
--
-- TEST DESCRIPTION:
-- This test uses a generic package to compute and check the
-- values of the modulus function. In addition, a non-generic
-- copy of this package is used to check the non-generic package
-- Ada.Numerics.Complex_Types.
-- Of special interest is the case where either the real or
-- the imaginary part of the argument is very large while the
-- other part is very small or 0.
-- We want to check that the value is computed such that
-- an overflow does not occur. If computed directly from the
-- definition
-- abs (x+yi) = sqrt(x**2 + y**2)
-- then overflow or underflow is much more likely than if the
-- argument is normalized first.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 31 JAN 96 SAIC Initial release for 2.1
-- 02 JUN 98 EDS Add parens to intermediate calculations.
--!
 
--
-- Reference:
-- Problems and Methodologies in Mathematical Software Production;
-- editors: P. C. Messina and A Murli;
-- Lecture Notes in Computer Science
-- Volume 142
-- Springer Verlag 1982
--
 
with System;
with Report;
with Ada.Numerics.Generic_Complex_Types;
with Ada.Numerics.Complex_Types;
procedure CXG2002 is
Verbose : constant Boolean := False;
Maximum_Relative_Error : constant := 3.0;
 
generic
type Real is digits <>;
package Generic_Check is
procedure Do_Test;
end Generic_Check;
 
package body Generic_Check is
package Complex_Types is new
Ada.Numerics.Generic_Complex_Types (Real);
use Complex_Types;
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real := Maximum_Relative_Error) is
Rel_Error,
Abs_Error,
Max_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * (abs Expected * Real'Model_Epsilon);
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual - Expected) > Max_Error then
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " &
Real'Image (Expected - Actual) &
" max_err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Do_Test is
Z : Complex;
X : Real;
T : Real;
begin
 
--- test 1 ---
begin
T := Real'Safe_Last;
Z := T + 0.0*i;
X := abs Z;
Check (X, T, "test 1 -- abs(bigreal + 0i)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 1");
when others =>
Report.Failed ("exception in test 1");
end;
 
--- test 2 ---
begin
T := Real'Safe_Last;
Z := 0.0 + T*i;
X := Modulus (Z);
Check (X, T, "test 2 -- abs(0 + bigreal*i)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 2");
when others =>
Report.Failed ("exception in test 2");
end;
 
--- test 3 ---
begin
Z := 3.0 + 4.0*i;
X := abs Z;
Check (X, 5.0 , "test 3 -- abs(3 + 4*i)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 3");
when others =>
Report.Failed ("exception in test 3");
end;
 
--- test 4 ---
declare
S : Real;
begin
S := Real(Real'Machine_Radix) ** (Real'Machine_EMax - 3);
Z := 3.0 * S + 4.0*S*i;
X := abs Z;
Check (X, 5.0*S, "test 4 -- abs(3S + 4S*i) for large S",
5.0*Real'Model_Epsilon);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 4");
when others =>
Report.Failed ("exception in test 4");
end;
 
--- test 5 ---
begin
T := Real'Model_Small;
Z := T + 0.0*i;
X := abs Z;
Check (X, T , "test 5 -- abs(small + 0*i)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 5");
when others =>
Report.Failed ("exception in test 5");
end;
 
--- test 6 ---
begin
T := Real'Model_Small;
Z := 0.0 + T*i;
X := abs Z;
Check (X, T , "test 6 -- abs(0 + small*i)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 6");
when others =>
Report.Failed ("exception in test 6");
end;
 
--- test 7 ---
declare
S : Real;
begin
S := Real(Real'Machine_Radix) ** (Real'Model_EMin + 3);
Z := 3.0 * S + 4.0*S*i;
X := abs Z;
Check (X, 5.0*S, "test 7 -- abs(3S + 4S*i) for small S",
5.0*Real'Model_Epsilon);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 7");
when others =>
Report.Failed ("exception in test 7");
end;
 
--- test 8 ---
declare
-- CRC Standard Mathematical Tables; 23rd Edition; pg 738
Sqrt2 : constant :=
1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
begin
Z := 1.0 + 1.0*i;
X := abs Z;
Check (X, Sqrt2 , "test 8 -- abs(1 + 1*i)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 8");
when others =>
Report.Failed ("exception in test 8");
end;
 
--- test 9 ---
begin
T := 0.0;
Z := T + 0.0*i;
X := abs Z;
Check (X, T , "test 5 -- abs(0 + 0*i)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 9");
when others =>
Report.Failed ("exception in test 9");
end;
end Do_Test;
end Generic_Check;
 
-----------------------------------------------------------------------
--- non generic copy of the above generic package
-----------------------------------------------------------------------
 
package Non_Generic_Check is
subtype Real is Float;
procedure Do_Test;
end Non_Generic_Check;
 
package body Non_Generic_Check is
use Ada.Numerics.Complex_Types;
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real := Maximum_Relative_Error) is
Rel_Error,
Abs_Error,
Max_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * (abs Expected * Real'Model_Epsilon);
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual - Expected) > Max_Error then
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " &
Real'Image (Expected - Actual) &
" max_err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Do_Test is
Z : Complex;
X : Real;
T : Real;
begin
 
--- test 1 ---
begin
T := Real'Safe_Last;
Z := T + 0.0*i;
X := abs Z;
Check (X, T, "test 1 -- abs(bigreal + 0i)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 1");
when others =>
Report.Failed ("exception in test 1");
end;
 
--- test 2 ---
begin
T := Real'Safe_Last;
Z := 0.0 + T*i;
X := Modulus (Z);
Check (X, T, "test 2 -- abs(0 + bigreal*i)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 2");
when others =>
Report.Failed ("exception in test 2");
end;
 
--- test 3 ---
begin
Z := 3.0 + 4.0*i;
X := abs Z;
Check (X, 5.0 , "test 3 -- abs(3 + 4*i)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 3");
when others =>
Report.Failed ("exception in test 3");
end;
 
--- test 4 ---
declare
S : Real;
begin
S := Real(Real'Machine_Radix) ** (Real'Machine_EMax - 3);
Z := 3.0 * S + 4.0*S*i;
X := abs Z;
Check (X, 5.0*S, "test 4 -- abs(3S + 4S*i) for large S",
5.0*Real'Model_Epsilon);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 4");
when others =>
Report.Failed ("exception in test 4");
end;
 
--- test 5 ---
begin
T := Real'Model_Small;
Z := T + 0.0*i;
X := abs Z;
Check (X, T , "test 5 -- abs(small + 0*i)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 5");
when others =>
Report.Failed ("exception in test 5");
end;
 
--- test 6 ---
begin
T := Real'Model_Small;
Z := 0.0 + T*i;
X := abs Z;
Check (X, T , "test 6 -- abs(0 + small*i)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 6");
when others =>
Report.Failed ("exception in test 6");
end;
 
--- test 7 ---
declare
S : Real;
begin
S := Real(Real'Machine_Radix) ** (Real'Model_EMin + 3);
Z := 3.0 * S + 4.0*S*i;
X := abs Z;
Check (X, 5.0*S, "test 7 -- abs(3S + 4S*i) for small S",
5.0*Real'Model_Epsilon);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 7");
when others =>
Report.Failed ("exception in test 7");
end;
 
--- test 8 ---
declare
-- CRC Standard Mathematical Tables; 23rd Edition; pg 738
Sqrt2 : constant :=
1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
begin
Z := 1.0 + 1.0*i;
X := abs Z;
Check (X, Sqrt2 , "test 8 -- abs(1 + 1*i)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 8");
when others =>
Report.Failed ("exception in test 8");
end;
 
--- test 9 ---
begin
T := 0.0;
Z := T + 0.0*i;
X := abs Z;
Check (X, T , "test 5 -- abs(0 + 0*i)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 9");
when others =>
Report.Failed ("exception in test 9");
end;
end Do_Test;
end Non_Generic_Check;
 
-----------------------------------------------------------------------
--- end of "manual instantiation"
-----------------------------------------------------------------------
package Chk_Float is new Generic_Check (Float);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
package Chk_A_Long_Float is new Generic_Check (A_Long_Float);
begin
Report.Test ("CXG2002",
"Check the accuracy of the complex modulus" &
" function");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
Chk_Float.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
Chk_A_Long_Float.Do_Test;
 
if Verbose then
Report.Comment ("checking non-generic package");
end if;
Non_Generic_Check.Do_Test;
Report.Result;
end CXG2002;
/cxg2011.a
0,0 → 1,490
-- CXG2011.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the log function returns
-- results that are within the error bound allowed.
--
-- TEST DESCRIPTION:
-- This test consists of a generic package that is
-- instantiated to check both Float and a long float type.
-- The test for each floating point type is divided into
-- several parts:
-- Special value checks where the result is a known constant.
-- Checks in a range where a Taylor series can be used to compute
-- the expected result.
-- Checks that use an identity for determining the result.
-- Exception checks.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 1 Mar 96 SAIC Initial release for 2.1
-- 22 Aug 96 SAIC Improved Check routine
-- 02 DEC 97 EDS Log (0.0) must raise Constraint_Error,
-- not Argument_Error
--!
 
--
-- References:
--
-- Software Manual for the Elementary Functions
-- William J. Cody, Jr. and William Waite
-- Prentice-Hall, 1980
--
-- CRC Standard Mathematical Tables
-- 23rd Edition
--
-- Implementation and Testing of Function Software
-- W. J. Cody
-- Problems and Methodologies in Mathematical Software Production
-- editors P. C. Messina and A. Murli
-- Lecture Notes in Computer Science Volume 142
-- Springer Verlag, 1982
--
 
with System;
with Report;
with Ada.Numerics.Generic_Elementary_Functions;
procedure CXG2011 is
Verbose : constant Boolean := False;
Max_Samples : constant := 1000;
 
-- CRC Handbook Page 738
Ln10 : constant := 2.30258_50929_94045_68401_79914_54684_36420_76011_01489;
Ln2 : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755_00134;
 
generic
type Real is digits <>;
package Generic_Check is
procedure Do_Test;
end Generic_Check;
 
package body Generic_Check is
package Elementary_Functions is new
Ada.Numerics.Generic_Elementary_Functions (Real);
function Sqrt (X : Real'Base) return Real'Base renames
Elementary_Functions.Sqrt;
function Exp (X : Real'Base) return Real'Base renames
Elementary_Functions.Exp;
function Log (X : Real'Base) return Real'Base renames
Elementary_Functions.Log;
function Log (X, Base : Real'Base) return Real'Base renames
Elementary_Functions.Log;
 
-- flag used to terminate some tests early
Accuracy_Error_Reported : Boolean := False;
 
 
-- The following value is a lower bound on the accuracy
-- required. It is normally 0.0 so that the lower bound
-- is computed from Model_Epsilon. However, for tests
-- where the expected result is only known to a certain
-- amount of precision this bound takes on a non-zero
-- value to account for that level of precision.
Error_Low_Bound : Real := 0.0;
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real) is
Max_Error : Real;
Rel_Error : Real;
Abs_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon
-- instead of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
-- take into account the low bound on the error
if Max_Error < Error_Low_Bound then
Max_Error := Error_Low_Bound;
end if;
 
if abs (Actual - Expected) > Max_Error then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Special_Value_Test is
begin
 
--- test 1 ---
declare
Y : Real;
begin
Y := Log(1.0);
Check (Y, 0.0, "special value test 1 -- log(1)",
0.0); -- no error allowed
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 1");
when others =>
Report.Failed ("exception in test 1");
end;
 
--- test 2 ---
declare
Y : Real;
begin
Y := Log(10.0);
Check (Y, Ln10, "special value test 2 -- log(10)", 4.0);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 2");
when others =>
Report.Failed ("exception in test 2");
end;
 
--- test 3 ---
declare
Y : Real;
begin
Y := Log (2.0);
Check (Y, Ln2, "special value test 3 -- log(2)", 4.0);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 3");
when others =>
Report.Failed ("exception in test 3");
end;
 
--- test 4 ---
declare
Y : Real;
begin
Y := Log (2.0 ** 18, 2.0);
Check (Y, 18.0, "special value test 4 -- log(2**18,2)", 4.0);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 4");
when others =>
Report.Failed ("exception in test 4");
end;
end Special_Value_Test;
 
 
procedure Taylor_Series_Test is
-- Use a 4 term taylor series expansion to check a selection of
-- arguments very near 1.0.
-- The range is chosen so that the 4 term taylor series will
-- provide accuracy to machine precision. Cody pg 49-50.
Half_Range : constant Real := Real'Model_Epsilon * 50.0;
A : constant Real := 1.0 - Half_Range;
B : constant Real := 1.0 + Half_Range;
X : Real;
Xm1 : Real;
Expected : Real;
Actual : Real;
 
begin
Accuracy_Error_Reported := False; -- reset
for I in 1..Max_Samples loop
X := (B - A) * Real (I) / Real (Max_Samples) + A;
Xm1 := X - 1.0;
-- The following is the first 4 terms of the taylor series
-- that has been rearranged to minimize error in the calculation
Expected := (Xm1 * (1.0/3.0 - Xm1/4.0) - 0.5) * Xm1 * Xm1 + Xm1;
 
Actual := Log (X);
Check (Actual, Expected,
"Taylor Series Test -" &
Integer'Image (I) &
" log (" & Real'Image (X) & ")",
4.0);
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
end loop;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Taylor Series Test");
when others =>
Report.Failed ("exception in Taylor Series Test");
end Taylor_Series_Test;
 
 
 
procedure Log_Difference_Identity is
-- Check using the identity ln(x) = ln(17x/16) - ln(17/16)
-- over the range A to B.
-- The selected range assures that both X and 17x/16 will
-- have the same exponents and neither argument gets too close
-- to 1. Cody pg 50.
A : constant Real := 1.0 / Sqrt (2.0);
B : constant Real := 15.0 / 16.0;
X : Real;
Expected : Real;
Actual : Real;
begin
Accuracy_Error_Reported := False; -- reset
for I in 1..Max_Samples loop
X := (B - A) * Real (I) / Real (Max_Samples) + A;
-- magic argument purification
X := Real'Machine (Real'Machine (X+8.0) - 8.0);
Expected := Log (X + X / 16.0) - Log (17.0/16.0);
 
Actual := Log (X);
Check (Actual, Expected,
"Log Difference Identity -" &
Integer'Image (I) &
" log (" & Real'Image (X) & ")",
4.0);
 
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
end loop;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Log Difference Identity Test");
when others =>
Report.Failed ("exception in Log Difference Identity Test");
end Log_Difference_Identity;
 
 
procedure Log_Product_Identity is
-- Check using the identity ln(x**2) = 2ln(x)
-- over the range A to B.
-- This large range is chosen to minimize the possibility of
-- undetected systematic errors. Cody pg 53.
A : constant Real := 16.0;
B : constant Real := 240.0;
X : Real;
Expected : Real;
Actual : Real;
begin
Accuracy_Error_Reported := False; -- reset
for I in 1..Max_Samples loop
X := (B - A) * Real (I) / Real (Max_Samples) + A;
-- magic argument purification
X := Real'Machine (Real'Machine (X+8.0) - 8.0);
Expected := 2.0 * Log (X);
 
Actual := Log (X*X);
Check (Actual, Expected,
"Log Product Identity -" &
Integer'Image (I) &
" log (" & Real'Image (X) & ")",
4.0);
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
end loop;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Log Product Identity Test");
when others =>
Report.Failed ("exception in Log Product Identity Test");
end Log_Product_Identity;
 
 
procedure Log10_Test is
-- Check using the identity log(x) = log(11x/10) - log(1.1)
-- over the range A to B. See Cody pg 52.
A : constant Real := 1.0 / Sqrt (10.0);
B : constant Real := 0.9;
X : Real;
Expected : Real;
Actual : Real;
begin
if Real'Digits > 17 then
-- constant used below is accuract to 17 digits
Error_Low_Bound := 0.00000_00000_00000_01;
Report.Comment ("log accuracy checked to 19 digits");
end if;
Accuracy_Error_Reported := False; -- reset
for I in 1..Max_Samples loop
X := (B - A) * Real (I) / Real (Max_Samples) + A;
Expected := Log (X + X/10.0, 10.0)
- 3.77060_15822_50407_5E-4 - 21.0 / 512.0;
 
Actual := Log (X, 10.0);
Check (Actual, Expected,
"Log 10 Test -" &
Integer'Image (I) &
" log (" & Real'Image (X) & ")",
4.0);
 
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
exit when Accuracy_Error_Reported;
end loop;
Error_Low_Bound := 0.0; -- reset
 
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Log 10 Test");
when others =>
Report.Failed ("exception in Log 10 Test");
end Log10_Test;
 
 
procedure Exception_Test is
X1, X2, X3, X4 : Real;
begin
begin
X1 := Log (0.0);
Report.Failed ("exception not raised for LOG(0)");
exception
-- Log (0.0) must raise Constraint_Error, not Argument_Error,
-- as per A.5.1(28,29). Was incorrect in ACVC 2.1 release.
when Ada.Numerics.Argument_Error =>
Report.Failed ("Argument_Error raised instead of" &
" Constraint_Error for LOG(0)--A.5.1(28,29)");
when Constraint_Error => null; -- ok
when others =>
Report.Failed ("wrong exception raised for LOG(0)");
end;
 
begin
X2 := Log ( 1.0, 0.0);
Report.Failed ("exception not raised for LOG(1,0)");
exception
when Ada.Numerics.Argument_Error => null; -- ok
when Constraint_Error =>
Report.Failed ("constraint_error raised instead of" &
" argument_error for LOG(1,0)");
when others =>
Report.Failed ("wrong exception raised for LOG(1,0)");
end;
 
begin
X3 := Log (1.0, 1.0);
Report.Failed ("exception not raised for LOG(1,1)");
exception
when Ada.Numerics.Argument_Error => null; -- ok
when Constraint_Error =>
Report.Failed ("constraint_error raised instead of" &
" argument_error for LOG(1,1)");
when others =>
Report.Failed ("wrong exception raised for LOG(1,1)");
end;
 
begin
X4 := Log (1.0, -10.0);
Report.Failed ("exception not raised for LOG(1,-10)");
exception
when Ada.Numerics.Argument_Error => null; -- ok
when Constraint_Error =>
Report.Failed ("constraint_error raised instead of" &
" argument_error for LOG(1,-10)");
when others =>
Report.Failed ("wrong exception raised for LOG(1,-10)");
end;
 
-- optimizer thwarting
if Report.Ident_Bool (False) then
Report.Comment (Real'Image (X1+X2+X3+X4));
end if;
end Exception_Test;
 
 
procedure Do_Test is
begin
Special_Value_Test;
Taylor_Series_Test;
Log_Difference_Identity;
Log_Product_Identity;
Log10_Test;
Exception_Test;
end Do_Test;
end Generic_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
package Float_Check is new Generic_Check (Float);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
package A_Long_Float_Check is new Generic_Check (A_Long_Float);
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
 
begin
Report.Test ("CXG2011",
"Check the accuracy of the log function");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
 
Report.Result;
end CXG2011;
/cxg2021.a
0,0 → 1,386
-- CXG2021.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the complex SIN and COS functions return
-- a result that is within the error bound allowed.
--
-- TEST DESCRIPTION:
-- This test consists of a generic package that is
-- instantiated to check complex numbers based upon
-- both Float and a long float type.
-- The test for each floating point type is divided into
-- several parts:
-- Special value checks where the result is a known constant.
-- Checks that use an identity for determining the result.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 27 Mar 96 SAIC Initial release for 2.1
-- 22 Aug 96 SAIC No longer skips test for systems with
-- more than 20 digits of precision.
--
--!
 
--
-- References:
--
-- W. J. Cody
-- CELEFUNT: A Portable Test Package for Complex Elementary Functions
-- Algorithm 714, Collected Algorithms from ACM.
-- Published in Transactions On Mathematical Software,
-- Vol. 19, No. 1, March, 1993, pp. 1-21.
--
-- CRC Standard Mathematical Tables
-- 23rd Edition
--
 
with System;
with Report;
with Ada.Numerics.Generic_Complex_Types;
with Ada.Numerics.Generic_Complex_Elementary_Functions;
procedure CXG2021 is
Verbose : constant Boolean := False;
-- Note that Max_Samples is the number of samples taken in
-- both the real and imaginary directions. Thus, for Max_Samples
-- of 100 the number of values checked is 10000.
Max_Samples : constant := 100;
 
E : constant := Ada.Numerics.E;
Pi : constant := Ada.Numerics.Pi;
 
generic
type Real is digits <>;
package Generic_Check is
procedure Do_Test;
end Generic_Check;
 
package body Generic_Check is
package Complex_Type is new
Ada.Numerics.Generic_Complex_Types (Real);
use Complex_Type;
 
package CEF is new
Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type);
 
function Sin (X : Complex) return Complex renames CEF.Sin;
function Cos (X : Complex) return Complex renames CEF.Cos;
 
-- flag used to terminate some tests early
Accuracy_Error_Reported : Boolean := False;
 
-- The following value is a lower bound on the accuracy
-- required. It is normally 0.0 so that the lower bound
-- is computed from Model_Epsilon. However, for tests
-- where the expected result is only known to a certain
-- amount of precision this bound takes on a non-zero
-- value to account for that level of precision.
Error_Low_Bound : Real := 0.0;
 
-- the E_Factor is an additional amount added to the Expected
-- value prior to computing the maximum relative error.
-- This is needed because the error analysis (Cody pg 17-20)
-- requires this additional allowance.
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real;
E_Factor : Real := 0.0) is
Max_Error : Real;
Rel_Error : Real;
Abs_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * Real'Model_Epsilon * (abs Expected + E_Factor);
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
-- take into account the low bound on the error
if Max_Error < Error_Low_Bound then
Max_Error := Error_Low_Bound;
end if;
 
if abs (Actual - Expected) > Max_Error then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) &
" efactor:" & Real'Image (E_Factor) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed" &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) &
" efactor:" & Real'Image (E_Factor) );
end if;
end if;
end Check;
 
 
procedure Check (Actual, Expected : Complex;
Test_Name : String;
MRE : Real;
R_Factor, I_Factor : Real := 0.0) is
begin
Check (Actual.Re, Expected.Re, Test_Name & " real part",
MRE, R_Factor);
Check (Actual.Im, Expected.Im, Test_Name & " imaginary part",
MRE, I_Factor);
end Check;
 
 
procedure Special_Value_Test is
-- In the following tests the expected result is accurate
-- to the machine precision so the minimum guaranteed error
-- bound can be used if the argument is exact.
-- Since the argument involves Pi, we must allow for this
-- inexact argument.
Minimum_Error : constant := 11.0;
begin
Check (Sin (Pi/2.0 + 0.0*i),
1.0 + 0.0*i,
"sin(pi/2+0i)",
Minimum_Error + 1.0);
Check (Cos (Pi/2.0 + 0.0*i),
0.0 + 0.0*i,
"cos(pi/2+0i)",
Minimum_Error + 1.0);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in special value test");
when others =>
Report.Failed ("exception in special value test");
end Special_Value_Test;
 
 
 
procedure Exact_Result_Test is
No_Error : constant := 0.0;
begin
-- G.1.2(36);6.0
Check (Sin(0.0 + 0.0*i), 0.0 + 0.0 * i, "sin(0+0i)", No_Error);
Check (Cos(0.0 + 0.0*i), 1.0 + 0.0 * i, "cos(0+0i)", No_Error);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in Exact_Result Test");
when others =>
Report.Failed ("exception in Exact_Result Test");
end Exact_Result_Test;
 
 
procedure Identity_Test (RA, RB, IA, IB : Real) is
-- Tests an identity over a range of values specified
-- by the 4 parameters. RA and RB denote the range for the
-- real part while IA and IB denote the range for the
-- imaginary part.
--
-- For this test we use the identity
-- Sin(Z) = Sin(Z-W) * Cos(W) + Cos(Z-W) * Sin(W)
-- and
-- Cos(Z) = Cos(Z-W) * Cos(W) - Sin(Z-W) * Sin(W)
--
 
X, Y : Real;
Z : Complex;
W : constant Complex := Compose_From_Cartesian(0.0625, 0.0625);
ZmW : Complex; -- Z - W
Sin_ZmW,
Cos_ZmW : Complex;
Actual1, Actual2 : Complex;
R_Factor : Real; -- additional real error factor
I_Factor : Real; -- additional imaginary error factor
Sin_W : constant Complex := (6.2581348413276935585E-2,
6.2418588008436587236E-2);
-- numeric stability is enhanced by using Cos(W) - 1.0 instead of
-- Cos(W) in the computation.
Cos_W_m_1 : constant Complex := (-2.5431314180235545803E-6,
-3.9062493377261771826E-3);
 
 
begin
if Real'Digits > 20 then
-- constants used here accurate to 20 digits. Allow 1
-- additional digit of error for computation.
Error_Low_Bound := 0.00000_00000_00000_0001;
Report.Comment ("accuracy checked to 19 digits");
end if;
 
Accuracy_Error_Reported := False; -- reset
for II in 0..Max_Samples loop
X := (RB - RA) * Real (II) / Real (Max_Samples) + RA;
for J in 0..Max_Samples loop
Y := (IB - IA) * Real (J) / Real (Max_Samples) + IA;
Z := Compose_From_Cartesian(X,Y);
ZmW := Z - W;
Sin_ZmW := Sin (ZmW);
Cos_ZmW := Cos (ZmW);
 
-- now for the first identity
-- Sin(Z) = Sin(Z-W) * Cos(W) + Cos(Z-W) * Sin(W)
-- = Sin(Z-W) * (1+(Cos(W)-1)) + Cos(Z-W) * Sin(W)
-- = Sin(Z-W) + Sin(Z-W)*(Cos(W)-1) + Cos(Z-W)*Sin(W)
 
 
Actual1 := Sin (Z);
Actual2 := Sin_ZmW + (Sin_ZmW * Cos_W_m_1 + Cos_ZmW * Sin_W);
 
-- The computation of the additional error factors are taken
-- from Cody pages 17-20.
 
R_Factor := abs (Re (Sin_ZmW) * Re (1.0 - Cos_W_m_1)) +
abs (Im (Sin_ZmW) * Im (1.0 - Cos_W_m_1)) +
abs (Re (Cos_ZmW) * Re (Sin_W)) +
abs (Re (Cos_ZmW) * Re (1.0 - Cos_W_m_1));
I_Factor := abs (Re (Sin_ZmW) * Im (1.0 - Cos_W_m_1)) +
abs (Im (Sin_ZmW) * Re (1.0 - Cos_W_m_1)) +
abs (Re (Cos_ZmW) * Im (Sin_W)) +
abs (Im (Cos_ZmW) * Re (1.0 - Cos_W_m_1));
Check (Actual1, Actual2,
"Identity_1_Test " & Integer'Image (II) &
Integer'Image (J) & ": Sin((" &
Real'Image (Z.Re) & ", " &
Real'Image (Z.Im) & ")) ",
11.0, R_Factor, I_Factor);
 
-- now for the second identity
-- Cos(Z) = Cos(Z-W) * Cos(W) - Sin(Z-W) * Sin(W)
-- = Cos(Z-W) * (1+(Cos(W)-1) - Sin(Z-W) * Sin(W)
Actual1 := Cos (Z);
Actual2 := Cos_ZmW + (Cos_ZmW * Cos_W_m_1 - Sin_ZmW * Sin_W);
 
-- The computation of the additional error factors are taken
-- from Cody pages 17-20.
 
R_Factor := abs (Re (Sin_ZmW) * Re (Sin_W)) +
abs (Im (Sin_ZmW) * Im (Sin_W)) +
abs (Re (Cos_ZmW) * Re (1.0 - Cos_W_m_1)) +
abs (Im (Cos_ZmW) * Im (1.0 - Cos_W_m_1));
I_Factor := abs (Re (Sin_ZmW) * Im (Sin_W)) +
abs (Im (Sin_ZmW) * Re (Sin_W)) +
abs (Re (Cos_ZmW) * Im (1.0 - Cos_W_m_1)) +
abs (Im (Cos_ZmW) * Re (1.0 - Cos_W_m_1));
Check (Actual1, Actual2,
"Identity_2_Test " & Integer'Image (II) &
Integer'Image (J) & ": Cos((" &
Real'Image (Z.Re) & ", " &
Real'Image (Z.Im) & ")) ",
11.0, R_Factor, I_Factor);
 
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
Error_Low_Bound := 0.0; -- reset
return;
end if;
end loop;
end loop;
 
Error_Low_Bound := 0.0; -- reset
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Identity_Test" &
" for Z=(" & Real'Image (X) &
", " & Real'Image (Y) & ")");
when others =>
Report.Failed ("exception in Identity_Test" &
" for Z=(" & Real'Image (X) &
", " & Real'Image (Y) & ")");
end Identity_Test;
 
 
procedure Do_Test is
begin
Special_Value_Test;
Exact_Result_Test;
-- test regions where sin and cos have the same sign and
-- about the same magnitude. This will minimize subtraction
-- errors in the identities.
-- See Cody page 17.
Identity_Test (0.0625, 10.0, 0.0625, 10.0);
Identity_Test ( 16.0, 17.0, 16.0, 17.0);
end Do_Test;
end Generic_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
package Float_Check is new Generic_Check (Float);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
package A_Long_Float_Check is new Generic_Check (A_Long_Float);
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
 
begin
Report.Test ("CXG2021",
"Check the accuracy of the complex SIN and COS functions");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
 
Report.Result;
end CXG2021;
/cxg2012.a
0,0 → 1,438
-- CXG2012.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the exponentiation operator returns
-- results that are within the error bound allowed.
--
-- TEST DESCRIPTION:
-- This test consists of a generic package that is
-- instantiated to check both Float and a long float type.
-- The test for each floating point type is divided into
-- several parts:
-- Special value checks where the result is a known constant.
-- Checks that use an identity for determining the result.
-- Exception checks.
-- While this test concentrates on the "**" operator
-- defined in Generic_Elementary_Functions, a check is also
-- performed on the standard "**" operator.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 7 Mar 96 SAIC Initial release for 2.1
-- 2 Sep 96 SAIC Improvements as suggested by reviewers
-- 3 Jun 98 EDS Add parens to ensure that the expression is not
-- evaluated by multiplying its two large terms
-- together and overflowing.
-- 3 Dec 01 RLB Added 'Machine to insure that equality tests
-- are certain to work.
--
--!
 
--
-- References:
--
-- Software Manual for the Elementary Functions
-- William J. Cody, Jr. and William Waite
-- Prentice-Hall, 1980
--
-- CRC Standard Mathematical Tables
-- 23rd Edition
--
-- Implementation and Testing of Function Software
-- W. J. Cody
-- Problems and Methodologies in Mathematical Software Production
-- editors P. C. Messina and A. Murli
-- Lecture Notes in Computer Science Volume 142
-- Springer Verlag, 1982
--
 
with System;
with Report;
with Ada.Numerics.Generic_Elementary_Functions;
procedure CXG2012 is
Verbose : constant Boolean := False;
Max_Samples : constant := 1000;
 
-- CRC Standard Mathematical Tables; 23rd Edition; pg 738
Sqrt2 : constant :=
1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
Sqrt3 : constant :=
1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
 
 
generic
type Real is digits <>;
package Generic_Check is
procedure Do_Test;
end Generic_Check;
 
package body Generic_Check is
package Elementary_Functions is new
Ada.Numerics.Generic_Elementary_Functions (Real);
function Sqrt (X : Real) return Real renames
Elementary_Functions.Sqrt;
function Exp (X : Real) return Real renames
Elementary_Functions.Exp;
function Log (X : Real) return Real renames
Elementary_Functions.Log;
function "**" (L, R : Real) return Real renames
Elementary_Functions."**";
 
-- flag used to terminate some tests early
Accuracy_Error_Reported : Boolean := False;
 
 
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real) is
Max_Error : Real;
Rel_Error : Real;
Abs_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon
-- instead of Model_Epsilon and Expected.
Rel_Error := MRE * (abs Expected * Real'Model_Epsilon);
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual - Expected) > Max_Error then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
-- the following version of Check computes the allowed error bound
-- using the operands
procedure Check (Actual, Expected : Real;
Left, Right : Real;
Test_Name : String;
MRE_Factor : Real := 1.0) is
MRE : Real;
begin
MRE := MRE_Factor * (4.0 + abs (Right * Log(Left)) / 32.0);
Check (Actual, Expected, Test_Name, MRE);
end Check;
 
 
procedure Real_To_Integer_Test is
type Int_Check is
record
Left : Real;
Right : Integer;
Expected : Real;
end record;
type Int_Checks is array (Positive range <>) of Int_Check;
 
-- the following tests use only model numbers so the result
-- is expected to be exact.
IC : constant Int_Checks :=
( ( 2.0, 5, 32.0),
( -2.0, 5, -32.0),
( 0.5, -5, 32.0),
( 2.0, 0, 1.0),
( 0.0, 0, 1.0) );
begin
for I in IC'Range loop
declare
Y : Real;
begin
Y := IC (I).Left ** IC (I).Right;
Check (Y, IC (I).Expected,
"real to integer test" &
Real'Image (IC (I).Left) & " ** " &
Integer'Image (IC (I).Right),
0.0); -- no error allowed
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in rtoi test " &
Integer'Image (I));
when others =>
Report.Failed ("exception in rtoi test " &
Integer'Image (I));
end;
end loop;
end Real_To_Integer_Test;
 
 
procedure Special_Value_Test is
No_Error : constant := 0.0;
begin
Check (0.0 ** 1.0, 0.0, "0**1", No_Error);
Check (1.0 ** 0.0, 1.0, "1**0", No_Error);
 
Check ( 2.0 ** 5.0, 32.0, 2.0, 5.0, "2**5");
Check ( 0.5**(-5.0), 32.0, 0.5, -5.0, "0.5**-5");
 
Check (Sqrt2 ** 4.0, 4.0, Sqrt2, 4.0, "Sqrt2**4");
Check (Sqrt3 ** 6.0, 27.0, Sqrt3, 6.0, "Sqrt3**6");
 
Check (2.0 ** 0.5, Sqrt2, 2.0, 0.5, "2.0**0.5");
 
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in Special Value Test");
when others =>
Report.Failed ("exception in Special Value Test");
end Special_Value_Test;
 
 
procedure Small_Range_Test is
-- Several checks over the range 1/radix .. 1
A : constant Real := 1.0 / Real (Real'Machine_Radix);
B : constant Real := 1.0;
X : Real;
-- In the cases below where the expected result is
-- inexact we allow an additional error amount of
-- 1.0 * Model_Epsilon to account for that error.
-- This is accomplished by the factor of 1.25 times
-- the computed error bound (which is > 4.0) thus
-- increasing the error bound by at least
-- 1.0 * Model_Epsilon
begin
Accuracy_Error_Reported := False; -- reset
for I in 0..Max_Samples loop
X := Real'Machine((B - A) * Real (I) / Real (Max_Samples) + A);
 
Check (X ** 1.0, X, -- exact result required
"Small range" & Integer'Image (I) & ": " &
Real'Image (X) & " ** 1.0",
0.0);
 
Check ((X*X) ** 1.5, X**3, X*X, 1.5,
"Small range" & Integer'Image (I) & ": " &
Real'Image (X*X) & " ** 1.5",
1.25);
 
Check (X ** 13.5, 1.0 / (X ** (-13.5)), X, 13.5,
"Small range" & Integer'Image (I) & ": " &
Real'Image (X) & " ** 13.5",
2.0); -- 2 ** computations
 
Check ((X*X) ** 1.25, X**(2.5), X*X, 1.25,
"Small range" & Integer'Image (I) & ": " &
Real'Image (X*X) & " ** 1.25",
2.0); -- 2 ** computations
 
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
 
end loop;
 
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Small Range Test");
when others =>
Report.Failed ("exception in Small Range Test");
end Small_Range_Test;
 
 
procedure Large_Range_Test is
-- Check over the range A to B where A is 1.0 and
-- B is a large value.
A : constant Real := 1.0;
B : Real;
X : Real;
Iteration : Integer := 0;
Subtest : Character := 'X';
begin
-- upper bound of range should be as large as possible where
-- B**3 is still valid.
B := Real'Safe_Last ** 0.333;
Accuracy_Error_Reported := False; -- reset
for I in 0..Max_Samples loop
Iteration := I;
Subtest := 'X';
X := Real'Machine((B - A) * (Real (I) / Real (Max_Samples)) + A);
 
Subtest := 'A';
Check (X ** 1.0, X, -- exact result required
"Large range" & Integer'Image (I) & ": " &
Real'Image (X) & " ** 1.0",
0.0);
 
Subtest := 'B';
Check ((X*X) ** 1.5, X**3, X*X, 1.5,
"Large range" & Integer'Image (I) & ": " &
Real'Image (X*X) & " ** 1.5",
1.25); -- inexact expected result
 
Subtest := 'C';
Check ((X*X) ** 1.25, X**(2.5), X*X, 1.25,
"Large range" & Integer'Image (I) & ": " &
Real'Image (X*X) & " ** 1.25",
2.0); -- two ** operators
 
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
 
end loop;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Large Range Test" &
Integer'Image (Iteration) & Subtest);
when others =>
Report.Failed ("exception in Large Range Test" &
Integer'Image (Iteration) & Subtest);
end Large_Range_Test;
 
 
procedure Exception_Test is
X1, X2, X3, X4 : Real;
begin
begin
X1 := 0.0 ** (-1.0);
Report.Failed ("exception not raised for 0**-1");
exception
when Ada.Numerics.Argument_Error =>
Report.Failed ("argument_error raised instead of" &
" constraint_error for 0**-1");
when Constraint_Error => null; -- ok
when others =>
Report.Failed ("wrong exception raised for 0**-1");
end;
 
begin
X2 := 0.0 ** 0.0;
Report.Failed ("exception not raised for 0**0");
exception
when Ada.Numerics.Argument_Error => null; -- ok
when Constraint_Error =>
Report.Failed ("constraint_error raised instead of" &
" argument_error for 0**0");
when others =>
Report.Failed ("wrong exception raised for 0**0");
end;
 
begin
X3 := (-1.0) ** 1.0;
Report.Failed ("exception not raised for -1**1");
exception
when Ada.Numerics.Argument_Error => null; -- ok
when Constraint_Error =>
Report.Failed ("constraint_error raised instead of" &
" argument_error for -1**1");
when others =>
Report.Failed ("wrong exception raised for -1**1");
end;
 
begin
X4 := (-2.0) ** 2.0;
Report.Failed ("exception not raised for -2**2");
exception
when Ada.Numerics.Argument_Error => null; -- ok
when Constraint_Error =>
Report.Failed ("constraint_error raised instead of" &
" argument_error for -2**2");
when others =>
Report.Failed ("wrong exception raised for -2**2");
end;
 
-- optimizer thwarting
if Report.Ident_Bool (False) then
Report.Comment (Real'Image (X1+X2+X3+X4));
end if;
end Exception_Test;
 
 
procedure Do_Test is
begin
Real_To_Integer_Test;
Special_Value_Test;
Small_Range_Test;
Large_Range_Test;
Exception_Test;
end Do_Test;
end Generic_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
package Float_Check is new Generic_Check (Float);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
package A_Long_Float_Check is new Generic_Check (A_Long_Float);
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
 
begin
Report.Test ("CXG2012",
"Check the accuracy of the ** operator");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
 
Report.Result;
end CXG2012;
/cxg1004.a
0,0 → 1,360
-- CXG1004.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the specified exceptions are raised by the subprograms
-- defined in package Ada.Numerics.Generic_Complex_Elementary_Functions
-- given the prescribed input parameter values.
--
-- TEST DESCRIPTION:
-- This test checks that specific subprograms defined in the
-- package Ada.Numerics.Generic_Complex_Elementary_Functions raise the
-- exceptions Argument_Error and Constraint_Error when their input
-- parameter value are those specified as causing each exception.
-- In the case of Constraint_Error, the exception will be raised in
-- each test case, provided that the value of the attribute
-- 'Machine_Overflows (for the actual type of package
-- Generic_Complex_Type) is True.
--
-- APPLICABILITY CRITERIA:
-- This test only applies to implementations supporting the
-- numerics annex.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 16 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1.
-- 29 Sep 96 SAIC Incorporated reviewer comments.
-- 02 Jun 98 EDS Replace "_i" with "_One".
--!
 
with Ada.Numerics.Generic_Complex_Types;
with Ada.Numerics.Generic_Complex_Elementary_Functions;
with Report;
 
procedure CXG1004 is
begin
 
Report.Test ("CXG1004", "Check that the specified exceptions are " &
"raised by the subprograms defined in package " &
"Ada.Numerics.Generic_Complex_Elementary_" &
"Functions given the prescribed input " &
"parameter values");
 
Test_Block:
declare
 
type Real_Type is new Float;
 
TC_Overflows : Boolean := Real_Type'Machine_Overflows;
 
package Complex_Pack is
new Ada.Numerics.Generic_Complex_Types(Real_Type);
 
package CEF is
new Ada.Numerics.Generic_Complex_Elementary_Functions(Complex_Pack);
 
use Ada.Numerics, Complex_Pack, CEF;
 
Complex_Zero : constant Complex := Compose_From_Cartesian(0.0, 0.0);
Plus_One : constant Complex := Compose_From_Cartesian(1.0, 0.0);
Minus_One : constant Complex := Compose_From_Cartesian(-1.0, 0.0);
Plus_i : constant Complex := Compose_From_Cartesian(i);
Minus_i : constant Complex := Compose_From_Cartesian(-i);
 
Complex_Negative_Real : constant Complex :=
Compose_From_Cartesian(-4.0, 2.0);
Complex_Negative_Imaginary : constant Complex :=
Compose_From_Cartesian(3.0, -5.0);
 
TC_Complex : Complex;
 
 
-- This procedure is used in "Exception Raising" calls below in an
-- attempt to avoid elimination of the subtest through optimization.
 
procedure No_Optimize (The_Complex_Number : Complex) is
begin
Report.Comment("No Optimize: Should never be printed " &
Integer'Image(Integer(The_Complex_Number.Im)));
end No_Optimize;
 
 
begin
 
-- Check that the exception Numerics.Argument_Error is raised by the
-- exponentiation operator when the value of the left operand is zero,
-- and the real component of the exponent (or the exponent itself) is
-- zero.
 
begin
TC_Complex := "**"(Left => Complex_Zero, Right => Complex_Zero);
Report.Failed("Argument_Error not raised by exponentiation " &
"operator, left operand = complex zero, right " &
"operand = complex zero");
No_Optimize(TC_Complex);
exception
when Argument_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised by exponentiation " &
"operator, left operand = complex zero, right " &
"operand = complex zero");
end;
 
begin
TC_Complex := Complex_Zero**0.0;
Report.Failed("Argument_Error not raised by exponentiation " &
"operator, left operand = complex zero, right " &
"operand = real zero");
No_Optimize(TC_Complex);
exception
when Argument_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised by exponentiation " &
"operator, left operand = complex zero, right " &
"operand = real zero");
end;
 
 
begin
TC_Complex := "**"(Left => 0.0, Right => Complex_Zero);
Report.Failed("Argument_Error not raised by exponentiation " &
"operator, left operand = real zero, right " &
"operand = complex zero");
No_Optimize(TC_Complex);
exception
when Argument_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised by exponentiation " &
"operator, left operand = real zero, right " &
"operand = complex zero");
end;
 
 
-- Check that the exception Constraint_Error is raised under the
-- specified circumstances, provided that
-- Complex_Types.Real'Machine_Overflows is True.
 
if TC_Overflows then
 
-- Raised by Log, when the value of the parameter X is zero.
begin
TC_Complex := Log (X => Complex_Zero);
Report.Failed("Constraint_Error not raised when Function " &
"Log given parameter value of complex zero");
No_Optimize(TC_Complex);
exception
when Constraint_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised when Function " &
"Log given parameter value of complex zero");
end;
 
-- Raised by Cot, when the value of the parameter X is zero.
begin
TC_Complex := Cot (X => Complex_Zero);
Report.Failed("Constraint_Error not raised when Function " &
"Cot given parameter value of complex zero");
No_Optimize(TC_Complex);
exception
when Constraint_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised when Function " &
"Cot given parameter value of complex zero");
end;
 
-- Raised by Coth, when the value of the parameter X is zero.
begin
TC_Complex := Coth (Complex_Zero);
Report.Failed("Constraint_Error not raised when Function " &
"Coth given parameter value of complex zero");
No_Optimize(TC_Complex);
exception
when Constraint_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised when Function " &
"Coth given parameter value of complex zero");
end;
 
-- Raised by the exponentiation operator, when the value of the
-- left operand is zero and the real component of the exponent
-- is negative.
begin
TC_Complex := Complex_Zero**Complex_Negative_Real;
Report.Failed("Constraint_Error not raised when the " &
"exponentiation operator left operand is " &
"complex zero, and the real component of " &
"the exponent is negative");
No_Optimize(TC_Complex);
exception
when Constraint_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised when the " &
"exponentiation operator left operand is " &
"complex zero, and the real component of " &
"the exponent is negative");
end;
 
-- Raised by the exponentiation operator, when the value of the
-- left operand is zero and the exponent itself (when it is of
-- type real) is negative.
declare
Negative_Exponent : constant Real_Type := -4.0;
begin
TC_Complex := Complex_Zero**Negative_Exponent;
Report.Failed("Constraint_Error not raised when the " &
"exponentiation operator left operand is " &
"complex zero, and the real exponent is " &
"negative");
No_Optimize(TC_Complex);
exception
when Constraint_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised when the " &
"exponentiation operator left operand is " &
"complex zero, and the real exponent is " &
"negative");
end;
 
-- Raised by Arctan, when the value of the parameter is +i.
begin
TC_Complex := Arctan (Plus_i);
Report.Failed("Constraint_Error not raised when Function " &
"Arctan is given parameter value +i");
No_Optimize(TC_Complex);
exception
when Constraint_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised when Function " &
"Arctan is given parameter value +i");
end;
 
-- Raised by Arctan, when the value of the parameter is -i.
begin
TC_Complex := Arctan (Minus_i);
Report.Failed("Constraint_Error not raised when Function " &
"Arctan is given parameter value -i");
No_Optimize(TC_Complex);
exception
when Constraint_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised when Function " &
"Arctan is given parameter value -i");
end;
 
-- Raised by Arccot, when the value of the parameter is +i.
begin
TC_Complex := Arccot (Plus_i);
Report.Failed("Constraint_Error not raised when Function " &
"Arccot is given parameter value +i");
No_Optimize(TC_Complex);
exception
when Constraint_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised when Function " &
"Arccot is given parameter value +i");
end;
 
-- Raised by Arccot, when the value of the parameter is -i.
begin
TC_Complex := Arccot (Minus_i);
Report.Failed("Constraint_Error not raised when Function " &
"Arccot is given parameter value -i");
No_Optimize(TC_Complex);
exception
when Constraint_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised when Function " &
"Arccot is given parameter value -i");
end;
 
-- Raised by Arctanh, when the value of the parameter is +1.
begin
TC_Complex := Arctanh (Plus_One);
Report.Failed("Constraint_Error not raised when Function " &
"Arctanh is given parameter value +1");
No_Optimize(TC_Complex);
exception
when Constraint_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised when Function " &
"Arctanh is given parameter value +1");
end;
 
-- Raised by Arctanh, when the value of the parameter is -1.
begin
TC_Complex := Arctanh (Minus_One);
Report.Failed("Constraint_Error not raised when Function " &
"Arctanh is given parameter value -1");
No_Optimize(TC_Complex);
exception
when Constraint_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised when Function " &
"Arctanh is given parameter value -1");
end;
 
-- Raised by Arccoth, when the value of the parameter is +1.
begin
TC_Complex := Arccoth (Plus_One);
Report.Failed("Constraint_Error not raised when Function " &
"Arccoth is given parameter value +1");
No_Optimize(TC_Complex);
exception
when Constraint_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised when Function " &
"Arccoth is given parameter value +1");
end;
 
-- Raised by Arccoth, when the value of the parameter is -1.
begin
TC_Complex := Arccoth (Minus_One);
Report.Failed("Constraint_Error not raised when Function " &
"Arccoth is given parameter value -1");
No_Optimize(TC_Complex);
exception
when Constraint_Error => null; -- OK, expected exception.
when others =>
Report.Failed("Incorrect exception raised when Function " &
"Arccoth is given parameter value -1");
end;
 
else
Report.Comment
("Attribute Complex_Pack.Real'Machine_Overflows is False; " &
"evaluation of the complex elementary functions under " &
"specified circumstances was not performed");
end if;
 
 
exception
when others =>
Report.Failed ("Unexpected exception raised in Test_Block");
end Test_Block;
 
Report.Result;
 
end CXG1004;
/cxg2003.a
0,0 → 1,701
-- CXG2003.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the sqrt function returns
-- results that are within the error bound allowed.
--
-- TEST DESCRIPTION:
-- This test contains three test packages that are almost
-- identical. The first two packages differ only in the
-- floating point type that is being tested. The first
-- and third package differ only in whether the generic
-- elementary functions package or the pre-instantiated
-- package is used.
-- The test package is not generic so that the arguments
-- and expected results for some of the test values
-- can be expressed as universal real instead of being
-- computed at runtime.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 2 FEB 96 SAIC Initial release for 2.1
-- 18 AUG 96 SAIC Made Check consistent with other tests.
--
--!
 
with System;
with Report;
with Ada.Numerics.Generic_Elementary_Functions;
with Ada.Numerics.Elementary_Functions;
procedure CXG2003 is
Verbose : constant Boolean := False;
 
package Float_Check is
subtype Real is Float;
procedure Do_Test;
end Float_Check;
 
package body Float_Check is
package Elementary_Functions is new
Ada.Numerics.Generic_Elementary_Functions (Real);
function Sqrt (X : Real) return Real renames
Elementary_Functions.Sqrt;
function Log (X : Real) return Real renames
Elementary_Functions.Log;
function Exp (X : Real) return Real renames
Elementary_Functions.Exp;
 
-- The default Maximum Relative Error is the value specified
-- in the LRM.
Default_MRE : constant Real := 2.0;
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real := Default_MRE) is
Rel_Error : Real;
Abs_Error : Real;
Max_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual - Expected) > Max_Error then
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " &
Real'Image (Actual - Expected) &
" mre:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
procedure Argument_Range_Check (A, B : Real;
Test : String) is
-- test a logarithmically distributed selection of
-- arguments selected from the range A to B.
X : Real;
Expected : Real;
Y : Real;
C : Real := Log(B/A);
Max_Samples : constant := 1000;
 
begin
for I in 1..Max_Samples loop
Expected := A * Exp(C * Real (I) / Real (Max_Samples));
X := Expected * Expected;
Y := Sqrt (X);
 
-- note that since the expected value is computed, we
-- must take the error in that computation into account.
Check (Y, Expected,
"test " & Test & " -" &
Integer'Image (I) &
" of argument range",
3.0);
end loop;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in argument range check");
when others =>
Report.Failed ("exception in argument range check");
end Argument_Range_Check;
 
procedure Do_Test is
begin
 
--- test 1 ---
declare
T : constant := (Real'Machine_EMax - 1) / 2;
X : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
Expected : constant := (1.0 * Real'Machine_Radix) ** T;
Y : Real;
begin
Y := Sqrt (X);
Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 1");
when others =>
Report.Failed ("exception in test 1");
end;
 
--- test 2 ---
declare
T : constant := (Real'Model_EMin + 1) / 2;
X : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
Expected : constant := (1.0 * Real'Machine_Radix) ** T;
Y : Real;
begin
Y := Sqrt (X);
Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 2");
when others =>
Report.Failed ("exception in test 2");
end;
 
--- test 3 ---
declare
X : constant := 1.0;
Expected : constant := 1.0;
Y : Real;
begin
Y := Sqrt(X);
Check (Y, Expected, "test 3 -- sqrt(1.0)",
0.0); -- no error allowed
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 3");
when others =>
Report.Failed ("exception in test 3");
end;
 
--- test 4 ---
declare
X : constant := 0.0;
Expected : constant := 0.0;
Y : Real;
begin
Y := Sqrt(X);
Check (Y, Expected, "test 4 -- sqrt(0.0)",
0.0); -- no error allowed
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 4");
when others =>
Report.Failed ("exception in test 4");
end;
 
--- test 5 ---
declare
X : constant := -1.0;
Y : Real;
begin
Y := Sqrt(X);
-- the following code should not be executed.
-- The call to Check is to keep the call to Sqrt from
-- appearing to be dead code.
Check (Y, -1.0, "test 5 -- sqrt(-1)" );
Report.Failed ("test 5 - argument_error expected");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 5");
when Ada.Numerics.Argument_Error =>
if Verbose then
Report.Comment ("test 5 correctly got argument_error");
end if;
when others =>
Report.Failed ("exception in test 5");
end;
 
--- test 6 ---
declare
X : constant := Ada.Numerics.Pi ** 2;
Expected : constant := Ada.Numerics.Pi;
Y : Real;
begin
Y := Sqrt (X);
Check (Y, Expected, "test 6 -- sqrt(pi**2)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 6");
when others =>
Report.Failed ("exception in test 6");
end;
 
--- test 7 & 8 ---
Argument_Range_Check (1.0/Sqrt(Real(Real'Machine_Radix)),
1.0,
"7");
Argument_Range_Check (1.0,
Sqrt(Real(Real'Machine_Radix)),
"8");
end Do_Test;
end Float_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
 
 
package A_Long_Float_Check is
subtype Real is A_Long_Float;
procedure Do_Test;
end A_Long_Float_Check;
 
package body A_Long_Float_Check is
package Elementary_Functions is new
Ada.Numerics.Generic_Elementary_Functions (Real);
function Sqrt (X : Real) return Real renames
Elementary_Functions.Sqrt;
function Log (X : Real) return Real renames
Elementary_Functions.Log;
function Exp (X : Real) return Real renames
Elementary_Functions.Exp;
 
-- The default Maximum Relative Error is the value specified
-- in the LRM.
Default_MRE : constant Real := 2.0;
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real := Default_MRE) is
Rel_Error : Real;
Abs_Error : Real;
Max_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual - Expected) > Max_Error then
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " &
Real'Image (Actual - Expected) &
" mre:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Argument_Range_Check (A, B : Real;
Test : String) is
-- test a logarithmically distributed selection of
-- arguments selected from the range A to B.
X : Real;
Expected : Real;
Y : Real;
C : Real := Log(B/A);
Max_Samples : constant := 1000;
 
begin
for I in 1..Max_Samples loop
Expected := A * Exp(C * Real (I) / Real (Max_Samples));
X := Expected * Expected;
Y := Sqrt (X);
 
-- note that since the expected value is computed, we
-- must take the error in that computation into account.
Check (Y, Expected,
"test " & Test & " -" &
Integer'Image (I) &
" of argument range",
3.0);
end loop;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in argument range check");
when others =>
Report.Failed ("exception in argument range check");
end Argument_Range_Check;
 
 
procedure Do_Test is
begin
 
--- test 1 ---
declare
T : constant := (Real'Machine_EMax - 1) / 2;
X : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
Expected : constant := (1.0 * Real'Machine_Radix) ** T;
Y : Real;
begin
Y := Sqrt (X);
Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 1");
when others =>
Report.Failed ("exception in test 1");
end;
 
--- test 2 ---
declare
T : constant := (Real'Model_EMin + 1) / 2;
X : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
Expected : constant := (1.0 * Real'Machine_Radix) ** T;
Y : Real;
begin
Y := Sqrt (X);
Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 2");
when others =>
Report.Failed ("exception in test 2");
end;
 
--- test 3 ---
declare
X : constant := 1.0;
Expected : constant := 1.0;
Y : Real;
begin
Y := Sqrt(X);
Check (Y, Expected, "test 3 -- sqrt(1.0)",
0.0); -- no error allowed
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 3");
when others =>
Report.Failed ("exception in test 3");
end;
 
--- test 4 ---
declare
X : constant := 0.0;
Expected : constant := 0.0;
Y : Real;
begin
Y := Sqrt(X);
Check (Y, Expected, "test 4 -- sqrt(0.0)",
0.0); -- no error allowed
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 4");
when others =>
Report.Failed ("exception in test 4");
end;
 
--- test 5 ---
declare
X : constant := -1.0;
Y : Real;
begin
Y := Sqrt(X);
-- the following code should not be executed.
-- The call to Check is to keep the call to Sqrt from
-- appearing to be dead code.
Check (Y, -1.0, "test 5 -- sqrt(-1)" );
Report.Failed ("test 5 - argument_error expected");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 5");
when Ada.Numerics.Argument_Error =>
if Verbose then
Report.Comment ("test 5 correctly got argument_error");
end if;
when others =>
Report.Failed ("exception in test 5");
end;
 
--- test 6 ---
declare
X : constant := Ada.Numerics.Pi ** 2;
Expected : constant := Ada.Numerics.Pi;
Y : Real;
begin
Y := Sqrt (X);
Check (Y, Expected, "test 6 -- sqrt(pi**2)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 6");
when others =>
Report.Failed ("exception in test 6");
end;
 
--- test 7 & 8 ---
Argument_Range_Check (1.0/Sqrt(Real(Real'Machine_Radix)),
1.0,
"7");
Argument_Range_Check (1.0,
Sqrt(Real(Real'Machine_Radix)),
"8");
end Do_Test;
end A_Long_Float_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
package Non_Generic_Check is
procedure Do_Test;
end Non_Generic_Check;
 
package body Non_Generic_Check is
package EF renames
Ada.Numerics.Elementary_Functions;
subtype Real is Float;
 
-- The default Maximum Relative Error is the value specified
-- in the LRM.
Default_MRE : constant Real := 2.0;
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real := Default_MRE) is
Rel_Error : Real;
Abs_Error : Real;
Max_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual - Expected) > Max_Error then
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " &
Real'Image (Actual - Expected) &
" mre:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
 
procedure Argument_Range_Check (A, B : Float;
Test : String) is
-- test a logarithmically distributed selection of
-- arguments selected from the range A to B.
X : Float;
Expected : Float;
Y : Float;
C : Float := EF.Log(B/A);
Max_Samples : constant := 1000;
 
begin
for I in 1..Max_Samples loop
Expected := A * EF.Exp(C * Float (I) / Float (Max_Samples));
X := Expected * Expected;
Y := EF.Sqrt (X);
 
-- note that since the expected value is computed, we
-- must take the error in that computation into account.
Check (Y, Expected,
"test " & Test & " -" &
Integer'Image (I) &
" of argument range",
3.0);
end loop;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in argument range check");
when others =>
Report.Failed ("exception in argument range check");
end Argument_Range_Check;
 
 
procedure Do_Test is
begin
 
--- test 1 ---
declare
T : constant := (Float'Machine_EMax - 1) / 2;
X : constant := (1.0 * Float'Machine_Radix) ** (2 * T);
Expected : constant := (1.0 * Float'Machine_Radix) ** T;
Y : Float;
begin
Y := EF.Sqrt (X);
Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 1");
when others =>
Report.Failed ("exception in test 1");
end;
 
--- test 2 ---
declare
T : constant := (Float'Model_EMin + 1) / 2;
X : constant := (1.0 * Float'Machine_Radix) ** (2 * T);
Expected : constant := (1.0 * Float'Machine_Radix) ** T;
Y : Float;
begin
Y := EF.Sqrt (X);
Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 2");
when others =>
Report.Failed ("exception in test 2");
end;
 
--- test 3 ---
declare
X : constant := 1.0;
Expected : constant := 1.0;
Y : Float;
begin
Y := EF.Sqrt(X);
Check (Y, Expected, "test 3 -- sqrt(1.0)",
0.0); -- no error allowed
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 3");
when others =>
Report.Failed ("exception in test 3");
end;
 
--- test 4 ---
declare
X : constant := 0.0;
Expected : constant := 0.0;
Y : Float;
begin
Y := EF.Sqrt(X);
Check (Y, Expected, "test 4 -- sqrt(0.0)",
0.0); -- no error allowed
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 4");
when others =>
Report.Failed ("exception in test 4");
end;
 
--- test 5 ---
declare
X : constant := -1.0;
Y : Float;
begin
Y := EF.Sqrt(X);
-- the following code should not be executed.
-- The call to Check is to keep the call to Sqrt from
-- appearing to be dead code.
Check (Y, -1.0, "test 5 -- sqrt(-1)" );
Report.Failed ("test 5 - argument_error expected");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 5");
when Ada.Numerics.Argument_Error =>
if Verbose then
Report.Comment ("test 5 correctly got argument_error");
end if;
when others =>
Report.Failed ("exception in test 5");
end;
 
--- test 6 ---
declare
X : constant := Ada.Numerics.Pi ** 2;
Expected : constant := Ada.Numerics.Pi;
Y : Float;
begin
Y := EF.Sqrt (X);
Check (Y, Expected, "test 6 -- sqrt(pi**2)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 6");
when others =>
Report.Failed ("exception in test 6");
end;
 
--- test 7 & 8 ---
Argument_Range_Check (1.0/EF.Sqrt(Float(Float'Machine_Radix)),
1.0,
"7");
Argument_Range_Check (1.0,
EF.Sqrt(Float(Float'Machine_Radix)),
"8");
end Do_Test;
end Non_Generic_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
begin
Report.Test ("CXG2003",
"Check the accuracy of the sqrt function");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking non-generic package");
end if;
 
Non_Generic_Check.Do_Test;
 
Report.Result;
end CXG2003;
/cxg2022.a
0,0 → 1,309
-- CXG2022.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that multiplication and division of binary fixed point
-- numbers with compatible 'small values produce exact results.
--
-- TEST DESCRIPTION:
-- Signed, unsigned, and a mixture of signed and unsigned
-- binary fixed point values are multiplied and divided.
-- The result is checked against the expected "perfect result set"
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 1 Apr 96 SAIC Initial release for 2.1
-- 29 Jan 1998 EDS Repaired fixed point errors ("**" and
-- assumptions about 'Small)
--!
 
with System;
with Report;
procedure CXG2022 is
Verbose : constant Boolean := False;
 
procedure Check_Signed is
type Pairs is delta 2.0 range -2.0 ** (System.Max_Mantissa) ..
2.0 ** (System.Max_Mantissa) - 1.0;
type Halves is delta 0.5 range -2.0 ** (System.Max_Mantissa-2) ..
2.0 ** (System.Max_Mantissa-2) - 1.0;
P1, P2, P3, P4 : Pairs;
H1, H2, H3, H4 : Halves;
 
procedure Dont_Opt is
-- keep optimizer from knowing the constant value of expressions
begin
if Report.Ident_Bool (False) then
P1 := 2.0; P2 := 4.0; P3 := 6.0;
H1 := -2.0; H2 := 9.0; H3 := 3.0;
end if;
end Dont_Opt;
 
begin
H1 := -0.5;
H2 := Halves'First;
H3 := 1.0;
P1 := 12.0;
P2 := Pairs'First;
P3 := Pairs'Last;
Dont_Opt;
 
P4 := Pairs (P1 * H1); -- 12.0 * -0.5
if P4 /= -6.0 then
Report.Failed ("12.0 * -0.5 = " & Pairs'Image (P4));
end if;
 
H4 := Halves (P1 / H1); -- 12.0 / -0.5
if H4 /= -24.0 then
Report.Failed ("12.0 / -0.5 = " & Halves'Image (H4));
end if;
 
P4 := P3 * H3; -- Pairs'Last * 1.0
if P4 /= Pairs'Last then
Report.Failed ("Pairs'Last * 1.0 = " & Pairs'Image (P4));
end if;
 
P4 := P3 / H3; -- Pairs'Last / 1.0
if P4 /= Pairs'Last then
Report.Failed ("Pairs'Last / 1.0 = " & Pairs'Image (P4));
end if;
 
P4 := P2 * 0.25; -- Pairs'First * 0.25
if P4 /= Pairs (-2.0 ** (System.Max_Mantissa - 2)) then
Report.Failed ("Pairs'First * 0.25 = " & Pairs'Image (P4));
end if;
 
P4 := 100.5 / H1; -- 100.5 / -0.5
if P4 = -201.0 then
null; -- Perfect result
elsif Pairs'Small = 2.0 and ( P4 = -200.0 or P4 = -202.0 ) then
null; -- Allowed variation
else
Report.Failed ("Pairs'Small =" & Pairs'Image (Pairs'Small) &
" and 100.5/-0.5 = " & Pairs'Image (P4) );
end if;
 
H4 := H1 * H2; -- -0.5 * Halves'First
if H4 /= Halves (2.0 ** (System.Max_Mantissa-3)) then
Report.Failed ("-0.5 * Halves'First =" & Halves'Image (H4) &
" instead of " &
Halves'Image( Halves(2.0 ** (System.Max_Mantissa-3))));
end if;
 
exception
when others =>
Report.Failed ("unexpected exception in Check_Signed");
end Check_Signed;
 
 
 
procedure Check_Unsigned is
type Pairs is delta 2.0 range 0.0 .. 2.0 ** (System.Max_Mantissa+1) - 1.0;
type Halves is delta 0.5 range 0.0 .. 2.0 ** (System.Max_Mantissa-1) - 1.0;
P1, P2, P3, P4 : Pairs;
H1, H2, H3, H4 : Halves;
 
procedure Dont_Opt is
-- keep optimizer from knowing the constant value of expressions
begin
if Report.Ident_Bool (False) then
P1 := 2.0; P2 := 4.0; P3 := 6.0;
H1 := 2.0; H2 := 9.0; H3 := 3.0;
end if;
end Dont_Opt;
 
begin
H1 := 10.5;
H2 := Halves(2.0 ** (System.Max_Mantissa - 6));
H3 := 1.0;
P1 := 12.0;
P2 := Pairs'Last / 2;
P3 := Pairs'Last;
Dont_Opt;
 
P4 := Pairs (P1 * H1); -- 12.0 * 10.5
if P4 /= 126.0 then
Report.Failed ("12.0 * 10.5 = " & Pairs'Image (P4));
end if;
 
H4 := Halves (P1 / H1); -- 12.0 / 10.5
if H4 /= 1.0 and H4 /= 1.5 then
Report.Failed ("12.0 / 10.5 = " & Halves'Image (H4));
end if;
 
P4 := P3 * H3; -- Pairs'Last * 1.0
if P4 /= Pairs'Last then
Report.Failed ("Pairs'Last * 1.0 = " & Pairs'Image (P4));
end if;
 
P4 := P3 / H3; -- Pairs'Last / 1.0
if P4 /= Pairs'Last then
Report.Failed ("Pairs'Last / 1.0 = " & Pairs'Image (P4));
end if;
 
P4 := P1 * 0.25; -- 12.0 * 0.25
if P4 /= 2.0 and P4 /= 4.0 then
Report.Failed ("12.0 * 0.25 = " & Pairs'Image (P4));
end if;
 
P4 := 100.5 / H1; -- 100.5 / 10.5 = 9.571...
if P4 /= 8.0 and P4 /= 10.0 then
Report.Failed ("100.5/10.5 = " & Pairs'Image (P4));
end if;
 
H4 := H2 * 2; -- 2**(max_mantissa-6) * 2
if H4 /= Halves(2.0 ** (System.Max_Mantissa-5)) then
Report.Failed ("2**(System.Max_Mantissa-6) * 2=" & Halves'Image (H4) &
" instead of " &
Halves'Image( Halves(2.0 ** (System.Max_Mantissa-5))));
end if;
 
exception
when others =>
Report.Failed ("unexpected exception in Check_Unsigned");
end Check_Unsigned;
 
 
 
procedure Check_Mixed is
type Pairs is delta 2.0 range -2.0 ** (System.Max_Mantissa) ..
2.0 ** (System.Max_Mantissa) - 1.0;
type Halves is delta 0.5 range 0.0 .. 2.0 ** (System.Max_Mantissa-1) - 1.0;
P1, P2, P3, P4 : Pairs;
H1, H2, H3, H4 : Halves;
 
procedure Dont_Opt is
-- keep optimizer from knowing the constant value of expressions
begin
if Report.Ident_Bool (False) then
P1 := 2.0; P2 := 4.0; P3 := 6.0;
H1 := 2.0; H2 := 9.0; H3 := 3.0;
end if;
end Dont_Opt;
 
begin
H1 := 10.5;
H2 := Halves(2.0 ** (System.Max_Mantissa - 6));
H3 := 1.0;
P1 := 12.0;
P2 := -4.0;
P3 := Pairs'Last;
Dont_Opt;
 
P4 := Pairs (P1 * H1); -- 12.0 * 10.5
if P4 /= 126.0 then
Report.Failed ("12.0 * 10.5 = " & Pairs'Image (P4));
end if;
 
H4 := Halves (P1 / H1); -- 12.0 / 10.5
if H4 /= 1.0 and H4 /= 1.5 then
Report.Failed ("12.0 / 10.5 = " & Halves'Image (H4));
end if;
 
P4 := P3 * H3; -- Pairs'Last * 1.0
if P4 /= Pairs'Last then
Report.Failed ("Pairs'Last * 1.0 = " & Pairs'Image (P4));
end if;
 
P4 := P3 / H3; -- Pairs'Last / 1.0
if P4 /= Pairs'Last then
Report.Failed ("Pairs'Last / 1.0 = " & Pairs'Image (P4));
end if;
 
P4 := P1 * 0.25; -- 12.0 * 0.25
if P4 = 3.0 then
null; -- Perfect result
elsif Pairs'Small = 2.0 and then ( P4 = 2.0 or P4 = 4.0 ) then
null; -- Allowed deviation
else
Report.Failed ("Pairs'Small =" & Pairs'Image (Pairs'Small) &
"and 12.0 * 0.25 = " & Pairs'Image (P4) );
end if;
 
P4 := 100.5 / H1; -- 100.5 / 10.5 = 9.571...
if P4 = 9.0 then
null; -- Perfect result
elsif Pairs'Small = 2.0 and then ( P4 = 8.0 or P4 = 10.0 ) then
null; -- Allowed values
else
Report.Failed ("Pairs'Small =" & Pairs'Image (Pairs'Small) &
"and 100.5/10.5 = " & Pairs'Image (P4) );
end if;
 
H4 := H2 * 2; -- 2**(max_mantissa-6) * 2
if H4 /= Halves(2.0 ** (System.Max_Mantissa-5)) then
Report.Failed ("2**(System.Max_Mantissa-6) * 2=" & Halves'Image (H4) &
" instead of " &
Halves'Image( Halves(2.0 ** (System.Max_Mantissa-5))));
end if;
 
P4 := Pairs(P1 * 6) / P2; -- 12 * 6 / -4
if (P4 /= -18.0) then
Report.Failed ("12*6/-4 = " & Pairs'Image(P4));
end if;
 
P4 := Halves(P1 * 6.0) / P2; -- 12 * 6 / -4
if (P4 /= -18.0) then
Report.Failed ("Halves(12*6)/-4 = " & Pairs'Image(P4));
end if;
 
exception
when others =>
Report.Failed ("unexpected exception in Check_Mixed");
end Check_Mixed;
 
 
begin -- main
Report.Test ("CXG2022",
"Check the accuracy of multiplication and division" &
" of binary fixed point numbers");
if Verbose then
Report.Comment ("starting signed test");
end if;
Check_Signed;
 
if Verbose then
Report.Comment ("starting unsigned test");
end if;
Check_Unsigned;
 
if Verbose then
Report.Comment ("starting mixed sign test");
end if;
Check_Mixed;
 
Report.Result;
end CXG2022;
/cxg2013.a
0,0 → 1,367
-- CXG2013.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the TAN and COT functions return
-- results that are within the error bound allowed.
--
-- TEST DESCRIPTION:
-- This test consists of a generic package that is
-- instantiated to check both Float and a long float type.
-- The test for each floating point type is divided into
-- several parts:
-- Special value checks where the result is a known constant.
-- Checks that use an identity for determining the result.
-- Exception checks.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 11 Mar 96 SAIC Initial release for 2.1
-- 17 Aug 96 SAIC Commentary fixes.
-- 03 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi
-- 02 DEC 97 EDS Change Max_Samples constant to 1001.
-- 29 JUN 98 EDS Deleted Special_Angle_Test as fatally flawed.
 
--!
 
--
-- References:
--
-- Software Manual for the Elementary Functions
-- William J. Cody, Jr. and William Waite
-- Prentice-Hall, 1980
--
-- CRC Standard Mathematical Tables
-- 23rd Edition
--
-- Implementation and Testing of Function Software
-- W. J. Cody
-- Problems and Methodologies in Mathematical Software Production
-- editors P. C. Messina and A. Murli
-- Lecture Notes in Computer Science Volume 142
-- Springer Verlag, 1982
--
 
with System;
with Report;
with Ada.Numerics.Generic_Elementary_Functions;
procedure CXG2013 is
Verbose : constant Boolean := False;
Max_Samples : constant := 1001;
 
-- CRC Standard Mathematical Tables; 23rd Edition; pg 738
Sqrt2 : constant :=
1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
Sqrt3 : constant :=
1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
Pi : constant := Ada.Numerics.Pi;
 
generic
type Real is digits <>;
package Generic_Check is
procedure Do_Test;
end Generic_Check;
 
package body Generic_Check is
package Elementary_Functions is new
Ada.Numerics.Generic_Elementary_Functions (Real);
function Sqrt (X : Real) return Real renames
Elementary_Functions.Sqrt;
function Tan (X : Real) return Real renames
Elementary_Functions.Tan;
function Cot (X : Real) return Real renames
Elementary_Functions.Cot;
function Tan (X, Cycle : Real) return Real renames
Elementary_Functions.Tan;
function Cot (X, Cycle : Real) return Real renames
Elementary_Functions.Cot;
 
-- flag used to terminate some tests early
Accuracy_Error_Reported : Boolean := False;
 
-- factor to be applied in computing MRE
Maximum_Relative_Error : constant Real := 4.0;
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real) is
Max_Error : Real;
Rel_Error : Real;
Abs_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual - Expected) > Max_Error then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
 
procedure Exact_Result_Test is
No_Error : constant := 0.0;
begin
-- A.5.1(38);6.0
Check (Tan (0.0), 0.0, "tan(0)", No_Error);
 
-- A.5.1(41);6.0
Check (Tan (180.0, 360.0), 0.0, "tan(180,360)", No_Error);
Check (Tan (360.0, 360.0), 0.0, "tan(360,360)", No_Error);
Check (Tan (720.0, 360.0), 0.0, "tan(720,360)", No_Error);
 
-- A.5.1(41);6.0
Check (Cot ( 90.0, 360.0), 0.0, "cot( 90,360)", No_Error);
Check (Cot (270.0, 360.0), 0.0, "cot(270,360)", No_Error);
Check (Cot (810.0, 360.0), 0.0, "cot(810,360)", No_Error);
 
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in Exact_Result Test");
when others =>
Report.Failed ("exception in Exact_Result Test");
end Exact_Result_Test;
 
 
procedure Tan_Test (A, B : Real) is
-- Use identity Tan(X) = [2*Tan(x/2)]/[1-Tan(x/2) ** 2]
-- checks over the range -pi/4 .. pi/4 require no argument reduction
-- checks over the range 7pi/8 .. 9pi/8 require argument reduction
X, Y : Real;
Actual1, Actual2 : Real;
begin
Accuracy_Error_Reported := False; -- reset
for I in 1..Max_Samples loop
X := (B - A) * Real (I) / Real (Max_Samples) + A;
-- argument purification to insure x and x/2 are exact
-- See Cody page 170.
Y := Real'Machine (X*0.5);
X := Real'Machine (Y + Y);
Actual1 := Tan(X);
Actual2 := (2.0 * Tan (Y)) / (1.0 - Tan (Y) ** 2);
if abs (X - Pi) > ( (B-A)/Real(2*Max_Samples) ) then
Check (Actual1, Actual2,
"Tan_Test " & Integer'Image (I) & ": tan(" &
Real'Image (X) & ") ",
(1.0 + Sqrt2) * Maximum_Relative_Error);
-- see Cody pg 165 for error bound info
end if;
 
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
 
end loop;
 
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Tan_Test");
when others =>
Report.Failed ("exception in Tan_Test");
end Tan_Test;
 
 
 
procedure Cot_Test is
-- Use identity Cot(X) = [Cot(X/2)**2 - 1]/[2*Cot(X/2)]
A : constant := 6.0 * Pi;
B : constant := 25.0 / 4.0 * Pi;
X, Y : Real;
Actual1, Actual2 : Real;
begin
Accuracy_Error_Reported := False; -- reset
for I in 1..Max_Samples loop
X := (B - A) * Real (I) / Real (Max_Samples) + A;
-- argument purification to insure x and x/2 are exact.
-- See Cody page 170.
Y := Real'Machine (X*0.5);
X := Real'Machine (Y + Y);
Actual1 := Cot(X);
Actual2 := (Cot (Y) ** 2 - 1.0) / (2.0 * Cot (Y));
Check (Actual1, Actual2,
"Cot_Test " & Integer'Image (I) & ": cot(" &
Real'Image (X) & ") ",
(1.0 + Sqrt2) * Maximum_Relative_Error);
-- see Cody pg 165 for error bound info
 
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
 
end loop;
 
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Cot_Test");
when others =>
Report.Failed ("exception in Cot_Test");
end Cot_Test;
 
 
procedure Exception_Test is
X1, X2, X3, X4, X5 : Real := 0.0;
begin
 
 
begin -- A.5.1(20);6.0
X1 := Tan (0.0, Cycle => 0.0);
Report.Failed ("no exception for cycle = 0.0");
exception
when Ada.Numerics.Argument_Error => null;
when others =>
Report.Failed ("wrong exception for cycle = 0.0");
end;
 
begin -- A.5.1(20);6.0
X2 := Cot (1.0, Cycle => -3.0);
Report.Failed ("no exception for cycle < 0.0");
exception
when Ada.Numerics.Argument_Error => null;
when others =>
Report.Failed ("wrong exception for cycle < 0.0");
end;
 
-- the remaining tests only apply to machines that overflow
if Real'Machine_Overflows then -- A.5.1(28);6.0
 
begin -- A.5.1(29);6.0
X3 := Cot (0.0);
Report.Failed ("exception not raised for cot(0)");
exception
when Constraint_Error => null; -- ok
when others =>
Report.Failed ("wrong exception raised for cot(0)");
end;
begin -- A.5.1(31);6.0
X4 := Tan (90.0, 360.0);
Report.Failed ("exception not raised for tan(90,360)");
exception
when Constraint_Error => null; -- ok
when others =>
Report.Failed ("wrong exception raised for tan(90,360)");
end;
 
begin -- A.5.1(32);6.0
X5 := Cot (180.0, 360.0);
Report.Failed ("exception not raised for cot(180,360)");
exception
when Constraint_Error => null; -- ok
when others =>
Report.Failed ("wrong exception raised for cot(180,360)");
end;
end if;
 
-- optimizer thwarting
if Report.Ident_Bool (False) then
Report.Comment (Real'Image (X1+X2+X3+X4+X5));
end if;
end Exception_Test;
 
 
procedure Do_Test is
begin
Exact_Result_Test;
Tan_Test (-Pi/4.0, Pi/4.0);
Tan_Test (7.0*Pi/8.0, 9.0*Pi/8.0);
Cot_Test;
Exception_Test;
end Do_Test;
end Generic_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
package Float_Check is new Generic_Check (Float);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
package A_Long_Float_Check is new Generic_Check (A_Long_Float);
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
 
begin
Report.Test ("CXG2013",
"Check the accuracy of the TAN and COT functions");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
 
Report.Result;
end CXG2013;
/cxg1005.a
0,0 → 1,393
-- CXG1005.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the subprograms defined in the package
-- Ada.Numerics.Generic_Complex_Elementary_Functions provide correct
-- results.
--
-- TEST DESCRIPTION:
-- This test checks that specific subprograms defined in the generic
-- package Generic_Complex_Elementary_Functions are available, and that
-- they provide prescribed results given specific input values.
-- The generic package Ada.Numerics.Generic_Complex_Types is instantiated
-- with a real type (new Float). The resulting new package is used as
-- the generic actual to package Complex_IO.
--
-- SPECIAL REQUIREMENTS:
-- Implementations for which Float'Signed_Zeros is True must provide
-- a body for ImpDef.Annex_G.Negative_Zero which returns a negative
-- zero.
--
-- APPLICABILITY CRITERIA
-- This test only applies to implementations that support the
-- numerics annex.
--
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 16 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1.
-- 21 Feb 96 SAIC Incorporated new structure for package Impdef.
-- 29 Sep 96 SAIC Incorporated reviewer comments.
--
--!
 
with Ada.Numerics.Generic_Complex_Types;
with Ada.Numerics.Generic_Complex_Elementary_Functions;
with ImpDef.Annex_G;
with Report;
 
procedure CXG1005 is
begin
 
Report.Test ("CXG1005", "Check that the subprograms defined in " &
"the package Generic_Complex_Elementary_" &
"Functions provide correct results");
 
Test_Block:
declare
 
type Real_Type is new Float;
 
TC_Signed_Zeros : Boolean := Real_Type'Signed_Zeros;
 
package Complex_Pack is new
Ada.Numerics.Generic_Complex_Types(Real_Type);
 
package CEF is
new Ada.Numerics.Generic_Complex_Elementary_Functions(Complex_Pack);
 
use Ada.Numerics, Complex_Pack, CEF;
 
Complex_Zero : constant Complex := Compose_From_Cartesian( 0.0, 0.0);
Plus_One : constant Complex := Compose_From_Cartesian( 1.0, 0.0);
Minus_One : constant Complex := Compose_From_Cartesian(-1.0, 0.0);
Plus_i : constant Complex := Compose_From_Cartesian(i);
Minus_i : constant Complex := Compose_From_Cartesian(-i);
 
Complex_Positive_Real : constant Complex :=
Compose_From_Cartesian(4.0, 2.0);
Complex_Positive_Imaginary : constant Complex :=
Compose_From_Cartesian(3.0, 5.0);
Complex_Negative_Real : constant Complex :=
Compose_From_Cartesian(-4.0, 2.0);
Complex_Negative_Imaginary : constant Complex :=
Compose_From_Cartesian(3.0, -5.0);
 
 
function A_Zero_Result (Z : Complex) return Boolean is
begin
return (Re(Z) = 0.0 and Im(Z) = 0.0);
end A_Zero_Result;
 
 
-- In order to evaluate complex elementary functions that are
-- prescribed to return a "real" result (meaning that the imaginary
-- component is zero), the Function A_Real_Result is defined.
 
function A_Real_Result (Z : Complex) return Boolean is
begin
return Im(Z) = 0.0;
end A_Real_Result;
 
 
-- In order to evaluate complex elementary functions that are
-- prescribed to return an "imaginary" result (meaning that the real
-- component of the complex number is zero, and the imaginary
-- component is non-zero), the Function An_Imaginary_Result is defined.
 
function An_Imaginary_Result (Z : Complex) return Boolean is
begin
return (Re(Z) = 0.0 and Im(Z) /= 0.0);
end An_Imaginary_Result;
 
 
begin
 
-- Check that when the input parameter value is zero, the following
-- functions yield a zero result.
 
if not A_Zero_Result( Sqrt(Complex_Zero) ) then
Report.Failed("Non-zero result from Function Sqrt with zero input");
end if;
 
if not A_Zero_Result( Sin(Complex_Zero) ) then
Report.Failed("Non-zero result from Function Sin with zero input");
end if;
 
if not A_Zero_Result( Arcsin(Complex_Zero) ) then
Report.Failed("Non-zero result from Function Arcsin with zero " &
"input");
end if;
 
if not A_Zero_Result( Tan(Complex_Zero) ) then
Report.Failed("Non-zero result from Function Tan with zero input");
end if;
 
if not A_Zero_Result( Arctan(Complex_Zero) ) then
Report.Failed("Non-zero result from Function Arctan with zero " &
"input");
end if;
 
if not A_Zero_Result( Sinh(Complex_Zero) ) then
Report.Failed("Non-zero result from Function Sinh with zero input");
end if;
 
if not A_Zero_Result( Arcsinh(Complex_Zero) ) then
Report.Failed("Non-zero result from Function Arcsinh with zero " &
"input");
end if;
 
if not A_Zero_Result( Tanh(Complex_Zero) ) then
Report.Failed("Non-zero result from Function Tanh with zero input");
end if;
 
if not A_Zero_Result( Arctanh(Complex_Zero) ) then
Report.Failed("Non-zero result from Function Arctanh with zero " &
"input");
end if;
 
 
-- Check that when the input parameter value is zero, the following
-- functions yield a result of one.
 
if Exp(Complex_Zero) /= Plus_One
then
Report.Failed("Non-zero result from Function Exp with zero input");
end if;
 
if Cos(Complex_Zero) /= Plus_One
then
Report.Failed("Non-zero result from Function Cos with zero input");
end if;
 
if Cosh(Complex_Zero) /= Plus_One
then
Report.Failed("Non-zero result from Function Cosh with zero input");
end if;
 
 
-- Check that when the input parameter value is zero, the following
-- functions yield a real result.
 
if not A_Real_Result( Arccos(Complex_Zero) ) then
Report.Failed("Non-real result from Function Arccos with zero input");
end if;
 
if not A_Real_Result( Arccot(Complex_Zero) ) then
Report.Failed("Non-real result from Function Arccot with zero input");
end if;
 
 
-- Check that when the input parameter value is zero, the following
-- functions yield an imaginary result.
 
if not An_Imaginary_Result( Arccoth(Complex_Zero) ) then
Report.Failed("Non-imaginary result from Function Arccoth with " &
"zero input");
end if;
 
 
-- Check that when the input parameter value is one, the Sqrt function
-- yields a result of one.
 
if Sqrt(Plus_One) /= Plus_One then
Report.Failed("Incorrect result from Function Sqrt with input " &
"value of one");
end if;
 
 
-- Check that when the input parameter value is one, the following
-- functions yield a result of zero.
 
if not A_Zero_Result( Log(Plus_One) ) then
Report.Failed("Non-zero result from Function Log with input " &
"value of one");
end if;
 
if not A_Zero_Result( Arccos(Plus_One) ) then
Report.Failed("Non-zero result from Function Arccos with input " &
"value of one");
end if;
 
if not A_Zero_Result( Arccosh(Plus_One) ) then
Report.Failed("Non-zero result from Function Arccosh with input " &
"value of one");
end if;
 
 
-- Check that when the input parameter value is one, the Arcsin
-- function yields a real result.
 
if not A_Real_Result( Arcsin(Plus_One) ) then
Report.Failed("Non-real result from Function Arcsin with input " &
"value of one");
end if;
 
 
-- Check that when the input parameter value is minus one, the Sqrt
-- function yields a result of "i", when the sign of the imaginary
-- component of the input parameter is positive (and yields "-i", if
-- the sign on the imaginary component is negative), and the
-- Complex_Types.Real'Signed_Zeros attribute is True.
 
if TC_Signed_Zeros then
 
declare
Minus_One_With_Pos_Zero_Im_Component : Complex :=
Compose_From_Cartesian(-1.0, +0.0);
Minus_One_With_Neg_Zero_Im_Component : Complex :=
Compose_From_Cartesian
(-1.0, Real_Type(ImpDef.Annex_G.Negative_Zero));
begin
 
if Sqrt(Minus_One_With_Pos_Zero_Im_Component) /= Plus_i then
Report.Failed("Incorrect result from Function Sqrt, when " &
"input value is minus one with a positive " &
"imaginary component, Signed_Zeros being True");
end if;
 
if Sqrt(Minus_One_With_Neg_Zero_Im_Component) /= Minus_i then
Report.Failed("Incorrect result from Function Sqrt, when " &
"input value is minus one with a negative " &
"imaginary component, Signed_Zeros being True");
end if;
end;
 
else -- Signed_Zeros is False.
 
-- Check that when the input parameter value is minus one, the Sqrt
-- function yields a result of "i", when the
-- Complex_Types.Real'Signed_Zeros attribute is False.
 
if Sqrt(Minus_One) /= Plus_i then
Report.Failed("Incorrect result from Function Sqrt, when " &
"input value is minus one, Signed_Zeros being " &
"False");
end if;
 
end if;
 
 
-- Check that when the input parameter value is minus one, the Log
-- function yields an imaginary result.
 
if not An_Imaginary_Result( Log(Minus_One) ) then
Report.Failed("Non-imaginary result from Function Log with a " &
"minus one input value");
end if;
 
-- Check that when the input parameter is minus one, the following
-- functions yield a real result.
 
if not A_Real_Result( Arcsin(Minus_One) ) then
Report.Failed("Non-real result from Function Arcsin with a " &
"minus one input value");
end if;
 
if not A_Real_Result( Arccos(Minus_One) ) then
Report.Failed("Non-real result from Function Arccos with a " &
"minus one input value");
end if;
 
 
-- Check that when the input parameter has a value of +i or -i, the
-- Log function yields an imaginary result.
 
if not An_Imaginary_Result( Log(Plus_i) ) then
Report.Failed("Non-imaginary result from Function Log with an " &
"input value of ""+i""");
end if;
 
if not An_Imaginary_Result( Log(Minus_i) ) then
Report.Failed("Non-imaginary result from Function Log with an " &
"input value of ""-i""");
end if;
 
 
-- Check that exponentiation by a zero exponent yields the value one.
 
if "**"(Left => Compose_From_Cartesian(5.0, 3.0),
Right => Complex_Zero) /= Plus_One or
Complex_Negative_Real**0.0 /= Plus_One or
15.0**Complex_Zero /= Plus_One
then
Report.Failed("Incorrect result from exponentiation with a zero " &
"exponent");
end if;
 
 
-- Check that exponentiation by a unit exponent yields the value of
-- the left operand (as a complex value).
-- Note: a "unit exponent" is considered the complex number (1.0, 0.0)
 
if "**"(Complex_Negative_Real, Plus_One) /=
Complex_Negative_Real or
Complex_Negative_Imaginary**Plus_One /=
Complex_Negative_Imaginary or
4.0**Plus_One /=
Compose_From_Cartesian(4.0, 0.0)
then
Report.Failed("Incorrect result from exponentiation with a unit " &
"exponent");
end if;
 
 
-- Check that exponentiation of the value one yields the value one.
 
if "**"(Plus_One, Complex_Negative_Imaginary) /= Plus_One or
Plus_One**9.0 /= Plus_One or
1.0**Complex_Negative_Real /= Plus_One
then
Report.Failed("Incorrect result from exponentiation of the value " &
"One");
end if;
 
 
-- Check that exponentiation of the value zero yields the value zero.
begin
if not A_Zero_Result("**"(Complex_Zero,
Complex_Positive_Imaginary)) or
not A_Zero_Result(Complex_Zero**4.0) or
not A_Zero_Result(0.0**Complex_Positive_Real)
then
Report.Failed("Incorrect result from exponentiation of the " &
"value zero");
end if;
exception
when others =>
Report.Failed("Exception raised during the exponentiation of " &
"the complex value zero");
end;
 
 
exception
when others => Report.Failed ("Exception raised in Test_Block");
end Test_Block;
 
Report.Result;
 
end CXG1005;
/cxg2004.a
0,0 → 1,499
-- CXG2004.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the sin and cos functions return
-- results that are within the error bound allowed.
--
-- TEST DESCRIPTION:
-- This test consists of a generic package that is
-- instantiated to check both float and a long float type.
-- The test for each floating point type is divided into
-- the following parts:
-- Special value checks where the result is a known constant.
-- Checks using an identity relationship.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 13 FEB 96 SAIC Initial release for 2.1
-- 22 APR 96 SAIC Changed to generic implementation.
-- 18 AUG 96 SAIC Improvements to commentary.
-- 23 OCT 96 SAIC Exact results are not required unless the
-- cycle is specified.
-- 28 FEB 97 PWB.CTA Removed checks where cycle 2.0*Pi is specified
-- 02 JUN 98 EDS Revised calculations to ensure that X is exactly
-- three times Y per advice of numerics experts.
--
-- CHANGE NOTE:
-- According to Ken Dritz, author of the Numerics Annex of the RM,
-- one should never specify the cycle 2.0*Pi for the trigonometric
-- functions. In particular, if the machine number for the first
-- argument is not an exact multiple of the machine number for the
-- explicit cycle, then the specified exact results cannot be
-- reasonably expected. The affected checks in this test have been
-- marked as comments, with the additional notation "pwb-math".
-- Phil Brashear
--!
 
--
-- References:
--
-- Software Manual for the Elementary Functions
-- William J. Cody, Jr. and William Waite
-- Prentice-Hall, 1980
--
-- CRC Standard Mathematical Tables
-- 23rd Edition
--
-- Implementation and Testing of Function Software
-- W. J. Cody
-- Problems and Methodologies in Mathematical Software Production
-- editors P. C. Messina and A. Murli
-- Lecture Notes in Computer Science Volume 142
-- Springer Verlag, 1982
--
-- The sin and cos checks are translated directly from
-- the netlib FORTRAN code that was written by W. Cody.
--
 
with System;
with Report;
with Ada.Numerics.Generic_Elementary_Functions;
with Ada.Numerics.Elementary_Functions;
procedure CXG2004 is
Verbose : constant Boolean := False;
Number_Samples : constant := 1000;
 
-- CRC Standard Mathematical Tables; 23rd Edition; pg 738
Sqrt2 : constant :=
1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
Sqrt3 : constant :=
1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
 
Pi : constant := Ada.Numerics.Pi;
 
generic
type Real is digits <>;
package Generic_Check is
procedure Do_Test;
end Generic_Check;
 
package body Generic_Check is
package Elementary_Functions is new
Ada.Numerics.Generic_Elementary_Functions (Real);
 
function Sin (X : Real) return Real renames
Elementary_Functions.Sin;
function Cos (X : Real) return Real renames
Elementary_Functions.Cos;
function Sin (X, Cycle : Real) return Real renames
Elementary_Functions.Sin;
function Cos (X, Cycle : Real) return Real renames
Elementary_Functions.Cos;
 
Accuracy_Error_Reported : Boolean := False;
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real) is
Rel_Error,
Abs_Error,
Max_Error : Real;
begin
 
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
 
-- in addition to the relative error checks we apply the
-- criteria of G.2.4(16)
if abs (Actual) > 1.0 then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name & " result > 1.0");
elsif abs (Actual - Expected) > Max_Error then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " &
Real'Image (Actual - Expected) &
" mre:" &
Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Sin_Check (A, B : Real;
Arg_Range : String) is
-- test a selection of
-- arguments selected from the range A to B.
--
-- This test uses the identity
-- sin(x) = sin(x/3)*(3 - 4 * sin(x/3)**2)
--
-- Note that in this test we must take into account the
-- error in the calculation of the expected result so
-- the maximum relative error is larger than the
-- accuracy required by the ARM.
 
X, Y, ZZ : Real;
Actual, Expected : Real;
MRE : Real;
Ran : Real;
begin
Accuracy_Error_Reported := False; -- reset
for I in 1 .. Number_Samples loop
-- Evenly distributed selection of arguments
Ran := Real (I) / Real (Number_Samples);
 
-- make sure x and x/3 are both exactly representable
-- on the machine. See "Implementation and Testing of
-- Function Software" page 44.
X := (B - A) * Ran + A;
Y := Real'Leading_Part
( X/3.0,
Real'Machine_Mantissa - Real'Exponent (3.0) );
X := Y * 3.0;
 
Actual := Sin (X);
 
ZZ := Sin(Y);
Expected := ZZ * (3.0 - 4.0 * ZZ * ZZ);
 
-- note that since the expected value is computed, we
-- must take the error in that computation into account.
-- See Cody pp 139-141.
MRE := 4.0;
 
Check (Actual, Expected,
"sin test of range" & Arg_Range &
Integer'Image (I),
MRE);
exit when Accuracy_Error_Reported;
end loop;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in sin check");
when others =>
Report.Failed ("exception in sin check");
end Sin_Check;
 
 
 
procedure Cos_Check (A, B : Real;
Arg_Range : String) is
-- test a selection of
-- arguments selected from the range A to B.
--
-- This test uses the identity
-- cos(x) = cos(x/3)*(4 * cos(x/3)**2 - 3)
--
-- Note that in this test we must take into account the
-- error in the calculation of the expected result so
-- the maximum relative error is larger than the
-- accuracy required by the ARM.
 
X, Y, ZZ : Real;
Actual, Expected : Real;
MRE : Real;
Ran : Real;
begin
Accuracy_Error_Reported := False; -- reset
for I in 1 .. Number_Samples loop
-- Evenly distributed selection of arguments
Ran := Real (I) / Real (Number_Samples);
 
-- make sure x and x/3 are both exactly representable
-- on the machine. See "Implementation and Testing of
-- Function Software" page 44.
X := (B - A) * Ran + A;
Y := Real'Leading_Part
( X/3.0,
Real'Machine_Mantissa - Real'Exponent (3.0) );
X := Y * 3.0;
 
Actual := Cos (X);
 
ZZ := Cos(Y);
Expected := ZZ * (4.0 * ZZ * ZZ - 3.0);
 
-- note that since the expected value is computed, we
-- must take the error in that computation into account.
-- See Cody pp 141-143.
MRE := 6.0;
 
Check (Actual, Expected,
"cos test of range" & Arg_Range &
Integer'Image (I),
MRE);
exit when Accuracy_Error_Reported;
end loop;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in cos check");
when others =>
Report.Failed ("exception in cos check");
end Cos_Check;
 
 
procedure Special_Angle_Checks is
type Data_Point is
record
Degrees,
Radians,
Sine,
Cosine : Real;
Sin_Result_Error,
Cos_Result_Error : Boolean;
end record;
 
type Test_Data_Type is array (Positive range <>) of Data_Point;
 
-- the values in the following table only involve static
-- expressions to minimize any loss of precision. However,
-- there are two sources of error that must be accounted for
-- in the following tests.
-- First, when a cycle is not specified there can be a roundoff
-- error in the value of Pi used. This error does not apply
-- when a cycle of 2.0 * Pi is explicitly provided.
-- Second, the expected results that involve sqrt values also
-- have a potential roundoff error.
-- The amount of error due to error in the argument is computed
-- as follows:
-- sin(x+err) = sin(x)*cos(err) + cos(x)*sin(err)
-- ~= sin(x) + err * cos(x)
-- similarly for cos the error due to error in the argument is
-- computed as follows:
-- cos(x+err) = cos(x)*cos(err) - sin(x)*sin(err)
-- ~= cos(x) - err * sin(x)
-- In both cases the term "err" is bounded by 0.5 * argument.
 
Test_Data : constant Test_Data_Type := (
-- degrees radians sine cosine sin_er cos_er test #
( 0.0, 0.0, 0.0, 1.0, False, False ), -- 1
( 30.0, Pi/6.0, 0.5, Sqrt3/2.0, False, True ), -- 2
( 60.0, Pi/3.0, Sqrt3/2.0, 0.5, True, False ), -- 3
( 90.0, Pi/2.0, 1.0, 0.0, False, False ), -- 4
(120.0, 2.0*Pi/3.0, Sqrt3/2.0, -0.5, True, False ), -- 5
(150.0, 5.0*Pi/6.0, 0.5, -Sqrt3/2.0, False, True ), -- 6
(180.0, Pi, 0.0, -1.0, False, False ), -- 7
(210.0, 7.0*Pi/6.0, -0.5, -Sqrt3/2.0, False, True ), -- 8
(240.0, 8.0*Pi/6.0, -Sqrt3/2.0, -0.5, True, False ), -- 9
(270.0, 9.0*Pi/6.0, -1.0, 0.0, False, False ), -- 10
(300.0, 10.0*Pi/6.0, -Sqrt3/2.0, 0.5, True, False ), -- 11
(330.0, 11.0*Pi/6.0, -0.5, Sqrt3/2.0, False, True ), -- 12
(360.0, 2.0*Pi, 0.0, 1.0, False, False ), -- 13
( 45.0, Pi/4.0, Sqrt2/2.0, Sqrt2/2.0, True, True ), -- 14
(135.0, 3.0*Pi/4.0, Sqrt2/2.0, -Sqrt2/2.0, True, True ), -- 15
(225.0, 5.0*Pi/4.0, -Sqrt2/2.0, -Sqrt2/2.0, True, True ), -- 16
(315.0, 7.0*Pi/4.0, -Sqrt2/2.0, Sqrt2/2.0, True, True ), -- 17
(405.0, 9.0*Pi/4.0, Sqrt2/2.0, Sqrt2/2.0, True, True ) ); -- 18
Y : Real;
Sin_Arg_Err,
Cos_Arg_Err,
Sin_Result_Err,
Cos_Result_Err : Real;
begin
for I in Test_Data'Range loop
-- compute error components
Sin_Arg_Err := abs Test_Data (I).Cosine *
abs Test_Data (I).Radians / 2.0;
Cos_Arg_Err := abs Test_Data (I).Sine *
abs Test_Data (I).Radians / 2.0;
 
if Test_Data (I).Sin_Result_Error then
Sin_Result_Err := 0.5;
else
Sin_Result_Err := 0.0;
end if;
 
if Test_Data (I).Cos_Result_Error then
Cos_Result_Err := 1.0;
else
Cos_Result_Err := 0.0;
end if;
 
 
 
Y := Sin (Test_Data (I).Radians);
Check (Y, Test_Data (I).Sine,
"test" & Integer'Image (I) & " sin(r)",
2.0 + Sin_Arg_Err + Sin_Result_Err);
Y := Cos (Test_Data (I).Radians);
Check (Y, Test_Data (I).Cosine,
"test" & Integer'Image (I) & " cos(r)",
2.0 + Cos_Arg_Err + Cos_Result_Err);
Y := Sin (Test_Data (I).Degrees, 360.0);
Check (Y, Test_Data (I).Sine,
"test" & Integer'Image (I) & " sin(d,360)",
2.0 + Sin_Result_Err);
Y := Cos (Test_Data (I).Degrees, 360.0);
Check (Y, Test_Data (I).Cosine,
"test" & Integer'Image (I) & " cos(d,360)",
2.0 + Cos_Result_Err);
--pwb-math Y := Sin (Test_Data (I).Radians, 2.0*Pi);
--pwb-math Check (Y, Test_Data (I).Sine,
--pwb-math "test" & Integer'Image (I) & " sin(r,2pi)",
--pwb-math 2.0 + Sin_Result_Err);
--pwb-math Y := Cos (Test_Data (I).Radians, 2.0*Pi);
--pwb-math Check (Y, Test_Data (I).Cosine,
--pwb-math "test" & Integer'Image (I) & " cos(r,2pi)",
--pwb-math 2.0 + Cos_Result_Err);
end loop;
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in special angle test");
when others =>
Report.Failed ("exception in special angle test");
end Special_Angle_Checks;
 
 
-- check the rule of A.5.1(41);6.0 which requires that the
-- result be exact if the mathematical result is 0.0, 1.0,
-- or -1.0
procedure Exact_Result_Checks is
type Data_Point is
record
Degrees,
Sine,
Cosine : Real;
end record;
 
type Test_Data_Type is array (Positive range <>) of Data_Point;
Test_Data : constant Test_Data_Type := (
-- degrees sine cosine test #
( 0.0, 0.0, 1.0 ), -- 1
( 90.0, 1.0, 0.0 ), -- 2
(180.0, 0.0, -1.0 ), -- 3
(270.0, -1.0, 0.0 ), -- 4
(360.0, 0.0, 1.0 ), -- 5
( 90.0 + 360.0, 1.0, 0.0 ), -- 6
(180.0 + 360.0, 0.0, -1.0 ), -- 7
(270.0 + 360.0,-1.0, 0.0 ), -- 8
(360.0 + 360.0, 0.0, 1.0 ) ); -- 9
Y : Real;
begin
for I in Test_Data'Range loop
Y := Sin (Test_Data(I).Degrees, 360.0);
if Y /= Test_Data(I).Sine then
Report.Failed ("exact result for sin(" &
Real'Image (Test_Data(I).Degrees) &
", 360.0) is not" &
Real'Image (Test_Data(I).Sine) &
" Difference is " &
Real'Image (Y - Test_Data(I).Sine) );
end if;
 
Y := Cos (Test_Data(I).Degrees, 360.0);
if Y /= Test_Data(I).Cosine then
Report.Failed ("exact result for cos(" &
Real'Image (Test_Data(I).Degrees) &
", 360.0) is not" &
Real'Image (Test_Data(I).Cosine) &
" Difference is " &
Real'Image (Y - Test_Data(I).Cosine) );
end if;
end loop;
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in exact result check");
when others =>
Report.Failed ("exception in exact result check");
end Exact_Result_Checks;
 
 
procedure Do_Test is
begin
Special_Angle_Checks;
Sin_Check (0.0, Pi/2.0, "0..pi/2");
Sin_Check (6.0*Pi, 6.5*Pi, "6pi..6.5pi");
Cos_Check (7.0*Pi, 7.5*Pi, "7pi..7.5pi");
Exact_Result_Checks;
end Do_Test;
end Generic_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
package Float_Check is new Generic_Check (Float);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
package A_Long_Float_Check is new Generic_Check (A_Long_Float);
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
 
begin
Report.Test ("CXG2004",
"Check the accuracy of the sin and cos functions");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
Report.Result;
end CXG2004;
/cxg2005.a
0,0 → 1,204
-- CXG2005.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that floating point addition and multiplication
-- have the required accuracy.
--
-- TEST DESCRIPTION:
-- The check for the required precision is essentially a
-- check that a guard digit is used for the operations.
-- This test uses a generic package to check the addition
-- and multiplication results. The
-- generic package is instantiated with the standard FLOAT
-- type and a floating point type for the maximum number
-- of digits of precision.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
--
--
-- CHANGE HISTORY:
-- 14 FEB 96 SAIC Initial Release for 2.1
-- 16 SEP 99 RLB Repaired to avoid printing thousands of (almost)
-- identical failure messages.
--!
 
-- References:
--
-- Basic Concepts for Computational Software
-- W. J. Cody
-- Problems and Methodologies in Mathematical Software Production
-- editors P. C. Messina and A. Murli
-- Lecture Notes in Computer Science Vol 142
-- Springer Verlag, 1982
--
-- Software Manual for the Elementary Functions
-- William J. Cody and William Waite
-- Prentice-Hall, 1980
--
 
with System;
with Report;
procedure CXG2005 is
Verbose : constant Boolean := False;
 
generic
type Real is digits <>;
package Guard_Digit_Check is
procedure Do_Test;
end Guard_Digit_Check;
 
package body Guard_Digit_Check is
-- made global so that the compiler will be more likely
-- to keep the values in memory instead of in higher
-- precision registers.
X, Y, Z : Real;
OneX : Real;
Eps, BN : Real;
 
-- special constants - not declared as constants so that
-- the "stored" precision will be used instead of a "register"
-- precision.
Zero : Real := 0.0;
One : Real := 1.0;
Two : Real := 2.0;
 
Failure_Count : Natural := 0;
 
procedure Thwart_Optimization is
-- the purpose of this procedure is to reference the
-- global variables used by the test so
-- that the compiler is not likely to keep them in
-- a higher precision register for their entire lifetime.
begin
if Report.Ident_Bool (False) then
-- never executed
X := X + 5.0;
Y := Y + 6.0;
Z := Z + 1.0;
Eps := Eps + 2.0;
BN := BN + 2.0;
OneX := X + Y;
One := 12.34; Two := 56.78; Zero := 90.12;
end if;
end Thwart_Optimization;
 
 
procedure Addition_Test is
begin
for K in 1..10 loop
Eps := Real (K) * Real'Model_Epsilon;
for N in 1.. Real'Machine_EMax - 1 loop
BN := Real(Real'Machine_Radix) ** N;
X := (One + Eps) * BN;
Y := (One - Eps) * BN;
Z := X - Y; -- true value for Z is 2*Eps*BN
 
if Z /= Eps*BN + Eps*BN then
Report.Failed ("addition check failed. K=" &
Integer'Image (K) &
" N=" & Integer'Image (N) &
" difference=" & Real'Image (Z - 2.0*Eps*BN) &
" Eps*BN=" & Real'Image (Eps*BN) );
Failure_Count := Failure_Count + 1;
exit when Failure_Count > K*4; -- Avoid displaying dozens of messages.
end if;
end loop;
end loop;
exception
when others =>
Thwart_Optimization;
Report.Failed ("unexpected exception in addition test");
end Addition_Test;
 
 
procedure Multiplication_Test is
begin
X := Real (Real'Machine_Radix) ** (Real'Machine_EMax - 1);
OneX := One * X;
Thwart_Optimization;
if OneX /= X then
Report.Failed ("multiplication for large values");
end if;
 
X := Real (Real'Machine_Radix) ** (Real'Model_EMin + 1);
OneX := One * X;
Thwart_Optimization;
if OneX /= X then
Report.Failed ("multiplication for small values");
end if;
 
-- selection of "random" values between 1/radix and radix
Y := One / Real (Real'Machine_Radix);
Z := Real(Real'Machine_Radix) - One/Real(Real'Machine_Radix);
for I in 0..100 loop
X := Y + Real (I) / 100.0 * Z;
OneX := One * X;
Thwart_Optimization;
if OneX /= X then
Report.Failed ("multiplication for case" & Integer'Image (I));
exit when Failure_Count > 40+8; -- Avoid displaying dozens of messages.
end if;
end loop;
exception
when others =>
Thwart_Optimization;
Report.Failed ("unexpected exception in multiplication test");
end Multiplication_Test;
 
 
procedure Do_Test is
begin
Addition_Test;
Multiplication_Test;
end Do_Test;
end Guard_Digit_Check;
 
package Chk_Float is new Guard_Digit_Check (Float);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
package Chk_A_Long_Float is new Guard_Digit_Check (A_Long_Float);
begin
Report.Test ("CXG2005",
"Check the accuracy of floating point" &
" addition and multiplication");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
Chk_Float.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
Chk_A_Long_Float.Do_Test;
 
Report.Result;
end CXG2005;
/cxg2014.a
0,0 → 1,399
-- CXG2014.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the SINH and COSH functions return
-- results that are within the error bound allowed.
--
-- TEST DESCRIPTION:
-- This test consists of a generic package that is
-- instantiated to check both Float and a long float type.
-- The test for each floating point type is divided into
-- several parts:
-- Special value checks where the result is a known constant.
-- Checks that use an identity for determining the result.
-- Exception checks.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 15 Mar 96 SAIC Initial release for 2.1
-- 03 Jun 98 EDS In line 80, change 1000 to 1024, making it a model
-- number. Add Taylor Series terms in line 281.
-- 15 Feb 99 RLB Repaired Subtraction_Error_Test to avoid precision
-- problems.
--!
 
--
-- References:
--
-- Software Manual for the Elementary Functions
-- William J. Cody, Jr. and William Waite
-- Prentice-Hall, 1980
--
-- CRC Standard Mathematical Tables
-- 23rd Edition
--
-- Implementation and Testing of Function Software
-- W. J. Cody
-- Problems and Methodologies in Mathematical Software Production
-- editors P. C. Messina and A. Murli
-- Lecture Notes in Computer Science Volume 142
-- Springer Verlag, 1982
--
 
with System;
with Report;
with Ada.Numerics.Generic_Elementary_Functions;
procedure CXG2014 is
Verbose : constant Boolean := False;
Max_Samples : constant := 1024;
 
E : constant := Ada.Numerics.E;
Cosh1 : constant := (E + 1.0 / E) / 2.0; -- cosh(1.0)
 
generic
type Real is digits <>;
package Generic_Check is
procedure Do_Test;
end Generic_Check;
 
package body Generic_Check is
package Elementary_Functions is new
Ada.Numerics.Generic_Elementary_Functions (Real);
function Sinh (X : Real) return Real renames
Elementary_Functions.Sinh;
function Cosh (X : Real) return Real renames
Elementary_Functions.Cosh;
function Log (X : Real) return Real renames
Elementary_Functions.Log;
 
-- flag used to terminate some tests early
Accuracy_Error_Reported : Boolean := False;
 
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real) is
Max_Error : Real;
Rel_Error : Real;
Abs_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Small instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Small;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual - Expected) > Max_Error then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Special_Value_Test is
-- In the following tests the expected result is accurate
-- to the machine precision so the minimum guaranteed error
-- bound can be used.
Minimum_Error : constant := 8.0;
begin
Check (Sinh (1.0),
(E - 1.0 / E) / 2.0,
"sinh(1)",
Minimum_Error);
Check (Cosh (1.0),
Cosh1,
"cosh(1)",
Minimum_Error);
Check (Sinh (2.0),
(E * E - (1.0 / (E * E))) / 2.0,
"sinh(2)",
Minimum_Error);
Check (Cosh (2.0),
(E * E + (1.0 / (E * E))) / 2.0,
"cosh(2)",
Minimum_Error);
Check (Sinh (-1.0),
(1.0 / E - E) / 2.0,
"sinh(-1)",
Minimum_Error);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in special value test");
when others =>
Report.Failed ("exception in special value test");
end Special_Value_Test;
 
 
 
procedure Exact_Result_Test is
No_Error : constant := 0.0;
begin
-- A.5.1(38);6.0
Check (Sinh (0.0), 0.0, "sinh(0)", No_Error);
Check (Cosh (0.0), 1.0, "cosh(0)", No_Error);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in Exact_Result Test");
when others =>
Report.Failed ("exception in Exact_Result Test");
end Exact_Result_Test;
 
 
procedure Identity_1_Test is
-- For the Sinh test use the identity
-- 2 * Sinh(x) * Cosh(1) = Sinh(x+1) + Sinh (x-1)
-- which is transformed to
-- Sinh(x) = ((Sinh(x+1) + Sinh(x-1)) * C
-- where C = 1/(2*Cosh(1))
--
-- For the Cosh test use the identity
-- 2 * Cosh(x) * Cosh(1) = Cosh(x+1) + Cosh(x-1)
-- which is transformed to
-- Cosh(x) = C * (Cosh(x+1) + Cosh(x-1))
-- where C is the same as above
--
-- see Cody pg 230-231 for details on the error analysis.
-- The net result is a relative error bound of 16 * Model_Epsilon.
 
A : constant := 3.0;
-- large upper bound but not so large as to cause Cosh(B)
-- to overflow
B : constant Real := Log(Real'Safe_Last) - 2.0;
X_Minus_1, X, X_Plus_1 : Real;
Actual1, Actual2 : Real;
C : constant := 1.0 / (2.0 * Cosh1);
begin
Accuracy_Error_Reported := False; -- reset
for I in 1..Max_Samples loop
-- make sure there is no error in x-1, x, and x+1
X_Plus_1 := (B - A) * Real (I) / Real (Max_Samples) + A;
X_Plus_1 := Real'Machine (X_Plus_1);
X := Real'Machine (X_Plus_1 - 1.0);
X_Minus_1 := Real'Machine (X - 1.0);
-- Sinh(x) = ((Sinh(x+1) + Sinh(x-1)) * C
Actual1 := Sinh(X);
Actual2 := C * (Sinh(X_Plus_1) + Sinh(X_Minus_1));
Check (Actual1, Actual2,
"Identity_1_Test " & Integer'Image (I) & ": sinh(" &
Real'Image (X) & ") ",
16.0);
 
-- Cosh(x) = C * (Cosh(x+1) + Cosh(x-1))
Actual1 := Cosh (X);
Actual2 := C * (Cosh(X_Plus_1) + Cosh (X_Minus_1));
Check (Actual1, Actual2,
"Identity_1_Test " & Integer'Image (I) & ": cosh(" &
Real'Image (X) & ") ",
16.0);
 
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
 
end loop;
 
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Identity_1_Test" &
" for X=" & Real'Image (X));
when others =>
Report.Failed ("exception in Identity_1_Test" &
" for X=" & Real'Image (X));
end Identity_1_Test;
 
 
 
procedure Subtraction_Error_Test is
-- This test detects the error resulting from subtraction if
-- the obvious algorithm was used for computing sinh. That is,
-- it it is computed as (e**x - e**-x)/2.
-- We check the result by using a Taylor series expansion that
-- will produce a result accurate to the machine precision for
-- the range under test.
--
-- The maximum relative error bound for this test is
-- 8 for the sinh operation and 7 for the Taylor series
-- for a total of 15 * Model_Epsilon
A : constant := 0.0;
B : constant := 0.5;
X : Real;
X_Squared : Real;
Actual, Expected : Real;
begin
if Real'digits > 15 then
return; -- The approximation below is not accurate beyond
-- 15 digits. Adding more terms makes the error
-- larger, so it makes the test worse for more normal
-- values. Thus, we skip this subtest for larger than
-- 15 digits.
end if;
Accuracy_Error_Reported := False; -- reset
for I in 1..Max_Samples loop
X := (B - A) * Real (I) / Real (Max_Samples) + A;
X_Squared := X * X;
Actual := Sinh(X);
 
-- The Taylor series regrouped a bit
Expected :=
X * (1.0 + (X_Squared / 6.0) *
(1.0 + (X_Squared/20.0) *
(1.0 + (X_Squared/42.0) *
(1.0 + (X_Squared/72.0) *
(1.0 + (X_Squared/110.0) *
(1.0 + (X_Squared/156.0)
))))));
Check (Actual, Expected,
"Subtraction_Error_Test " & Integer'Image (I) & ": sinh(" &
Real'Image (X) & ") ",
15.0);
 
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
 
end loop;
 
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Subtraction_Error_Test");
when others =>
Report.Failed ("exception in Subtraction_Error_Test");
end Subtraction_Error_Test;
 
 
procedure Exception_Test is
X1, X2 : Real := 0.0;
begin
-- this part of the test is only applicable if 'Machine_Overflows
-- is true.
if Real'Machine_Overflows then
 
begin
X1 := Sinh (Real'Safe_Last / 2.0);
Report.Failed ("no exception for sinh overflow");
exception
when Constraint_Error => null;
when others =>
Report.Failed ("wrong exception sinh overflow");
end;
 
begin
X2 := Cosh (Real'Safe_Last / 2.0);
Report.Failed ("no exception for cosh overflow");
exception
when Constraint_Error => null;
when others =>
Report.Failed ("wrong exception cosh overflow");
end;
 
end if;
 
-- optimizer thwarting
if Report.Ident_Bool (False) then
Report.Comment (Real'Image (X1 + X2));
end if;
end Exception_Test;
 
 
procedure Do_Test is
begin
Special_Value_Test;
Exact_Result_Test;
Identity_1_Test;
Subtraction_Error_Test;
Exception_Test;
end Do_Test;
end Generic_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
package Float_Check is new Generic_Check (Float);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
package A_Long_Float_Check is new Generic_Check (A_Long_Float);
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
 
begin
Report.Test ("CXG2014",
"Check the accuracy of the SINH and COSH functions");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
 
Report.Result;
end CXG2014;
/cxg2023.a
0,0 → 1,351
-- CXG2023.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that multiplication and division of decimal fixed point
-- numbers produce exact results.
--
-- TEST DESCRIPTION:
-- Check that multiplication and division of decimal fixed point
-- numbers produce exact results.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
-- This test applies only to implementations supporting
-- decimal fixed point types of at least 9 digits.
--
--
-- CHANGE HISTORY:
-- 3 Apr 96 SAIC Initial release for 2.1
--
--!
 
with System;
with Report;
procedure CXG2023 is
Verbose : constant Boolean := False;
 
procedure Check_1 is
Num_Digits : constant := 6;
type Pennies is delta 0.01 digits Num_Digits;
type Franklins is delta 100.0 digits Num_Digits;
type Dollars is delta 1.0 digits Num_Digits;
 
P1 : Pennies;
F1 : Franklins;
D1 : Dollars;
 
-- optimization thwarting functions
 
function P (X : Pennies) return Pennies is
begin
if Report.Ident_Bool (True) then
return X;
else
return 3.21; -- never executed
end if;
end P;
 
 
function F (X : Franklins) return Franklins is
begin
if Report.Ident_Bool (True) then
return X;
else
return 32100.0; -- never executed
end if;
end F;
 
 
function D (X : Dollars) return Dollars is
begin
if Report.Ident_Bool (True) then
return X;
else
return 321.0; -- never executed
end if;
end D;
 
 
begin
-- multiplication where one operand is universal real
 
P1 := P(0.05) * 200.0;
if P1 /= 10.00 then
Report.Failed ("1 - expected 10.00 got " & Pennies'Image (P1));
end if;
 
D1 := P(0.05) * 100.0;
if D1 /= 5.00 then
Report.Failed ("2 - expected 5.00 got " & Dollars'Image (D1));
end if;
 
F1 := P(0.05) * 50_000.0;
if F1 /= 2500.00 then
Report.Failed ("3 - expected 2500.0 got " & Franklins'Image (F1));
end if;
 
-- multiplication where both operands are decimal fixed
 
P1 := P(0.05) * D(-200.0);
if P1 /= -10.00 then
Report.Failed ("4 - expected -10.00 got " & Pennies'Image (P1));
end if;
 
D1 := P(0.05) * P(-100.0);
if D1 /= -5.00 then
Report.Failed ("5 - expected -5.00 got " & Dollars'Image (D1));
end if;
 
F1 := P(-0.05) * F(50_000.0);
if F1 /= -2500.00 then
Report.Failed ("6 - expected -2500.0 got " & Franklins'Image (F1));
end if;
 
-- division where one operand is universal real
 
P1 := P(0.05) / 0.001;
if P1 /= 50.00 then
Report.Failed ("7 - expected 50.00 got " & Pennies'Image (P1));
end if;
 
D1 := D(1000.0) / 3.0;
if D1 /= 333.00 then
Report.Failed ("8 - expected 333.00 got " & Dollars'Image (D1));
end if;
 
F1 := P(1234.56) / 0.0001;
if F1 /= 12345600.00 then
Report.Failed ("9 - expected 12345600.0 got " & Franklins'Image (F1));
end if;
 
 
-- division where both operands are decimal fixed
 
P1 := P(0.05) / D(1.0);
if P1 /= 0.05 then
Report.Failed ("10 - expected 0.05 got " & Pennies'Image (P1));
end if;
 
-- check for truncation toward 0
D1 := P(-101.00) / P(2.0);
if D1 /= -50.00 then
Report.Failed ("11 - expected -50.00 got " & Dollars'Image (D1));
end if;
 
P1 := P(-102.03) / P(-0.5);
if P1 /= 204.06 then
Report.Failed ("12 - expected 204.06 got " & Pennies'Image (P1));
end if;
 
F1 := P(876.54) / P(0.03);
if F1 /= 29200.00 then
Report.Failed ("13 - expected 29200.0 got " & Franklins'Image (F1));
end if;
 
exception
when others =>
Report.Failed ("unexpected exception in Check_1");
end Check_1;
 
generic
type Pennies is delta<> digits<>;
type Dollars is delta<> digits<>;
type Franklins is delta<> digits<>;
procedure Generic_Check;
procedure Generic_Check is
 
-- the following code is copied directly from the
-- above procedure Check_1
 
P1 : Pennies;
F1 : Franklins;
D1 : Dollars;
 
-- optimization thwarting functions
 
function P (X : Pennies) return Pennies is
begin
if Report.Ident_Bool (True) then
return X;
else
return 3.21; -- never executed
end if;
end P;
 
 
function F (X : Franklins) return Franklins is
begin
if Report.Ident_Bool (True) then
return X;
else
return 32100.0; -- never executed
end if;
end F;
 
 
function D (X : Dollars) return Dollars is
begin
if Report.Ident_Bool (True) then
return X;
else
return 321.0; -- never executed
end if;
end D;
 
 
begin
-- multiplication where one operand is universal real
 
P1 := P(0.05) * 200.0;
if P1 /= 10.00 then
Report.Failed ("1 - expected 10.00 got " & Pennies'Image (P1));
end if;
 
D1 := P(0.05) * 100.0;
if D1 /= 5.00 then
Report.Failed ("2 - expected 5.00 got " & Dollars'Image (D1));
end if;
 
F1 := P(0.05) * 50_000.0;
if F1 /= 2500.00 then
Report.Failed ("3 - expected 2500.0 got " & Franklins'Image (F1));
end if;
 
-- multiplication where both operands are decimal fixed
 
P1 := P(0.05) * D(-200.0);
if P1 /= -10.00 then
Report.Failed ("4 - expected -10.00 got " & Pennies'Image (P1));
end if;
 
D1 := P(0.05) * P(-100.0);
if D1 /= -5.00 then
Report.Failed ("5 - expected -5.00 got " & Dollars'Image (D1));
end if;
 
F1 := P(-0.05) * F(50_000.0);
if F1 /= -2500.00 then
Report.Failed ("6 - expected -2500.0 got " & Franklins'Image (F1));
end if;
 
-- division where one operand is universal real
 
P1 := P(0.05) / 0.001;
if P1 /= 50.00 then
Report.Failed ("7 - expected 50.00 got " & Pennies'Image (P1));
end if;
 
D1 := D(1000.0) / 3.0;
if D1 /= 333.00 then
Report.Failed ("8 - expected 333.00 got " & Dollars'Image (D1));
end if;
 
F1 := P(1234.56) / 0.0001;
if F1 /= 12345600.00 then
Report.Failed ("9 - expected 12345600.0 got " & Franklins'Image (F1));
end if;
 
 
-- division where both operands are decimal fixed
 
P1 := P(0.05) / D(1.0);
if P1 /= 0.05 then
Report.Failed ("10 - expected 0.05 got " & Pennies'Image (P1));
end if;
 
-- check for truncation toward 0
D1 := P(-101.00) / P(2.0);
if D1 /= -50.00 then
Report.Failed ("11 - expected -50.00 got " & Dollars'Image (D1));
end if;
 
P1 := P(-102.03) / P(-0.5);
if P1 /= 204.06 then
Report.Failed ("12 - expected 204.06 got " & Pennies'Image (P1));
end if;
 
F1 := P(876.54) / P(0.03);
if F1 /= 29200.00 then
Report.Failed ("13 - expected 29200.0 got " & Franklins'Image (F1));
end if;
 
end Generic_Check;
 
 
procedure Check_G6 is
Num_Digits : constant := 6;
type Pennies is delta 0.01 digits Num_Digits;
type Franklins is delta 100.0 digits Num_Digits;
type Dollars is delta 1.0 digits Num_Digits;
 
procedure G is new Generic_Check (Pennies, Dollars, Franklins);
begin
G;
end Check_G6;
 
 
procedure Check_G9 is
Num_Digits : constant := 9;
type Pennies is delta 0.01 digits Num_Digits;
type Franklins is delta 100.0 digits Num_Digits;
type Dollars is delta 1.0 digits Num_Digits;
 
procedure G is new Generic_Check (Pennies, Dollars, Franklins);
begin
G;
end Check_G9;
 
 
begin -- main
Report.Test ("CXG2023",
"Check the accuracy of multiplication and division" &
" of decimal fixed point numbers");
 
if Verbose then
Report.Comment ("starting Check_1");
end if;
Check_1;
 
if Verbose then
Report.Comment ("starting Check_G6");
end if;
Check_G6;
 
if Verbose then
Report.Comment ("starting Check_G9");
end if;
Check_G9;
 
Report.Result;
end CXG2023;
/cxg2006.a
0,0 → 1,281
-- CXG2006.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the complex Argument function returns
-- results that are within the error bound allowed.
-- Check that Argument_Error is raised if the Cycle parameter
-- is less than or equal to zero.
--
-- TEST DESCRIPTION:
-- This test uses a generic package to compute and check the
-- values of the Argument function.
-- Of special interest is the case where either the real or
-- the imaginary part of the parameter is very large while the
-- other part is very small or 0.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 15 FEB 96 SAIC Initial release for 2.1
-- 03 MAR 97 PWB.CTA Removed checks involving explicit cycle => 2.0*Pi
--
-- CHANGE NOTE:
-- According to Ken Dritz, author of the Numerics Annex of the RM,
-- one should never specify the cycle 2.0*Pi for the trigonometric
-- functions. In particular, if the machine number for the first
-- argument is not an exact multiple of the machine number for the
-- explicit cycle, then the specified exact results cannot be
-- reasonably expected. The affected checks in this test have been
-- marked as comments, with the additional notation "pwb-math".
-- Phil Brashear
--!
 
--
-- Reference:
-- Problems and Methodologies in Mathematical Software Production;
-- editors: P. C. Messina and A Murli;
-- Lecture Notes in Computer Science
-- Volume 142
-- Springer Verlag 1982
--
 
with System;
with Report;
with ImpDef.Annex_G;
with Ada.Numerics;
with Ada.Numerics.Generic_Complex_Types;
with Ada.Numerics.Complex_Types;
procedure CXG2006 is
Verbose : constant Boolean := False;
 
 
-- CRC Standard Mathematical Tables; 23rd Edition; pg 738
Sqrt2 : constant :=
1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
Sqrt3 : constant :=
1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
 
Pi : constant := Ada.Numerics.Pi;
 
generic
type Real is digits <>;
package Generic_Check is
procedure Do_Test;
end Generic_Check;
 
package body Generic_Check is
package Complex_Types is new
Ada.Numerics.Generic_Complex_Types (Real);
use Complex_Types;
 
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real) is
Rel_Error : Real;
Abs_Error : Real;
Max_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual - Expected) > Max_Error then
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " &
Real'Image (Actual - Expected) &
" mre:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Special_Cases is
type Data_Point is
record
Re,
Im,
Radians,
Degrees,
Error_Bound : Real;
end record;
 
type Test_Data_Type is array (Positive range <>) of Data_Point;
 
-- the values in the following table only involve static
-- expressions to minimize errors in precision introduced by the
-- test. For cases where Pi is used in the argument we must
-- allow an extra 1.0*MRE to account for roundoff error in the
-- argument. Where the result involves a square root we allow
-- an extra 0.5*MRE to allow for roundoff error.
Test_Data : constant Test_Data_Type := (
-- Re Im Radians Degrees Err Test #
(0.0, 0.0, 0.0, 0.0, 4.0 ), -- 1
(1.0, 0.0, 0.0, 0.0, 4.0 ), -- 2
(Real'Safe_Last, 0.0, 0.0, 0.0, 4.0 ), -- 3
(Real'Model_Small, 0.0, 0.0, 0.0, 4.0 ), -- 4
(1.0, 1.0, Pi/4.0, 45.0, 5.0 ), -- 5
(1.0, -1.0, -Pi/4.0, -45.0, 5.0 ), -- 6
(-1.0, -1.0, -3.0*Pi/4.0,-135.0, 5.0 ), -- 7
(-1.0, 1.0, 3.0*Pi/4.0, 135.0, 5.0 ), -- 8
(Sqrt3, 1.0, Pi/6.0, 30.0, 5.5 ), -- 9
(-Sqrt3, 1.0, 5.0*Pi/6.0, 150.0, 5.5 ), -- 10
(Sqrt3, -1.0, -Pi/6.0, -30.0, 5.5 ), -- 11
(-Sqrt3, -1.0, -5.0*Pi/6.0,-150.0, 5.5 ), -- 12
(Real'Model_Small, Real'Model_Small, Pi/4.0, 45.0, 5.0 ), -- 13
(-Real'Safe_Last, 0.0, Pi, 180.0, 5.0 ), -- 14
(-Real'Safe_Last, -Real'Model_Small, -Pi,-180.0, 5.0 ), -- 15
(100000.0, 100000.0, Pi/4.0, 45.0, 5.0 )); -- 16
X : Real;
Z : Complex;
begin
for I in Test_Data'Range loop
begin
Z := (Test_Data(I).Re, Test_Data(I).Im);
X := Argument (Z);
Check (X, Test_Data(I).Radians,
"test" & Integer'Image (I) & " argument(z)",
Test_Data (I).Error_Bound);
--pwb-math X := Argument (Z, 2.0*Pi);
--pwb-math Check (X, Test_Data(I).Radians,
--pwb-math "test" & Integer'Image (I) & " argument(z, 2pi)",
--pwb-math Test_Data (I).Error_Bound);
X := Argument (Z, 360.0);
Check (X, Test_Data(I).Degrees,
"test" & Integer'Image (I) & " argument(z, 360)",
Test_Data (I).Error_Bound);
 
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test" &
Integer'Image (I));
when others =>
Report.Failed ("exception in test" &
Integer'Image (I));
end;
end loop;
if Real'Signed_Zeros then
begin
X := Argument ((-1.0, Real(ImpDef.Annex_G.Negative_Zero)));
Check (X, -Pi, "test of arg((-1,-0)", 4.0);
exception
when others =>
Report.Failed ("exception in signed zero test");
end;
end if;
end Special_Cases;
 
 
procedure Exception_Cases is
-- check that Argument_Error is raised if Cycle is <= 0
Z : Complex := (1.0, 1.0);
X : Real;
Y : Real;
begin
begin
X := Argument (Z, Cycle => 0.0);
Report.Failed ("no exception for cycle = 0.0");
exception
when Ada.Numerics.Argument_Error => null;
when others =>
Report.Failed ("wrong exception for cycle = 0.0");
end;
 
begin
Y := Argument (Z, Cycle => -3.0);
Report.Failed ("no exception for cycle < 0.0");
exception
when Ada.Numerics.Argument_Error => null;
when others =>
Report.Failed ("wrong exception for cycle < 0.0");
end;
 
if Report.Ident_Int (2) = 1 then
-- optimization thwarting code - never executed
Report.Failed("2=1" & Real'Image (X+Y));
end if;
end Exception_Cases;
 
 
procedure Do_Test is
begin
Special_Cases;
Exception_Cases;
end Do_Test;
end Generic_Check;
 
package Chk_Float is new Generic_Check (Float);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
package Chk_A_Long_Float is new Generic_Check (A_Long_Float);
begin
Report.Test ("CXG2006",
"Check the accuracy of the complex argument" &
" function");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Chk_Float.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
Chk_A_Long_Float.Do_Test;
 
Report.Result;
end CXG2006;
/cxg2015.a
0,0 → 1,686
-- CXG2015.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the ARCSIN and ARCCOS functions return
-- results that are within the error bound allowed.
--
-- TEST DESCRIPTION:
-- This test consists of a generic package that is
-- instantiated to check both Float and a long float type.
-- The test for each floating point type is divided into
-- several parts:
-- Special value checks where the result is a known constant.
-- Checks in a specific range where a Taylor series can be
-- used to compute an accurate result for comparison.
-- Exception checks.
-- The Taylor series tests are a direct translation of the
-- FORTRAN code found in the reference.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 18 Mar 96 SAIC Initial release for 2.1
-- 24 Apr 96 SAIC Fixed error bounds.
-- 17 Aug 96 SAIC Added reference information and improved
-- checking for machines with more than 23
-- digits of precision.
-- 03 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi
-- 22 Dec 99 RLB Added model range checking to "exact" results,
-- in order to avoid too strictly requiring a specific
-- result, and too weakly checking results.
--
-- CHANGE NOTE:
-- According to Ken Dritz, author of the Numerics Annex of the RM,
-- one should never specify the cycle 2.0*Pi for the trigonometric
-- functions. In particular, if the machine number for the first
-- argument is not an exact multiple of the machine number for the
-- explicit cycle, then the specified exact results cannot be
-- reasonably expected. The affected checks in this test have been
-- marked as comments, with the additional notation "pwb-math".
-- Phil Brashear
--!
 
--
-- References:
--
-- Software Manual for the Elementary Functions
-- William J. Cody, Jr. and William Waite
-- Prentice-Hall, 1980
--
-- CRC Standard Mathematical Tables
-- 23rd Edition
--
-- Implementation and Testing of Function Software
-- W. J. Cody
-- Problems and Methodologies in Mathematical Software Production
-- editors P. C. Messina and A. Murli
-- Lecture Notes in Computer Science Volume 142
-- Springer Verlag, 1982
--
-- CELEFUNT: A Portable Test Package for Complex Elementary Functions
-- ACM Collected Algorithms number 714
 
with System;
with Report;
with Ada.Numerics.Generic_Elementary_Functions;
procedure CXG2015 is
Verbose : constant Boolean := False;
Max_Samples : constant := 1000;
 
 
-- CRC Standard Mathematical Tables; 23rd Edition; pg 738
Sqrt2 : constant :=
1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
Sqrt3 : constant :=
1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
 
Pi : constant := Ada.Numerics.Pi;
 
-- relative error bound from G.2.4(7);6.0
Minimum_Error : constant := 4.0;
 
generic
type Real is digits <>;
Half_PI_Low : in Real; -- The machine number closest to, but not greater
-- than PI/2.0.
Half_PI_High : in Real;-- The machine number closest to, but not less
-- than PI/2.0.
PI_Low : in Real; -- The machine number closest to, but not greater
-- than PI.
PI_High : in Real; -- The machine number closest to, but not less
-- than PI.
package Generic_Check is
procedure Do_Test;
end Generic_Check;
 
package body Generic_Check is
package Elementary_Functions is new
Ada.Numerics.Generic_Elementary_Functions (Real);
 
function Arcsin (X : Real) return Real renames
Elementary_Functions.Arcsin;
function Arcsin (X, Cycle : Real) return Real renames
Elementary_Functions.Arcsin;
function Arccos (X : Real) return Real renames
Elementary_Functions.ArcCos;
function Arccos (X, Cycle : Real) return Real renames
Elementary_Functions.ArcCos;
 
-- needed for support
function Log (X, Base : Real) return Real renames
Elementary_Functions.Log;
 
-- flag used to terminate some tests early
Accuracy_Error_Reported : Boolean := False;
 
-- The following value is a lower bound on the accuracy
-- required. It is normally 0.0 so that the lower bound
-- is computed from Model_Epsilon. However, for tests
-- where the expected result is only known to a certain
-- amount of precision this bound takes on a non-zero
-- value to account for that level of precision.
Error_Low_Bound : Real := 0.0;
 
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real) is
Max_Error : Real;
Rel_Error : Real;
Abs_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
-- take into account the low bound on the error
if Max_Error < Error_Low_Bound then
Max_Error := Error_Low_Bound;
end if;
 
if abs (Actual - Expected) > Max_Error then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Special_Value_Test is
-- In the following tests the expected result is accurate
-- to the machine precision so the minimum guaranteed error
-- bound can be used.
 
type Data_Point is
record
Degrees,
Radians,
Argument,
Error_Bound : Real;
end record;
 
type Test_Data_Type is array (Positive range <>) of Data_Point;
 
-- the values in the following tables only involve static
-- expressions so no loss of precision occurs. However,
-- rounding can be an issue with expressions involving Pi
-- and square roots. The error bound specified in the
-- table takes the sqrt error into account but not the
-- error due to Pi. The Pi error is added in in the
-- radians test below.
 
Arcsin_Test_Data : constant Test_Data_Type := (
-- degrees radians sine error_bound test #
--( 0.0, 0.0, 0.0, 0.0 ), -- 1 - In Exact_Result_Test.
( 30.0, Pi/6.0, 0.5, 4.0 ), -- 2
( 60.0, Pi/3.0, Sqrt3/2.0, 5.0 ), -- 3
--( 90.0, Pi/2.0, 1.0, 4.0 ), -- 4 - In Exact_Result_Test.
--(-90.0, -Pi/2.0, -1.0, 4.0 ), -- 5 - In Exact_Result_Test.
(-60.0, -Pi/3.0, -Sqrt3/2.0, 5.0 ), -- 6
(-30.0, -Pi/6.0, -0.5, 4.0 ), -- 7
( 45.0, Pi/4.0, Sqrt2/2.0, 5.0 ), -- 8
(-45.0, -Pi/4.0, -Sqrt2/2.0, 5.0 ) ); -- 9
 
Arccos_Test_Data : constant Test_Data_Type := (
-- degrees radians cosine error_bound test #
--( 0.0, 0.0, 1.0, 0.0 ), -- 1 - In Exact_Result_Test.
( 30.0, Pi/6.0, Sqrt3/2.0, 5.0 ), -- 2
( 60.0, Pi/3.0, 0.5, 4.0 ), -- 3
--( 90.0, Pi/2.0, 0.0, 4.0 ), -- 4 - In Exact_Result_Test.
(120.0, 2.0*Pi/3.0, -0.5, 4.0 ), -- 5
(150.0, 5.0*Pi/6.0, -Sqrt3/2.0, 5.0 ), -- 6
--(180.0, Pi, -1.0, 4.0 ), -- 7 - In Exact_Result_Test.
( 45.0, Pi/4.0, Sqrt2/2.0, 5.0 ), -- 8
(135.0, 3.0*Pi/4.0, -Sqrt2/2.0, 5.0 ) ); -- 9
 
Cycle_Error,
Radian_Error : Real;
begin
for I in Arcsin_Test_Data'Range loop
 
-- note exact result requirements A.5.1(38);6.0 and
-- G.2.4(12);6.0
if Arcsin_Test_Data (I).Error_Bound = 0.0 then
Cycle_Error := 0.0;
Radian_Error := 0.0;
else
Cycle_Error := Arcsin_Test_Data (I).Error_Bound;
-- allow for rounding error in the specification of Pi
Radian_Error := Cycle_Error + 1.0;
end if;
 
Check (Arcsin (Arcsin_Test_Data (I).Argument),
Arcsin_Test_Data (I).Radians,
"test" & Integer'Image (I) &
" arcsin(" &
Real'Image (Arcsin_Test_Data (I).Argument) &
")",
Radian_Error);
--pwb-math Check (Arcsin (Arcsin_Test_Data (I).Argument, 2.0 * Pi),
--pwb-math Arcsin_Test_Data (I).Radians,
--pwb-math "test" & Integer'Image (I) &
--pwb-math " arcsin(" &
--pwb-math Real'Image (Arcsin_Test_Data (I).Argument) &
--pwb-math ", 2pi)",
--pwb-math Cycle_Error);
Check (Arcsin (Arcsin_Test_Data (I).Argument, 360.0),
Arcsin_Test_Data (I).Degrees,
"test" & Integer'Image (I) &
" arcsin(" &
Real'Image (Arcsin_Test_Data (I).Argument) &
", 360)",
Cycle_Error);
end loop;
 
 
for I in Arccos_Test_Data'Range loop
 
-- note exact result requirements A.5.1(39);6.0 and
-- G.2.4(12);6.0
if Arccos_Test_Data (I).Error_Bound = 0.0 then
Cycle_Error := 0.0;
Radian_Error := 0.0;
else
Cycle_Error := Arccos_Test_Data (I).Error_Bound;
-- allow for rounding error in the specification of Pi
Radian_Error := Cycle_Error + 1.0;
end if;
 
Check (Arccos (Arccos_Test_Data (I).Argument),
Arccos_Test_Data (I).Radians,
"test" & Integer'Image (I) &
" arccos(" &
Real'Image (Arccos_Test_Data (I).Argument) &
")",
Radian_Error);
--pwb-math Check (Arccos (Arccos_Test_Data (I).Argument, 2.0 * Pi),
--pwb-math Arccos_Test_Data (I).Radians,
--pwb-math "test" & Integer'Image (I) &
--pwb-math " arccos(" &
--pwb-math Real'Image (Arccos_Test_Data (I).Argument) &
--pwb-math ", 2pi)",
--pwb-math Cycle_Error);
Check (Arccos (Arccos_Test_Data (I).Argument, 360.0),
Arccos_Test_Data (I).Degrees,
"test" & Integer'Image (I) &
" arccos(" &
Real'Image (Arccos_Test_Data (I).Argument) &
", 360)",
Cycle_Error);
end loop;
 
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in special value test");
when others =>
Report.Failed ("exception in special value test");
end Special_Value_Test;
 
 
procedure Check_Exact (Actual, Expected_Low, Expected_High : Real;
Test_Name : String) is
-- If the expected result is not a model number, then Expected_Low is
-- the first machine number less than the (exact) expected
-- result, and Expected_High is the first machine number greater than
-- the (exact) expected result. If the expected result is a model
-- number, Expected_Low = Expected_High = the result.
Model_Expected_Low : Real := Expected_Low;
Model_Expected_High : Real := Expected_High;
begin
-- Calculate the first model number nearest to, but below (or equal)
-- to the expected result:
while Real'Model (Model_Expected_Low) /= Model_Expected_Low loop
-- Try the next machine number lower:
Model_Expected_Low := Real'Adjacent(Model_Expected_Low, 0.0);
end loop;
-- Calculate the first model number nearest to, but above (or equal)
-- to the expected result:
while Real'Model (Model_Expected_High) /= Model_Expected_High loop
-- Try the next machine number higher:
Model_Expected_High := Real'Adjacent(Model_Expected_High, 100.0);
end loop;
 
if Actual < Model_Expected_Low or Actual > Model_Expected_High then
Accuracy_Error_Reported := True;
if Actual < Model_Expected_Low then
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected low: " & Real'Image (Model_Expected_Low) &
" expected high: " & Real'Image (Model_Expected_High) &
" difference: " & Real'Image (Actual - Expected_Low));
else
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected low: " & Real'Image (Model_Expected_Low) &
" expected high: " & Real'Image (Model_Expected_High) &
" difference: " & Real'Image (Expected_High - Actual));
end if;
elsif Verbose then
Report.Comment (Test_Name & " passed");
end if;
end Check_Exact;
 
 
procedure Exact_Result_Test is
begin
-- A.5.1(38)
Check_Exact (Arcsin (0.0), 0.0, 0.0, "arcsin(0)");
Check_Exact (Arcsin (0.0, 45.0), 0.0, 0.0, "arcsin(0,45)");
 
-- A.5.1(39)
Check_Exact (Arccos (1.0), 0.0, 0.0, "arccos(1)");
Check_Exact (Arccos (1.0, 75.0), 0.0, 0.0, "arccos(1,75)");
 
-- G.2.4(11-13)
Check_Exact (Arcsin (1.0), Half_PI_Low, Half_PI_High, "arcsin(1)");
Check_Exact (Arcsin (1.0, 360.0), 90.0, 90.0, "arcsin(1,360)");
 
Check_Exact (Arcsin (-1.0), -Half_PI_High, -Half_PI_Low, "arcsin(-1)");
Check_Exact (Arcsin (-1.0, 360.0), -90.0, -90.0, "arcsin(-1,360)");
 
Check_Exact (Arccos (0.0), Half_PI_Low, Half_PI_High, "arccos(0)");
Check_Exact (Arccos (0.0, 360.0), 90.0, 90.0, "arccos(0,360)");
 
Check_Exact (Arccos (-1.0), PI_Low, PI_High, "arccos(-1)");
Check_Exact (Arccos (-1.0, 360.0), 180.0, 180.0, "arccos(-1,360)");
 
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in Exact_Result Test");
when others =>
Report.Failed ("Exception in Exact_Result Test");
end Exact_Result_Test;
 
 
procedure Arcsin_Taylor_Series_Test is
-- the following range is chosen so that the Taylor series
-- used will produce a result accurate to machine precision.
--
-- The following formula is used for the Taylor series:
-- TS(x) = x { 1 + (xsq/2) [ (1/3) + (3/4)xsq { (1/5) +
-- (5/6)xsq [ (1/7) + (7/8)xsq/9 ] } ] }
-- where xsq = x * x
--
A : constant := -0.125;
B : constant := 0.125;
X : Real;
Y, Y_Sq : Real;
Actual, Sum, Xm : Real;
-- terms in Taylor series
K : constant Integer := Integer (
Log (
Real (Real'Machine_Radix) ** Real'Machine_Mantissa,
10.0)) + 1;
begin
Accuracy_Error_Reported := False; -- reset
for I in 1..Max_Samples loop
-- make sure there is no error in x-1, x, and x+1
X := (B - A) * Real (I) / Real (Max_Samples) + A;
 
Y := X;
Y_Sq := Y * Y;
Sum := 0.0;
Xm := Real (K + K + 1);
for M in 1 .. K loop
Sum := Y_Sq * (Sum + 1.0/Xm);
Xm := Xm - 2.0;
Sum := Sum * (Xm /(Xm + 1.0));
end loop;
Sum := Sum * Y;
Actual := Y + Sum;
Sum := (Y - Actual) + Sum;
if not Real'Machine_Rounds then
Actual := Actual + (Sum + Sum);
end if;
 
Check (Actual, Arcsin (X),
"Taylor Series test" & Integer'Image (I) & ": arcsin(" &
Real'Image (X) & ") ",
Minimum_Error);
 
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
 
end loop;
 
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Arcsin_Taylor_Series_Test" &
" for X=" & Real'Image (X));
when others =>
Report.Failed ("exception in Arcsin_Taylor_Series_Test" &
" for X=" & Real'Image (X));
end Arcsin_Taylor_Series_Test;
 
 
 
procedure Arccos_Taylor_Series_Test is
-- the following range is chosen so that the Taylor series
-- used will produce a result accurate to machine precision.
--
-- The following formula is used for the Taylor series:
-- TS(x) = x { 1 + (xsq/2) [ (1/3) + (3/4)xsq { (1/5) +
-- (5/6)xsq [ (1/7) + (7/8)xsq/9 ] } ] }
-- arccos(x) = pi/2 - TS(x)
A : constant := -0.125;
B : constant := 0.125;
C1, C2 : Real;
X : Real;
Y, Y_Sq : Real;
Actual, Sum, Xm, S : Real;
-- terms in Taylor series
K : constant Integer := Integer (
Log (
Real (Real'Machine_Radix) ** Real'Machine_Mantissa,
10.0)) + 1;
begin
if Real'Digits > 23 then
-- constants in this section only accurate to 23 digits
Error_Low_Bound := 0.00000_00000_00000_00000_001;
Report.Comment ("arctan accuracy checked to 23 digits");
end if;
 
-- C1 + C2 equals Pi/2 accurate to 23 digits
if Real'Machine_Radix = 10 then
C1 := 1.57;
C2 := 7.9632679489661923132E-4;
else
C1 := 201.0 / 128.0;
C2 := 4.8382679489661923132E-4;
end if;
 
Accuracy_Error_Reported := False; -- reset
for I in 1..Max_Samples loop
-- make sure there is no error in x-1, x, and x+1
X := (B - A) * Real (I) / Real (Max_Samples) + A;
 
Y := X;
Y_Sq := Y * Y;
Sum := 0.0;
Xm := Real (K + K + 1);
for M in 1 .. K loop
Sum := Y_Sq * (Sum + 1.0/Xm);
Xm := Xm - 2.0;
Sum := Sum * (Xm /(Xm + 1.0));
end loop;
Sum := Sum * Y;
 
-- at this point we have arcsin(x).
-- We compute arccos(x) = pi/2 - arcsin(x).
-- The following code segment is translated directly from
-- the CELEFUNT FORTRAN implementation
 
S := C1 + C2;
Sum := ((C1 - S) + C2) - Sum;
Actual := S + Sum;
Sum := ((S - Actual) + Sum) - Y;
S := Actual;
Actual := S + Sum;
Sum := (S - Actual) + Sum;
 
if not Real'Machine_Rounds then
Actual := Actual + (Sum + Sum);
end if;
 
Check (Actual, Arccos (X),
"Taylor Series test" & Integer'Image (I) & ": arccos(" &
Real'Image (X) & ") ",
Minimum_Error);
 
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
exit when Accuracy_Error_Reported;
end loop;
Error_Low_Bound := 0.0; -- reset
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Arccos_Taylor_Series_Test" &
" for X=" & Real'Image (X));
when others =>
Report.Failed ("exception in Arccos_Taylor_Series_Test" &
" for X=" & Real'Image (X));
end Arccos_Taylor_Series_Test;
 
 
 
procedure Identity_Test is
-- test the identity arcsin(-x) = -arcsin(x)
-- range chosen to be most of the valid range of the argument.
A : constant := -0.999;
B : constant := 0.999;
X : Real;
begin
Accuracy_Error_Reported := False; -- reset
for I in 1..Max_Samples loop
-- make sure there is no error in x-1, x, and x+1
X := (B - A) * Real (I) / Real (Max_Samples) + A;
 
Check (Arcsin(-X), -Arcsin (X),
"Identity test" & Integer'Image (I) & ": arcsin(" &
Real'Image (X) & ") ",
8.0); -- 2 arcsin evaluations => twice the error bound
 
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
end loop;
end Identity_Test;
 
 
procedure Exception_Test is
X1, X2 : Real := 0.0;
begin
begin
X1 := Arcsin (1.1);
Report.Failed ("no exception for Arcsin (1.1)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error instead of " &
"Argument_Error for Arcsin (1.1)");
when Ada.Numerics.Argument_Error =>
null; -- expected result
when others =>
Report.Failed ("wrong exception for Arcsin(1.1)");
end;
 
begin
X2 := Arccos (-1.1);
Report.Failed ("no exception for Arccos (-1.1)");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error instead of " &
"Argument_Error for Arccos (-1.1)");
when Ada.Numerics.Argument_Error =>
null; -- expected result
when others =>
Report.Failed ("wrong exception for Arccos(-1.1)");
end;
 
 
-- optimizer thwarting
if Report.Ident_Bool (False) then
Report.Comment (Real'Image (X1 + X2));
end if;
end Exception_Test;
 
 
procedure Do_Test is
begin
Special_Value_Test;
Exact_Result_Test;
Arcsin_Taylor_Series_Test;
Arccos_Taylor_Series_Test;
Identity_Test;
Exception_Test;
end Do_Test;
end Generic_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
-- These expressions must be truly static, which is why we have to do them
-- outside of the generic, and we use the named numbers. Note that we know
-- that PI is not a machine number (it is irrational), and it should be
-- represented to more digits than supported by the target machine.
Float_Half_PI_Low : constant := Float'Adjacent(PI/2.0, 0.0);
Float_Half_PI_High : constant := Float'Adjacent(PI/2.0, 10.0);
Float_PI_Low : constant := Float'Adjacent(PI, 0.0);
Float_PI_High : constant := Float'Adjacent(PI, 10.0);
package Float_Check is new Generic_Check (Float,
Half_PI_Low => Float_Half_PI_Low,
Half_PI_High => Float_Half_PI_High,
PI_Low => Float_PI_Low,
PI_High => Float_PI_High);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
A_Long_Float_Half_PI_Low : constant := A_Long_Float'Adjacent(PI/2.0, 0.0);
A_Long_Float_Half_PI_High : constant := A_Long_Float'Adjacent(PI/2.0, 10.0);
A_Long_Float_PI_Low : constant := A_Long_Float'Adjacent(PI, 0.0);
A_Long_Float_PI_High : constant := A_Long_Float'Adjacent(PI, 10.0);
package A_Long_Float_Check is new Generic_Check (A_Long_Float,
Half_PI_Low => A_Long_Float_Half_PI_Low,
Half_PI_High => A_Long_Float_Half_PI_High,
PI_Low => A_Long_Float_PI_Low,
PI_High => A_Long_Float_PI_High);
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
 
begin
Report.Test ("CXG2015",
"Check the accuracy of the ARCSIN and ARCCOS functions");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
 
Report.Result;
end CXG2015;
/cxg2024.a
0,0 → 1,191
-- CXG2024.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that multiplication and division of decimal
-- and binary fixed point numbers that result in a
-- decimal fixed point type produce acceptable results.
--
-- TEST DESCRIPTION:
-- Multiplication and division of mixed binary and decimal
-- values are performed. Identity functions are used so
-- that the operands of the expressions will not be seen
-- as static by the compiler.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
-- This test applies only to implementations supporting
-- decimal fixed point types of at least 9 digits.
--
--
-- CHANGE HISTORY:
-- 4 Apr 96 SAIC Initial release for 2.1
-- 17 Aug 96 SAIC Removed checks for close results
--
--!
 
with System;
with Report;
procedure CXG2024 is
 
procedure Do_Check is
Num_Digits : constant := 9;
type Pennies is delta 0.01 digits Num_Digits;
type Dollars is delta 1.0 digits Num_Digits;
 
type Signed_Sixteenths is delta 0.0625
range -2.0 ** (System.Max_Mantissa-5) ..
2.0 ** (System.Max_Mantissa-5) - 1.0;
type Unsigned_Sixteenths is delta 0.0625
range 0.0 .. 2.0 ** (System.Max_Mantissa-4) - 1.0;
 
P1 : Pennies;
D1 : Dollars;
 
-- optimization thwarting functions
 
function P (X : Pennies) return Pennies is
begin
if Report.Ident_Bool (True) then
return X;
else
return 3.21; -- never executed
end if;
end P;
 
 
function D (X : Dollars) return Dollars is
begin
if Report.Ident_Bool (True) then
return X;
else
return 321.0; -- never executed
end if;
end D;
 
 
function US (X : Unsigned_Sixteenths) return Unsigned_Sixteenths is
begin
if Report.Ident_Bool (True) then
return X;
else
return 321.0; -- never executed
end if;
end US;
 
 
function SS (X : Signed_Sixteenths) return Signed_Sixteenths is
begin
if Report.Ident_Bool (True) then
return X;
else
return 321.0; -- never executed
end if;
end SS;
 
 
begin
 
P1 := P(0.05) * SS(-200.0);
if P1 /= -10.00 then
Report.Failed ("1 - expected -10.00 got " & Pennies'Image (P1));
end if;
 
D1 := P(0.05) * SS(-100.0);
if D1 /= -5.00 then
Report.Failed ("2 - expected -5.00 got " & Dollars'Image (D1));
end if;
 
P1 := P(0.05) * US(200.0);
if P1 /= 10.00 then
Report.Failed ("3 - expected 10.00 got " & Pennies'Image (P1));
end if;
 
D1 := P(-0.05) * US(100.0);
if D1 /= -5.00 then
Report.Failed ("4 - expected -5.00 got " & Dollars'Image (D1));
end if;
 
 
 
P1 := P(0.05) / US(1.0);
if P1 /= 0.05 then
Report.Failed ("6 - expected 0.05 got " & Pennies'Image (P1));
end if;
 
-- check rounding
 
D1 := Dollars'Round (Pennies (P(-101.00) / US(2.0)));
if D1 /= -51.00 then
Report.Failed ("11 - expected -51.00 got " & Dollars'Image (D1));
end if;
 
D1 := Dollars'Round (Pennies (P(101.00) / US(2.0)));
if D1 /= 51.00 then
Report.Failed ("12 - expected 51.00 got " & Dollars'Image (D1));
end if;
 
D1 := Dollars'Round (Pennies (SS(-101.00) / P(2.0)));
if D1 /= -51.00 then
Report.Failed ("13 - expected -51.00 got " & Dollars'Image (D1));
end if;
 
D1 := Dollars'Round (Pennies (US(101.00) / P(2.0)));
if D1 /= 51.00 then
Report.Failed ("14 - expected 51.00 got " & Dollars'Image (D1));
end if;
 
 
 
P1 := P(-102.03) / SS(-0.5);
if P1 /= 204.06 then
Report.Failed ("15 - expected 204.06 got " & Pennies'Image (P1));
end if;
 
 
exception
when others =>
Report.Failed ("unexpected exception in Do_Check");
end Do_Check;
 
 
begin -- main
Report.Test ("CXG2024",
"Check the accuracy of multiplication and division" &
" of mixed decimal and binary fixed point numbers");
 
Do_Check;
 
Report.Result;
end CXG2024;
/cxg2007.a
0,0 → 1,291
-- CXG2007.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the complex Compose_From_Polar function returns
-- results that are within the error bound allowed.
-- Check that Argument_Error is raised if the Cycle parameter
-- is less than or equal to zero.
--
-- TEST DESCRIPTION:
-- This test uses a generic package to compute and check the
-- values of the Compose_From_Polar function.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 23 FEB 96 SAIC Initial release for 2.1
-- 23 APR 96 SAIC Fixed error checking
-- 03 MAR 97 PWB.CTA Deleted checks with explicit Cycle => 2.0*Pi
--
-- CHANGE NOTE:
-- According to Ken Dritz, author of the Numerics Annex of the RM,
-- one should never specify the cycle 2.0*Pi for the trigonometric
-- functions. In particular, if the machine number for the first
-- argument is not an exact multiple of the machine number for the
-- explicit cycle, then the specified exact results cannot be
-- reasonably expected. The affected checks in this test have been
-- marked as comments, with the additional notation "pwb-math".
-- Phil Brashear
--!
 
with System;
with Report;
with Ada.Numerics;
with Ada.Numerics.Generic_Complex_Types;
procedure CXG2007 is
Verbose : constant Boolean := False;
 
 
-- CRC Standard Mathematical Tables; 23rd Edition; pg 738
Sqrt2 : constant :=
1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
Sqrt3 : constant :=
1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
 
Pi : constant := Ada.Numerics.Pi;
 
generic
type Real is digits <>;
package Generic_Check is
procedure Do_Test;
end Generic_Check;
 
package body Generic_Check is
package Complex_Types is new
Ada.Numerics.Generic_Complex_Types (Real);
use Complex_Types;
 
Maximum_Relative_Error : constant Real := 3.0;
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real;
Arg_Error : Real) is
-- Arg_Error is additional absolute error that is allowed beyond
-- the MRE to account for error in the result that can be
-- attributed to error in the arguments.
Max_Error : Real;
Rel_Error : Real;
Abs_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Small instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
Max_Error := Max_Error + Arg_Error;
 
if abs (Actual - Expected) > Max_Error then
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Check (Actual, Expected : Complex;
Test_Name : String;
MRE : Real;
Arg_Error : Real) is
-- Arg_Error is additional absolute error that is allowed beyond
-- the MRE to account for error in the result that can be
-- attributed to error in the arguments.
begin
Check (Actual.Re, Expected.Re,
Test_Name & " real part",
MRE, Arg_Error);
Check (Actual.Im, Expected.Im,
Test_Name & " imaginary part",
MRE, Arg_Error);
end Check;
 
 
procedure Special_Cases is
type Data_Point is
record
Re,
Im,
Modulus,
Radians,
Degrees,
Arg_Error : Real;
end record;
 
-- shorthand names for various constants
P4 : constant := Pi/4.0;
P6 : constant := Pi/6.0;
 
MER2 : constant Real := Real'Model_Epsilon * Sqrt2;
 
type Test_Data_Type is array (Positive range <>) of Data_Point;
 
-- the values in the following table only involve static
-- expressions so no loss of precision occurs.
Test_Data : constant Test_Data_Type := (
--Re Im Modulus Radians Degrees Arg_Err
( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ), -- 1
( 0.0, 0.0, 0.0, Pi, 180.0, 0.0 ), -- 2
( 1.0, 0.0, 1.0, 0.0, 0.0, 0.0 ), -- 3
(-1.0, 0.0, -1.0, 0.0, 0.0, 0.0 ), -- 4
( 1.0, 1.0, Sqrt2, P4, 45.0, MER2), -- 5
(-1.0, 1.0, -Sqrt2, -P4, -45.0, MER2), -- 6
( 1.0, -1.0, Sqrt2, -P4, -45.0, MER2), -- 7
(-1.0, -1.0, -Sqrt2, P4, 45.0, MER2), -- 8
(-1.0, -1.0, Sqrt2, -3.0*P4,-135.0, MER2), -- 9
(-1.0, 1.0, Sqrt2, 3.0*P4, 135.0, MER2), -- 10
( 1.0, -1.0, -Sqrt2, 3.0*P4, 135.0, MER2), -- 11
(-1.0, 0.0, 1.0, Pi, 180.0, 0.0 ), -- 12
( 1.0, 0.0, -1.0, Pi, 180.0, 0.0 ) ); -- 13
 
Z : Complex;
Exp : Complex;
begin
for I in Test_Data'Range loop
begin
Exp := (Test_Data (I).Re, Test_Data (I).Im);
 
Z := Compose_From_Polar (Test_Data (I).Modulus,
Test_Data (I).Radians);
Check (Z, Exp,
"test" & Integer'Image (I) & " compose_from_polar(m,r)",
Maximum_Relative_Error, Test_Data (I).Arg_Error);
 
--pwb-math Z := Compose_From_Polar (Test_Data (I).Modulus,
--pwb-math Test_Data (I).Radians,
--pwb-math 2.0*Pi);
--pwb-math Check (Z, Exp,
--pwb-math "test" & Integer'Image (I) & " compose_from_polar(m,r,2pi)",
--pwb-math Maximum_Relative_Error, Test_Data (I).Arg_Error);
 
Z := Compose_From_Polar (Test_Data (I).Modulus,
Test_Data (I).Degrees,
360.0);
Check (Z, Exp,
"test" & Integer'Image (I) & " compose_from_polar(m,d,360)",
Maximum_Relative_Error, Test_Data (I).Arg_Error);
 
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test" &
Integer'Image (I));
when others =>
Report.Failed ("exception in test" &
Integer'Image (I));
end;
end loop;
end Special_Cases;
 
 
procedure Exception_Cases is
-- check that Argument_Error is raised if Cycle is <= 0
Z : Complex;
W : Complex;
begin
begin
Z := Compose_From_Polar (3.0, 0.0, Cycle => 0.0);
Report.Failed ("no exception for cycle = 0.0");
exception
when Ada.Numerics.Argument_Error => null;
when others =>
Report.Failed ("wrong exception for cycle = 0.0");
end;
 
begin
W := Compose_From_Polar (6.0, 1.0, Cycle => -10.0);
Report.Failed ("no exception for cycle < 0.0");
exception
when Ada.Numerics.Argument_Error => null;
when others =>
Report.Failed ("wrong exception for cycle < 0.0");
end;
 
if Report.Ident_Int (1) = 2 then
-- not executed - used to make it appear that we use the
-- results of the above computation
Z := Z * W;
Report.Failed(Real'Image (Z.Re + Z.Im));
end if;
end Exception_Cases;
 
 
procedure Do_Test is
begin
Special_Cases;
Exception_Cases;
end Do_Test;
end Generic_Check;
 
package Chk_Float is new Generic_Check (Float);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
package Chk_A_Long_Float is new Generic_Check (A_Long_Float);
begin
Report.Test ("CXG2007",
"Check the accuracy of the Compose_From_Polar" &
" function");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
Chk_Float.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
Chk_A_Long_Float.Do_Test;
 
Report.Result;
end CXG2007;
/cxg2016.a
0,0 → 1,482
-- CXG2016.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the ARCTAN function returns a
-- result that is within the error bound allowed.
--
-- TEST DESCRIPTION:
-- This test consists of a generic package that is
-- instantiated to check both Float and a long float type.
-- The test for each floating point type is divided into
-- several parts:
-- Special value checks where the result is a known constant.
-- Exception checks.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 19 Mar 96 SAIC Initial release for 2.1
-- 30 APR 96 SAIC Fixed optimization issue
-- 17 AUG 96 SAIC Incorporated Reviewer's suggestions.
-- 12 OCT 96 SAIC Incorporated Reviewer's suggestions.
-- 02 DEC 97 EDS Remove procedure Identity_1_Test and calls to
-- procedure.
-- 29 JUN 98 EDS Replace -0.0 with call to ImpDef.Annex_G.Negative_Zero
-- 28 APR 99 RLB Replaced comma accidentally deleted in above change.
-- 15 DEC 99 RLB Added model range checking to "exact" results,
-- in order to avoid too strictly requiring a specific
-- result.
--!
 
--
-- References:
--
-- Software Manual for the Elementary Functions
-- William J. Cody, Jr. and William Waite
-- Prentice-Hall, 1980
--
-- CRC Standard Mathematical Tables
-- 23rd Edition
--
-- Implementation and Testing of Function Software
-- W. J. Cody
-- Problems and Methodologies in Mathematical Software Production
-- editors P. C. Messina and A. Murli
-- Lecture Notes in Computer Science Volume 142
-- Springer Verlag, 1982
--
 
with System;
with Report;
with Ada.Numerics.Generic_Elementary_Functions;
with Impdef.Annex_G;
procedure CXG2016 is
Verbose : constant Boolean := False;
Max_Samples : constant := 1000;
 
-- CRC Standard Mathematical Tables; 23rd Edition; pg 738
Sqrt2 : constant :=
1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
Sqrt3 : constant :=
1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
 
Pi : constant := Ada.Numerics.Pi;
 
generic
type Real is digits <>;
Half_PI_Low : in Real; -- The machine number closest to, but not greater
-- than PI/2.0.
Half_PI_High : in Real;-- The machine number closest to, but not less
-- than PI/2.0.
PI_Low : in Real; -- The machine number closest to, but not greater
-- than PI.
PI_High : in Real; -- The machine number closest to, but not less
-- than PI.
package Generic_Check is
procedure Do_Test;
end Generic_Check;
 
package body Generic_Check is
package Elementary_Functions is new
Ada.Numerics.Generic_Elementary_Functions (Real);
 
function Arctan (Y : Real;
X : Real := 1.0) return Real renames
Elementary_Functions.Arctan;
function Arctan (Y : Real;
X : Real := 1.0;
Cycle : Real) return Real renames
Elementary_Functions.Arctan;
 
-- flag used to terminate some tests early
Accuracy_Error_Reported : Boolean := False;
 
-- The following value is a lower bound on the accuracy
-- required. It is normally 0.0 so that the lower bound
-- is computed from Model_Epsilon. However, for tests
-- where the expected result is only known to a certain
-- amount of precision this bound takes on a non-zero
-- value to account for that level of precision.
Error_Low_Bound : Real := 0.0;
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real) is
Max_Error : Real;
Rel_Error : Real;
Abs_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon
-- instead of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
-- take into account the low bound on the error
if Max_Error < Error_Low_Bound then
Max_Error := Error_Low_Bound;
end if;
 
if abs (Actual - Expected) > Max_Error then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Special_Value_Test is
-- If eta is very small, arctan(x + eta) ~= arctan(x) + eta/(1+x*x).
--
-- For tests 4 and 5, there is an error of 4.0ME for arctan + an
-- additional error of 1.0ME because pi is not exact for a total of 5.0ME.
--
-- In test 3 there is the error for pi plus an additional error
-- of (1.0ME)/4 since sqrt3 is not exact, for a total of 5.25ME.
--
-- In test 2 there is the error for pi plus an additional error
-- of (3/4)(1.0ME) since sqrt3 is not exact, for a total of 5.75ME.
 
 
type Data_Point is
record
Degrees,
Radians,
Tangent,
Allowed_Error : Real;
end record;
 
type Test_Data_Type is array (Positive range <>) of Data_Point;
 
-- the values in the following table only involve static
-- expressions so no additional loss of precision occurs.
Test_Data : constant Test_Data_Type := (
-- degrees radians tangent error test #
( 0.0, 0.0, 0.0, 4.0 ), -- 1
( 30.0, Pi/6.0, Sqrt3/3.0, 5.75), -- 2
( 60.0, Pi/3.0, Sqrt3, 5.25), -- 3
( 45.0, Pi/4.0, 1.0, 5.0 ), -- 4
(-45.0, -Pi/4.0, -1.0, 5.0 ) ); -- 5
 
begin
for I in Test_Data'Range loop
Check (Arctan (Test_Data (I).Tangent),
Test_Data (I).Radians,
"special value test" & Integer'Image (I) &
" arctan(" &
Real'Image (Test_Data (I).Tangent) &
")",
Test_Data (I).Allowed_Error);
Check (Arctan (Test_Data (I).Tangent, Cycle => 360.0),
Test_Data (I).Degrees,
"special value test" & Integer'Image (I) &
" arctan(" &
Real'Image (Test_Data (I).Tangent) &
", cycle=>360)",
Test_Data (I).Allowed_Error);
end loop;
 
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in special value test");
when others =>
Report.Failed ("exception in special value test");
end Special_Value_Test;
 
 
 
procedure Check_Exact (Actual, Expected_Low, Expected_High : Real;
Test_Name : String) is
-- If the expected result is not a model number, then Expected_Low is
-- the first machine number less than the (exact) expected
-- result, and Expected_High is the first machine number greater than
-- the (exact) expected result. If the expected result is a model
-- number, Expected_Low = Expected_High = the result.
Model_Expected_Low : Real := Expected_Low;
Model_Expected_High : Real := Expected_High;
begin
-- Calculate the first model number nearest to, but below (or equal)
-- to the expected result:
while Real'Model (Model_Expected_Low) /= Model_Expected_Low loop
-- Try the next machine number lower:
Model_Expected_Low := Real'Adjacent(Model_Expected_Low, 0.0);
end loop;
-- Calculate the first model number nearest to, but above (or equal)
-- to the expected result:
while Real'Model (Model_Expected_High) /= Model_Expected_High loop
-- Try the next machine number higher:
Model_Expected_High := Real'Adjacent(Model_Expected_High, 100.0);
end loop;
 
if Actual < Model_Expected_Low or Actual > Model_Expected_High then
Accuracy_Error_Reported := True;
if Actual < Model_Expected_Low then
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected low: " & Real'Image (Model_Expected_Low) &
" expected high: " & Real'Image (Model_Expected_High) &
" difference: " & Real'Image (Actual - Expected_Low));
else
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected low: " & Real'Image (Model_Expected_Low) &
" expected high: " & Real'Image (Model_Expected_High) &
" difference: " & Real'Image (Expected_High - Actual));
end if;
elsif Verbose then
Report.Comment (Test_Name & " passed");
end if;
end Check_Exact;
 
 
procedure Exact_Result_Test is
begin
-- A.5.1(40);6.0
Check_Exact (Arctan (0.0, 1.0), 0.0, 0.0, "arctan(0,1)");
Check_Exact (Arctan (0.0, 1.0, 27.0), 0.0, 0.0, "arctan(0,1,27)");
 
-- G.2.4(11-13);6.0
 
Check_Exact (Arctan (1.0, 0.0), Half_PI_Low, Half_PI_High,
"arctan(1,0)");
Check_Exact (Arctan (1.0, 0.0, 360.0), 90.0, 90.0, "arctan(1,0,360)");
 
Check_Exact (Arctan (-1.0, 0.0), -Half_PI_High, -Half_PI_Low,
"arctan(-1,0)");
Check_Exact (Arctan (-1.0, 0.0, 360.0), -90.0, -90.0,
"arctan(-1,0,360)");
 
if Real'Signed_Zeros then
Check_Exact (Arctan (0.0, -1.0), PI_Low, PI_High, "arctan(+0,-1)");
Check_Exact (Arctan (0.0, -1.0, 360.0), 180.0, 180.0,
"arctan(+0,-1,360)");
Check_Exact (Arctan ( Real ( ImpDef.Annex_G.Negative_Zero ), -1.0),
-PI_High, -PI_Low, "arctan(-0,-1)");
Check_Exact (Arctan ( Real ( ImpDef.Annex_G.Negative_Zero ), -1.0,
360.0), -180.0, -180.0, "arctan(-0,-1,360)");
else
Check_Exact (Arctan (0.0, -1.0), PI_Low, PI_High, "arctan(0,-1)");
Check_Exact (Arctan (0.0, -1.0, 360.0), 180.0, 180.0,
"arctan(0,-1,360)");
end if;
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in Exact_Result Test");
when others =>
Report.Failed ("Exception in Exact_Result Test");
end Exact_Result_Test;
 
 
procedure Taylor_Series_Test is
-- This test checks the Arctan by using a taylor series expansion that
-- will produce a result accurate to 19 decimal digits for
-- the range under test.
--
-- The maximum relative error bound for this test is
-- 4 for the arctan operation and 2 for the Taylor series
-- for a total of 6 * Model_Epsilon
 
A : constant := -1.0/16.0;
B : constant := 1.0/16.0;
X : Real;
Actual, Expected : Real;
Sum, Em, X_Squared : Real;
begin
if Real'Digits > 19 then
-- Taylor series calculation produces result accurate to 19
-- digits. If type being tested has more digits then set
-- the error low bound to account for this.
-- The error low bound is conservatively set to 6*10**-19
Error_Low_Bound := 0.00000_00000_00000_0006;
Report.Comment ("arctan accuracy checked to 19 digits");
end if;
 
Accuracy_Error_Reported := False; -- reset
for I in 0..Max_Samples loop
X := (B - A) * Real (I) / Real (Max_Samples) + A;
X_Squared := X * X;
Em := 17.0;
Sum := X_Squared / Em;
 
for II in 1 .. 7 loop
Em := Em - 2.0;
Sum := (1.0 / Em - Sum) * X_Squared;
end loop;
Sum := -X * Sum;
Expected := X + Sum;
Sum := (X - Expected) + Sum;
if not Real'Machine_Rounds then
Expected := Expected + (Sum + Sum);
end if;
 
Actual := Arctan (X);
 
Check (Actual, Expected,
"Taylor_Series_Test " & Integer'Image (I) & ": arctan(" &
Real'Image (X) & ") ",
6.0);
 
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
 
end loop;
Error_Low_Bound := 0.0; -- reset
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Taylor_Series_Test");
when others =>
Report.Failed ("exception in Taylor_Series_Test");
end Taylor_Series_Test;
 
 
procedure Exception_Test is
X1, X2, X3 : Real := 0.0;
begin
 
begin -- A.5.1(20);6.0
X1 := Arctan(0.0, Cycle => 0.0);
Report.Failed ("no exception for cycle = 0.0");
exception
when Ada.Numerics.Argument_Error => null;
when others =>
Report.Failed ("wrong exception for cycle = 0.0");
end;
 
begin -- A.5.1(20);6.0
X2 := Arctan (0.0, Cycle => -1.0);
Report.Failed ("no exception for cycle < 0.0");
exception
when Ada.Numerics.Argument_Error => null;
when others =>
Report.Failed ("wrong exception for cycle < 0.0");
end;
 
begin -- A.5.1(25);6.0
X3 := Arctan (0.0, 0.0);
Report.Failed ("no exception for arctan(0,0)");
exception
when Ada.Numerics.Argument_Error => null;
when others =>
Report.Failed ("wrong exception for arctan(0,0)");
end;
 
-- optimizer thwarting
if Report.Ident_Bool (False) then
Report.Comment (Real'Image (X1 + X2 + X3));
end if;
end Exception_Test;
 
 
procedure Do_Test is
begin
Special_Value_Test;
Exact_Result_Test;
Taylor_Series_Test;
Exception_Test;
end Do_Test;
end Generic_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
-- These expressions must be truly static, which is why we have to do them
-- outside of the generic, and we use the named numbers. Note that we know
-- that PI is not a machine number (it is irrational), and it should be
-- represented to more digits than supported by the target machine.
Float_Half_PI_Low : constant := Float'Adjacent(PI/2.0, 0.0);
Float_Half_PI_High : constant := Float'Adjacent(PI/2.0, 10.0);
Float_PI_Low : constant := Float'Adjacent(PI, 0.0);
Float_PI_High : constant := Float'Adjacent(PI, 10.0);
package Float_Check is new Generic_Check (Float,
Half_PI_Low => Float_Half_PI_Low,
Half_PI_High => Float_Half_PI_High,
PI_Low => Float_PI_Low,
PI_High => Float_PI_High);
 
-- check the Floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
A_Long_Float_Half_PI_Low : constant := A_Long_Float'Adjacent(PI/2.0, 0.0);
A_Long_Float_Half_PI_High : constant := A_Long_Float'Adjacent(PI/2.0, 10.0);
A_Long_Float_PI_Low : constant := A_Long_Float'Adjacent(PI, 0.0);
A_Long_Float_PI_High : constant := A_Long_Float'Adjacent(PI, 10.0);
package A_Long_Float_Check is new Generic_Check (A_Long_Float,
Half_PI_Low => A_Long_Float_Half_PI_Low,
Half_PI_High => A_Long_Float_Half_PI_High,
PI_Low => A_Long_Float_PI_Low,
PI_High => A_Long_Float_PI_High);
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
 
begin
Report.Test ("CXG2016",
"Check the accuracy of the ARCTAN function");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
 
Report.Result;
end CXG2016;
/cxg2008.a
0,0 → 1,948
-- CXG2008.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the complex multiplication and division
-- operations return results that are within the allowed
-- error bound.
-- Check that all the required pure Numerics packages are pure.
--
-- TEST DESCRIPTION:
-- This test contains three test packages that are almost
-- identical. The first two packages differ only in the
-- floating point type that is being tested. The first
-- and third package differ only in whether the generic
-- complex types package or the pre-instantiated
-- package is used.
-- The test package is not generic so that the arguments
-- and expected results for some of the test values
-- can be expressed as universal real instead of being
-- computed at runtime.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 24 FEB 96 SAIC Initial release for 2.1
-- 03 JUN 98 EDS Correct the test program's incorrect assumption
-- that Constraint_Error must be raised by complex
-- division by zero, which is contrary to the
-- allowance given by the Ada 95 standard G.1.1(40).
-- 13 MAR 01 RLB Replaced commented out Pure check on non-generic
-- packages, as required by Defect Report
-- 8652/0020 and as reflected in Technical
-- Corrigendum 1.
--!
 
------------------------------------------------------------------------------
-- Check that the required pure packages are pure by withing them from a
-- pure package. The non-generic versions of those packages are required to
-- be pure by Defect Report 8652/0020, Technical Corrigendum 1 [A.5.1(9/1) and
-- G.1.1(25/1)].
with Ada.Numerics.Generic_Elementary_Functions;
with Ada.Numerics.Elementary_Functions;
with Ada.Numerics.Generic_Complex_Types;
with Ada.Numerics.Complex_Types;
with Ada.Numerics.Generic_Complex_Elementary_Functions;
with Ada.Numerics.Complex_Elementary_Functions;
package CXG2008_0 is
pragma Pure;
-- CRC Standard Mathematical Tables; 23rd Edition; pg 738
Sqrt2 : constant :=
1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
Sqrt3 : constant :=
1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
end CXG2008_0;
 
------------------------------------------------------------------------------
 
with System;
with Report;
with Ada.Numerics.Generic_Complex_Types;
with Ada.Numerics.Complex_Types;
with CXG2008_0; use CXG2008_0;
procedure CXG2008 is
Verbose : constant Boolean := False;
 
package Float_Check is
subtype Real is Float;
procedure Do_Test;
end Float_Check;
 
package body Float_Check is
package Complex_Types is new
Ada.Numerics.Generic_Complex_Types (Real);
use Complex_Types;
 
-- keep track if an accuracy failure has occurred so the test
-- can be short-circuited to avoid thousands of error messages.
Failure_Detected : Boolean := False;
 
Mult_MBE : constant Real := 5.0;
Divide_MBE : constant Real := 13.0;
 
 
procedure Check (Actual, Expected : Complex;
Test_Name : String;
MBE : Real) is
Rel_Error : Real;
Abs_Error : Real;
Max_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon instead
-- of Model_Epsilon and Expected.
Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon;
Abs_Error := MBE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual.Re - Expected.Re) > Max_Error then
Failure_Detected := True;
Report.Failed (Test_Name &
" actual.re: " & Real'Image (Actual.Re) &
" expected.re: " & Real'Image (Expected.Re) &
" difference.re " &
Real'Image (Actual.Re - Expected.Re) &
" mre:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result for real part");
else
Report.Comment (Test_Name & " passed for real part");
end if;
end if;
 
Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
if abs (Actual.Im - Expected.Im) > Max_Error then
Failure_Detected := True;
Report.Failed (Test_Name &
" actual.im: " & Real'Image (Actual.Im) &
" expected.im: " & Real'Image (Expected.Im) &
" difference.im " &
Real'Image (Actual.Im - Expected.Im) &
" mre:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result for imaginary part");
else
Report.Comment (Test_Name & " passed for imaginary part");
end if;
end if;
end Check;
 
 
procedure Special_Values is
begin
 
--- test 1 ---
declare
T : constant := (Real'Machine_EMax - 1) / 2;
Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
Expected : Complex := (0.0, 0.0);
X : Complex := (0.0, 0.0);
Y : Complex := (Big, Big);
Z : Complex;
begin
Z := X * Y;
Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)",
Mult_MBE);
Z := Y * X;
Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)",
Mult_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 1");
when others =>
Report.Failed ("exception in test 1");
end;
 
--- test 2 ---
declare
T : constant := Real'Model_EMin + 1;
Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
U : Complex := (Tiny, Tiny);
X : Complex := (0.0, 0.0);
Expected : Complex := (0.0, 0.0);
Z : Complex;
begin
Z := U * X;
Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)",
Mult_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 2");
when others =>
Report.Failed ("exception in test 2");
end;
 
--- test 3 ---
declare
T : constant := (Real'Machine_EMax - 1) / 2;
Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
B : Complex := (Big, Big);
X : Complex := (0.0, 0.0);
Z : Complex;
begin
if Real'Machine_Overflows then
Z := B / X;
Report.Failed ("test 3 - Constraint_Error not raised");
Check (Z, Z, "not executed - optimizer thwarting", 0.0);
end if;
exception
when Constraint_Error => null; -- expected
when others =>
Report.Failed ("exception in test 3");
end;
 
--- test 4 ---
declare
T : constant := Real'Model_EMin + 1;
Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
U : Complex := (Tiny, Tiny);
X : Complex := (0.0, 0.0);
Z : Complex;
begin
if Real'Machine_Overflows then
Z := U / X;
Report.Failed ("test 4 - Constraint_Error not raised");
Check (Z, Z, "not executed - optimizer thwarting", 0.0);
end if;
exception
when Constraint_Error => null; -- expected
when others =>
Report.Failed ("exception in test 4");
end;
 
 
--- test 5 ---
declare
X : Complex := (Sqrt2, Sqrt2);
Z : Complex;
Expected : constant Complex := (0.0, 4.0);
begin
Z := X * X;
Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)",
Mult_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 5");
when others =>
Report.Failed ("exception in test 5");
end;
 
--- test 6 ---
declare
X : Complex := Sqrt3 - Sqrt3 * i;
Z : Complex;
Expected : constant Complex := (0.0, -6.0);
begin
Z := X * X;
Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)",
Mult_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 6");
when others =>
Report.Failed ("exception in test 6");
end;
 
--- test 7 ---
declare
X : Complex := Sqrt2 + Sqrt2 * i;
Y : Complex := Sqrt2 - Sqrt2 * i;
Z : Complex;
Expected : constant Complex := 0.0 + i;
begin
Z := X / Y;
Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)",
Divide_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 7");
when others =>
Report.Failed ("exception in test 7");
end;
end Special_Values;
 
 
procedure Do_Mult_Div (X, Y : Complex) is
Z : Complex;
Args : constant String :=
"X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " &
"Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ;
begin
Z := (X * X) / X;
Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE);
Z := (X * Y) / X;
Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE);
Z := (X * Y) / Y;
Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args);
when others =>
Report.Failed ("exception in Do_Mult_Div for " & Args);
end Do_Mult_Div;
 
-- select complex values X and Y where the real and imaginary
-- parts are selected from the ranges (1/radix..1) and
-- (1..radix). This translates into quite a few combinations.
procedure Mult_Div_Check is
Samples : constant := 17;
Radix : constant Real := Real(Real'Machine_Radix);
Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix);
Low_Sample : Real; -- (1/radix .. 1)
High_Sample : Real; -- (1 .. radix)
Sample : array (1..2) of Real;
X, Y : Complex;
begin
for I in 1 .. Samples loop
Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) +
Inv_Radix;
Sample (1) := Low_Sample;
for J in 1 .. Samples loop
High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) +
Radix;
Sample (2) := High_Sample;
for K in 1 .. 2 loop
for L in 1 .. 2 loop
X := Complex'(Sample (K), Sample (L));
Y := Complex'(Sample (L), Sample (K));
Do_Mult_Div (X, Y);
if Failure_Detected then
return; -- minimize flood of error messages
end if;
end loop;
end loop;
end loop; -- J
end loop; -- I
end Mult_Div_Check;
 
 
procedure Do_Test is
begin
Special_Values;
Mult_Div_Check;
end Do_Test;
end Float_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
-- check the floating point type with the most digits
 
package A_Long_Float_Check is
type A_Long_Float is digits System.Max_Digits;
subtype Real is A_Long_Float;
procedure Do_Test;
end A_Long_Float_Check;
 
package body A_Long_Float_Check is
 
package Complex_Types is new
Ada.Numerics.Generic_Complex_Types (Real);
use Complex_Types;
 
-- keep track if an accuracy failure has occurred so the test
-- can be short-circuited to avoid thousands of error messages.
Failure_Detected : Boolean := False;
 
Mult_MBE : constant Real := 5.0;
Divide_MBE : constant Real := 13.0;
 
 
procedure Check (Actual, Expected : Complex;
Test_Name : String;
MBE : Real) is
Rel_Error : Real;
Abs_Error : Real;
Max_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon instead
-- of Model_Epsilon and Expected.
Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon;
Abs_Error := MBE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual.Re - Expected.Re) > Max_Error then
Failure_Detected := True;
Report.Failed (Test_Name &
" actual.re: " & Real'Image (Actual.Re) &
" expected.re: " & Real'Image (Expected.Re) &
" difference.re " &
Real'Image (Actual.Re - Expected.Re) &
" mre:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result for real part");
else
Report.Comment (Test_Name & " passed for real part");
end if;
end if;
 
Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
if abs (Actual.Im - Expected.Im) > Max_Error then
Failure_Detected := True;
Report.Failed (Test_Name &
" actual.im: " & Real'Image (Actual.Im) &
" expected.im: " & Real'Image (Expected.Im) &
" difference.im " &
Real'Image (Actual.Im - Expected.Im) &
" mre:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result for imaginary part");
else
Report.Comment (Test_Name & " passed for imaginary part");
end if;
end if;
end Check;
 
 
procedure Special_Values is
begin
 
--- test 1 ---
declare
T : constant := (Real'Machine_EMax - 1) / 2;
Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
Expected : Complex := (0.0, 0.0);
X : Complex := (0.0, 0.0);
Y : Complex := (Big, Big);
Z : Complex;
begin
Z := X * Y;
Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)",
Mult_MBE);
Z := Y * X;
Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)",
Mult_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 1");
when others =>
Report.Failed ("exception in test 1");
end;
 
--- test 2 ---
declare
T : constant := Real'Model_EMin + 1;
Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
U : Complex := (Tiny, Tiny);
X : Complex := (0.0, 0.0);
Expected : Complex := (0.0, 0.0);
Z : Complex;
begin
Z := U * X;
Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)",
Mult_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 2");
when others =>
Report.Failed ("exception in test 2");
end;
 
--- test 3 ---
declare
T : constant := (Real'Machine_EMax - 1) / 2;
Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
B : Complex := (Big, Big);
X : Complex := (0.0, 0.0);
Z : Complex;
begin
if Real'Machine_Overflows then
Z := B / X;
Report.Failed ("test 3 - Constraint_Error not raised");
Check (Z, Z, "not executed - optimizer thwarting", 0.0);
end if;
exception
when Constraint_Error => null; -- expected
when others =>
Report.Failed ("exception in test 3");
end;
 
--- test 4 ---
declare
T : constant := Real'Model_EMin + 1;
Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
U : Complex := (Tiny, Tiny);
X : Complex := (0.0, 0.0);
Z : Complex;
begin
if Real'Machine_Overflows then
Z := U / X;
Report.Failed ("test 4 - Constraint_Error not raised");
Check (Z, Z, "not executed - optimizer thwarting", 0.0);
end if;
exception
when Constraint_Error => null; -- expected
when others =>
Report.Failed ("exception in test 4");
end;
 
 
--- test 5 ---
declare
X : Complex := (Sqrt2, Sqrt2);
Z : Complex;
Expected : constant Complex := (0.0, 4.0);
begin
Z := X * X;
Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)",
Mult_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 5");
when others =>
Report.Failed ("exception in test 5");
end;
 
--- test 6 ---
declare
X : Complex := Sqrt3 - Sqrt3 * i;
Z : Complex;
Expected : constant Complex := (0.0, -6.0);
begin
Z := X * X;
Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)",
Mult_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 6");
when others =>
Report.Failed ("exception in test 6");
end;
 
--- test 7 ---
declare
X : Complex := Sqrt2 + Sqrt2 * i;
Y : Complex := Sqrt2 - Sqrt2 * i;
Z : Complex;
Expected : constant Complex := 0.0 + i;
begin
Z := X / Y;
Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)",
Divide_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 7");
when others =>
Report.Failed ("exception in test 7");
end;
end Special_Values;
 
 
procedure Do_Mult_Div (X, Y : Complex) is
Z : Complex;
Args : constant String :=
"X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " &
"Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ;
begin
Z := (X * X) / X;
Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE);
Z := (X * Y) / X;
Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE);
Z := (X * Y) / Y;
Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args);
when others =>
Report.Failed ("exception in Do_Mult_Div for " & Args);
end Do_Mult_Div;
 
-- select complex values X and Y where the real and imaginary
-- parts are selected from the ranges (1/radix..1) and
-- (1..radix). This translates into quite a few combinations.
procedure Mult_Div_Check is
Samples : constant := 17;
Radix : constant Real := Real(Real'Machine_Radix);
Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix);
Low_Sample : Real; -- (1/radix .. 1)
High_Sample : Real; -- (1 .. radix)
Sample : array (1..2) of Real;
X, Y : Complex;
begin
for I in 1 .. Samples loop
Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) +
Inv_Radix;
Sample (1) := Low_Sample;
for J in 1 .. Samples loop
High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) +
Radix;
Sample (2) := High_Sample;
for K in 1 .. 2 loop
for L in 1 .. 2 loop
X := Complex'(Sample (K), Sample (L));
Y := Complex'(Sample (L), Sample (K));
Do_Mult_Div (X, Y);
if Failure_Detected then
return; -- minimize flood of error messages
end if;
end loop;
end loop;
end loop; -- J
end loop; -- I
end Mult_Div_Check;
 
 
procedure Do_Test is
begin
Special_Values;
Mult_Div_Check;
end Do_Test;
end A_Long_Float_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
package Non_Generic_Check is
subtype Real is Float;
procedure Do_Test;
end Non_Generic_Check;
 
package body Non_Generic_Check is
 
use Ada.Numerics.Complex_Types;
 
-- keep track if an accuracy failure has occurred so the test
-- can be short-circuited to avoid thousands of error messages.
Failure_Detected : Boolean := False;
 
Mult_MBE : constant Real := 5.0;
Divide_MBE : constant Real := 13.0;
 
 
procedure Check (Actual, Expected : Complex;
Test_Name : String;
MBE : Real) is
Rel_Error : Real;
Abs_Error : Real;
Max_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon instead
-- of Model_Epsilon and Expected.
Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon;
Abs_Error := MBE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual.Re - Expected.Re) > Max_Error then
Failure_Detected := True;
Report.Failed (Test_Name &
" actual.re: " & Real'Image (Actual.Re) &
" expected.re: " & Real'Image (Expected.Re) &
" difference.re " &
Real'Image (Actual.Re - Expected.Re) &
" mre:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result for real part");
else
Report.Comment (Test_Name & " passed for real part");
end if;
end if;
 
Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
if abs (Actual.Im - Expected.Im) > Max_Error then
Failure_Detected := True;
Report.Failed (Test_Name &
" actual.im: " & Real'Image (Actual.Im) &
" expected.im: " & Real'Image (Expected.Im) &
" difference.im " &
Real'Image (Actual.Im - Expected.Im) &
" mre:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result for imaginary part");
else
Report.Comment (Test_Name & " passed for imaginary part");
end if;
end if;
end Check;
 
 
procedure Special_Values is
begin
 
--- test 1 ---
declare
T : constant := (Real'Machine_EMax - 1) / 2;
Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
Expected : Complex := (0.0, 0.0);
X : Complex := (0.0, 0.0);
Y : Complex := (Big, Big);
Z : Complex;
begin
Z := X * Y;
Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)",
Mult_MBE);
Z := Y * X;
Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)",
Mult_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 1");
when others =>
Report.Failed ("exception in test 1");
end;
 
--- test 2 ---
declare
T : constant := Real'Model_EMin + 1;
Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
U : Complex := (Tiny, Tiny);
X : Complex := (0.0, 0.0);
Expected : Complex := (0.0, 0.0);
Z : Complex;
begin
Z := U * X;
Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)",
Mult_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 2");
when others =>
Report.Failed ("exception in test 2");
end;
 
--- test 3 ---
declare
T : constant := (Real'Machine_EMax - 1) / 2;
Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
B : Complex := (Big, Big);
X : Complex := (0.0, 0.0);
Z : Complex;
begin
if Real'Machine_Overflows then
Z := B / X;
Report.Failed ("test 3 - Constraint_Error not raised");
Check (Z, Z, "not executed - optimizer thwarting", 0.0);
end if;
exception
when Constraint_Error => null; -- expected
when others =>
Report.Failed ("exception in test 3");
end;
 
--- test 4 ---
declare
T : constant := Real'Model_EMin + 1;
Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
U : Complex := (Tiny, Tiny);
X : Complex := (0.0, 0.0);
Z : Complex;
begin
if Real'Machine_Overflows then
Z := U / X;
Report.Failed ("test 4 - Constraint_Error not raised");
Check (Z, Z, "not executed - optimizer thwarting", 0.0);
end if;
exception
when Constraint_Error => null; -- expected
when others =>
Report.Failed ("exception in test 4");
end;
 
 
--- test 5 ---
declare
X : Complex := (Sqrt2, Sqrt2);
Z : Complex;
Expected : constant Complex := (0.0, 4.0);
begin
Z := X * X;
Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)",
Mult_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 5");
when others =>
Report.Failed ("exception in test 5");
end;
 
--- test 6 ---
declare
X : Complex := Sqrt3 - Sqrt3 * i;
Z : Complex;
Expected : constant Complex := (0.0, -6.0);
begin
Z := X * X;
Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)",
Mult_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 6");
when others =>
Report.Failed ("exception in test 6");
end;
 
--- test 7 ---
declare
X : Complex := Sqrt2 + Sqrt2 * i;
Y : Complex := Sqrt2 - Sqrt2 * i;
Z : Complex;
Expected : constant Complex := 0.0 + i;
begin
Z := X / Y;
Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)",
Divide_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in test 7");
when others =>
Report.Failed ("exception in test 7");
end;
end Special_Values;
 
 
procedure Do_Mult_Div (X, Y : Complex) is
Z : Complex;
Args : constant String :=
"X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " &
"Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ;
begin
Z := (X * X) / X;
Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE);
Z := (X * Y) / X;
Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE);
Z := (X * Y) / Y;
Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args);
when others =>
Report.Failed ("exception in Do_Mult_Div for " & Args);
end Do_Mult_Div;
 
-- select complex values X and Y where the real and imaginary
-- parts are selected from the ranges (1/radix..1) and
-- (1..radix). This translates into quite a few combinations.
procedure Mult_Div_Check is
Samples : constant := 17;
Radix : constant Real := Real(Real'Machine_Radix);
Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix);
Low_Sample : Real; -- (1/radix .. 1)
High_Sample : Real; -- (1 .. radix)
Sample : array (1..2) of Real;
X, Y : Complex;
begin
for I in 1 .. Samples loop
Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) +
Inv_Radix;
Sample (1) := Low_Sample;
for J in 1 .. Samples loop
High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) +
Radix;
Sample (2) := High_Sample;
for K in 1 .. 2 loop
for L in 1 .. 2 loop
X := Complex'(Sample (K), Sample (L));
Y := Complex'(Sample (L), Sample (K));
Do_Mult_Div (X, Y);
if Failure_Detected then
return; -- minimize flood of error messages
end if;
end loop;
end loop;
end loop; -- J
end loop; -- I
end Mult_Div_Check;
 
 
procedure Do_Test is
begin
Special_Values;
Mult_Div_Check;
end Do_Test;
end Non_Generic_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
begin
Report.Test ("CXG2008",
"Check the accuracy of the complex multiplication and" &
" division operators");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking non-generic package");
end if;
 
Non_Generic_Check.Do_Test;
 
Report.Result;
end CXG2008;
/cxg2017.a
0,0 → 1,296
-- CXG2017.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the TANH function returns
-- a result that is within the error bound allowed.
--
-- TEST DESCRIPTION:
-- This test consists of a generic package that is
-- instantiated to check both Float and a long float type.
-- The test for each floating point type is divided into
-- several parts:
-- Special value checks where the result is a known constant.
-- Checks that use an identity for determining the result.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 20 Mar 96 SAIC Initial release for 2.1
-- 17 Aug 96 SAIC Incorporated reviewer comments.
-- 03 Jun 98 EDS Add parens to remove the potential for overflow.
-- Remove the invocation of Identity_Test that checks
-- Tanh values that are too close to zero for the
-- test's error bounds.
--!
 
--
-- References:
--
-- Software Manual for the Elementary Functions
-- William J. Cody, Jr. and William Waite
-- Prentice-Hall, 1980
--
-- CRC Standard Mathematical Tables
-- 23rd Edition
--
-- Implementation and Testing of Function Software
-- W. J. Cody
-- Problems and Methodologies in Mathematical Software Production
-- editors P. C. Messina and A. Murli
-- Lecture Notes in Computer Science Volume 142
-- Springer Verlag, 1982
--
 
with System;
with Report;
with Ada.Numerics.Generic_Elementary_Functions;
procedure CXG2017 is
Verbose : constant Boolean := False;
Max_Samples : constant := 1000;
 
E : constant := Ada.Numerics.E;
 
generic
type Real is digits <>;
package Generic_Check is
procedure Do_Test;
end Generic_Check;
 
package body Generic_Check is
package Elementary_Functions is new
Ada.Numerics.Generic_Elementary_Functions (Real);
 
function Tanh (X : Real) return Real renames
Elementary_Functions.Tanh;
 
function Log (X : Real) return Real renames
Elementary_Functions.Log;
 
-- flag used to terminate some tests early
Accuracy_Error_Reported : Boolean := False;
 
 
-- The following value is a lower bound on the accuracy
-- required. It is normally 0.0 so that the lower bound
-- is computed from Model_Epsilon. However, for tests
-- where the expected result is only known to a certain
-- amount of precision this bound takes on a non-zero
-- value to account for that level of precision.
Error_Low_Bound : Real := 0.0;
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real) is
Max_Error : Real;
Rel_Error : Real;
Abs_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Small instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Small;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
-- take into account the low bound on the error
if Max_Error < Error_Low_Bound then
Max_Error := Error_Low_Bound;
end if;
 
if abs (Actual - Expected) > Max_Error then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Special_Value_Test is
-- In the following tests the expected result is accurate
-- to the machine precision so the minimum guaranteed error
-- bound can be used.
Minimum_Error : constant := 8.0;
E2 : constant := E * E;
begin
Check (Tanh (1.0),
(E - 1.0 / E) / (E + 1.0 / E),
"tanh(1)",
Minimum_Error);
Check (Tanh (2.0),
(E2 - 1.0 / E2) / (E2 + 1.0 / E2),
"tanh(2)",
Minimum_Error);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in special value test");
when others =>
Report.Failed ("exception in special value test");
end Special_Value_Test;
 
 
 
procedure Exact_Result_Test is
No_Error : constant := 0.0;
begin
-- A.5.1(38);6.0
Check (Tanh (0.0), 0.0, "tanh(0)", No_Error);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in Exact_Result Test");
when others =>
Report.Failed ("exception in Exact_Result Test");
end Exact_Result_Test;
 
 
procedure Identity_Test (A, B : Real) is
-- For this test we use the identity
-- TANH(u+v) = [TANH(u) + TANH(v)] / [1 + TANH(u)*TANH(v)]
-- which is transformed to
-- TANH(x) = [TANH(y)+C] / [1 + TANH(y) * C]
-- where C = TANH(1/8) and y = x - 1/8
--
-- see Cody pg 248-249 for details on the error analysis.
-- The net result is a relative error bound of 16 * Model_Epsilon.
--
-- The second part of this test checks the identity
-- TANH(-x) = -TANH(X)
 
X, Y : Real;
Actual1, Actual2 : Real;
C : constant := 1.2435300177159620805e-1;
begin
if Real'Digits > 20 then
-- constant C is accurate to 20 digits. Set the low bound
-- on the error to 16*10**-20
Error_Low_Bound := 0.00000_00000_00000_00016;
Report.Comment ("tanh accuracy checked to 20 digits");
end if;
 
Accuracy_Error_Reported := False; -- reset
for I in 1..Max_Samples loop
X := (B - A) * (Real (I) / Real (Max_Samples)) + A;
Actual1 := Tanh(X);
-- TANH(x) = [TANH(y)+C] / [1 + TANH(y) * C]
Y := X - (1.0 / 8.0);
Actual2 := (Tanh (Y) + C) / (1.0 + Tanh(Y) * C);
Check (Actual1, Actual2,
"Identity_1_Test " & Integer'Image (I) & ": tanh(" &
Real'Image (X) & ") ",
16.0);
 
-- TANH(-x) = -TANH(X)
Actual2 := Tanh(-X);
Check (-Actual1, Actual2,
"Identity_2_Test " & Integer'Image (I) & ": tanh(" &
Real'Image (X) & ") ",
16.0);
 
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
 
end loop;
Error_Low_Bound := 0.0; -- reset
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Identity_Test" &
" for X=" & Real'Image (X));
when others =>
Report.Failed ("exception in Identity_Test" &
" for X=" & Real'Image (X));
end Identity_Test;
 
 
 
procedure Do_Test is
begin
Special_Value_Test;
Exact_Result_Test;
-- cover a large range
Identity_Test (1.0, Real'Safe_Last);
end Do_Test;
end Generic_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
package Float_Check is new Generic_Check (Float);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
package A_Long_Float_Check is new Generic_Check (A_Long_Float);
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
 
begin
Report.Test ("CXG2017",
"Check the accuracy of the TANH function");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
 
Report.Result;
end CXG2017;
/cxg2009.a
0,0 → 1,421
-- CXG2009.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the real sqrt and complex modulus functions
-- return results that are within the allowed
-- error bound.
--
-- TEST DESCRIPTION:
-- This test checks the accuracy of the sqrt and modulus functions
-- by computing the norm of various vectors where the result
-- is known in advance.
-- This test uses real and complex math together as would an
-- actual application. Considerable use of generics is also
-- employed.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 26 FEB 96 SAIC Initial release for 2.1
-- 22 AUG 96 SAIC Revised Check procedure
--
--!
 
------------------------------------------------------------------------------
 
with System;
with Report;
with Ada.Numerics.Generic_Complex_Types;
with Ada.Numerics.Generic_Elementary_Functions;
procedure CXG2009 is
Verbose : constant Boolean := False;
 
--=====================================================================
 
generic
type Real is digits <>;
package Generic_Real_Norm_Check is
procedure Do_Test;
end Generic_Real_Norm_Check;
 
-----------------------------------------------------------------------
 
package body Generic_Real_Norm_Check is
type Vector is array (Integer range <>) of Real;
 
package GEF is new Ada.Numerics.Generic_Elementary_Functions (Real);
function Sqrt (X : Real) return Real renames GEF.Sqrt;
 
function One_Norm (V : Vector) return Real is
-- sum of absolute values of the elements of the vector
Result : Real := 0.0;
begin
for I in V'Range loop
Result := Result + abs V(I);
end loop;
return Result;
end One_Norm;
 
function Inf_Norm (V : Vector) return Real is
-- greatest absolute vector element
Result : Real := 0.0;
begin
for I in V'Range loop
if abs V(I) > Result then
Result := abs V(I);
end if;
end loop;
return Result;
end Inf_Norm;
 
function Two_Norm (V : Vector) return Real is
-- if greatest absolute vector element is 0 then return 0
-- else return greatest * sqrt (sum((element / greatest) ** 2)))
-- where greatest is Inf_Norm of the vector
Inf_N : Real;
Sum_Squares : Real;
Term : Real;
begin
Inf_N := Inf_Norm (V);
if Inf_N = 0.0 then
return 0.0;
end if;
Sum_Squares := 0.0;
for I in V'Range loop
Term := V (I) / Inf_N;
Sum_Squares := Sum_Squares + Term * Term;
end loop;
return Inf_N * Sqrt (Sum_Squares);
end Two_Norm;
 
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real;
Vector_Length : Integer) is
Rel_Error : Real;
Abs_Error : Real;
Max_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual - Expected) > Max_Error then
Report.Failed (Test_Name &
" VectLength:" &
Integer'Image (Vector_Length) &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " &
Real'Image (Actual - Expected) &
" mre:" & Real'Image (Max_Error) );
elsif Verbose then
Report.Comment (Test_Name & " vector length" &
Integer'Image (Vector_Length));
end if;
end Check;
 
 
procedure Do_Test is
begin
for Vector_Length in 1 .. 10 loop
declare
V : Vector (1..Vector_Length) := (1..Vector_Length => 0.0);
V1 : Vector (1..Vector_Length) := (1..Vector_Length => 1.0);
begin
Check (One_Norm (V), 0.0, "one_norm (z)", 0.0, Vector_Length);
Check (Inf_Norm (V), 0.0, "inf_norm (z)", 0.0, Vector_Length);
 
for J in 1..Vector_Length loop
V := (1..Vector_Length => 0.0);
V (J) := 1.0;
Check (One_Norm (V), 1.0, "one_norm (010)",
0.0, Vector_Length);
Check (Inf_Norm (V), 1.0, "inf_norm (010)",
0.0, Vector_Length);
Check (Two_Norm (V), 1.0, "two_norm (010)",
0.0, Vector_Length);
end loop;
 
Check (One_Norm (V1), Real (Vector_Length), "one_norm (1)",
0.0, Vector_Length);
Check (Inf_Norm (V1), 1.0, "inf_norm (1)",
0.0, Vector_Length);
 
-- error in computing Two_Norm and expected result
-- are as follows (ME is Model_Epsilon * Expected_Value):
-- 2ME from expected Sqrt
-- 2ME from Sqrt in Two_Norm times the error in the
-- vector calculation.
-- The vector calculation contains the following error
-- based upon the length N of the vector:
-- N*1ME from squaring terms in Two_Norm
-- N*1ME from the division of each term in Two_Norm
-- (N-1)*1ME from the sum of the terms
-- This gives (2 + 2 * (N + N + (N-1)) ) * ME
-- which simplifies to (2 + 2N + 2N + 2N - 2) * ME
-- or 6*N*ME
Check (Two_Norm (V1), Sqrt (Real(Vector_Length)),
"two_norm (1)",
(Real (6 * Vector_Length)),
Vector_Length);
exception
when others => Report.Failed ("exception for vector length" &
Integer'Image (Vector_Length) );
end;
end loop;
end Do_Test;
end Generic_Real_Norm_Check;
 
--=====================================================================
 
generic
type Real is digits <>;
package Generic_Complex_Norm_Check is
procedure Do_Test;
end Generic_Complex_Norm_Check;
 
-----------------------------------------------------------------------
 
package body Generic_Complex_Norm_Check is
package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real);
use Complex_Types;
type Vector is array (Integer range <>) of Complex;
 
package GEF is new Ada.Numerics.Generic_Elementary_Functions (Real);
function Sqrt (X : Real) return Real renames GEF.Sqrt;
 
function One_Norm (V : Vector) return Real is
Result : Real := 0.0;
begin
for I in V'Range loop
Result := Result + abs V(I);
end loop;
return Result;
end One_Norm;
 
function Inf_Norm (V : Vector) return Real is
Result : Real := 0.0;
begin
for I in V'Range loop
if abs V(I) > Result then
Result := abs V(I);
end if;
end loop;
return Result;
end Inf_Norm;
 
function Two_Norm (V : Vector) return Real is
Inf_N : Real;
Sum_Squares : Real;
Term : Real;
begin
Inf_N := Inf_Norm (V);
if Inf_N = 0.0 then
return 0.0;
end if;
Sum_Squares := 0.0;
for I in V'Range loop
Term := abs (V (I) / Inf_N );
Sum_Squares := Sum_Squares + Term * Term;
end loop;
return Inf_N * Sqrt (Sum_Squares);
end Two_Norm;
 
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real;
Vector_Length : Integer) is
Rel_Error : Real;
Abs_Error : Real;
Max_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Epsilon instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual - Expected) > Max_Error then
Report.Failed (Test_Name &
" VectLength:" &
Integer'Image (Vector_Length) &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " &
Real'Image (Actual - Expected) &
" mre:" & Real'Image (Max_Error) );
elsif Verbose then
Report.Comment (Test_Name & " vector length" &
Integer'Image (Vector_Length));
end if;
end Check;
 
 
procedure Do_Test is
begin
for Vector_Length in 1 .. 10 loop
declare
V : Vector (1..Vector_Length) :=
(1..Vector_Length => (0.0, 0.0));
X, Y : Vector (1..Vector_Length);
begin
Check (One_Norm (V), 0.0, "one_norm (z)", 0.0, Vector_Length);
Check (Inf_Norm (V), 0.0, "inf_norm (z)", 0.0, Vector_Length);
 
for J in 1..Vector_Length loop
X := (1..Vector_Length => (0.0, 0.0) );
Y := X; -- X and Y are now both zeroed
X (J).Re := 1.0;
Y (J).Im := 1.0;
Check (One_Norm (X), 1.0, "one_norm (0x0)",
0.0, Vector_Length);
Check (Inf_Norm (X), 1.0, "inf_norm (0x0)",
0.0, Vector_Length);
Check (Two_Norm (X), 1.0, "two_norm (0x0)",
0.0, Vector_Length);
Check (One_Norm (Y), 1.0, "one_norm (0y0)",
0.0, Vector_Length);
Check (Inf_Norm (Y), 1.0, "inf_norm (0y0)",
0.0, Vector_Length);
Check (Two_Norm (Y), 1.0, "two_norm (0y0)",
0.0, Vector_Length);
end loop;
 
V := (1..Vector_Length => (3.0, 4.0));
 
-- error in One_Norm is 3*N*ME for abs computation +
-- (N-1)*ME for the additions
-- which gives (4N-1) * ME
Check (One_Norm (V), 5.0 * Real (Vector_Length),
"one_norm ((3,4))",
Real (4*Vector_Length - 1),
Vector_Length);
 
-- error in Inf_Norm is from abs of single element (3ME)
Check (Inf_Norm (V), 5.0,
"inf_norm ((3,4))",
3.0,
Vector_Length);
 
-- error in following comes from:
-- 2ME in sqrt of expected result
-- 3ME in Inf_Norm calculation
-- 2ME in sqrt of vector calculation
-- vector calculation has following error
-- 3N*ME for abs
-- N*ME for squaring
-- N*ME for division
-- (N-1)ME for sum
-- this results in [2 + 3 + 2(6N-1) ] * ME
-- or (12N + 3)ME
Check (Two_Norm (V), 5.0 * Sqrt (Real(Vector_Length)),
"two_norm ((3,4))",
(12.0 * Real (Vector_Length) + 3.0),
Vector_Length);
exception
when others => Report.Failed ("exception for complex " &
"vector length" &
Integer'Image (Vector_Length) );
end;
end loop;
end Do_Test;
end Generic_Complex_Norm_Check;
 
--=====================================================================
 
generic
type Real is digits <>;
package Generic_Norm_Check is
procedure Do_Test;
end Generic_Norm_Check;
 
-----------------------------------------------------------------------
 
package body Generic_Norm_Check is
package RNC is new Generic_Real_Norm_Check (Real);
package CNC is new Generic_Complex_Norm_Check (Real);
procedure Do_Test is
begin
RNC.Do_Test;
CNC.Do_Test;
end Do_Test;
end Generic_Norm_Check;
 
--=====================================================================
 
package Float_Check is new Generic_Norm_Check (Float);
 
type A_Long_Float is digits System.Max_Digits;
package A_Long_Float_Check is new Generic_Norm_Check (A_Long_Float);
 
-----------------------------------------------------------------------
 
begin
Report.Test ("CXG2009",
"Check the accuracy of the real sqrt and complex " &
" modulus functions");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
Report.Result;
end CXG2009;
/cxg2018.a
0,0 → 1,355
-- CXG2018.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the complex EXP function returns
-- a result that is within the error bound allowed.
--
-- TEST DESCRIPTION:
-- This test consists of a generic package that is
-- instantiated to check complex numbers based upon
-- both Float and a long float type.
-- The test for each floating point type is divided into
-- several parts:
-- Special value checks where the result is a known constant.
-- Checks that use an identity for determining the result.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 21 Mar 96 SAIC Initial release for 2.1
-- 17 Aug 96 SAIC Incorporated reviewer comments.
-- 27 Aug 99 RLB Repair on the error result of checks.
-- 02 Apr 03 RLB Added code to discard excess precision in the
-- construction of the test value for the
-- Identity_Test.
--
--!
 
--
-- References:
--
-- W. J. Cody
-- CELEFUNT: A Portable Test Package for Complex Elementary Functions
-- Algorithm 714, Collected Algorithms from ACM.
-- Published in Transactions On Mathematical Software,
-- Vol. 19, No. 1, March, 1993, pp. 1-21.
--
-- CRC Standard Mathematical Tables
-- 23rd Edition
--
 
with System;
with Report;
with Ada.Numerics.Generic_Complex_Types;
with Ada.Numerics.Generic_Complex_Elementary_Functions;
procedure CXG2018 is
Verbose : constant Boolean := False;
-- Note that Max_Samples is the number of samples taken in
-- both the real and imaginary directions. Thus, for Max_Samples
-- of 100 the number of values checked is 10000.
Max_Samples : constant := 100;
 
E : constant := Ada.Numerics.E;
Pi : constant := Ada.Numerics.Pi;
 
generic
type Real is digits <>;
package Generic_Check is
procedure Do_Test;
end Generic_Check;
 
package body Generic_Check is
package Complex_Type is new
Ada.Numerics.Generic_Complex_Types (Real);
use Complex_Type;
 
package CEF is new
Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type);
 
function Exp (X : Complex) return Complex renames CEF.Exp;
function Exp (X : Imaginary) return Complex renames CEF.Exp;
 
-- flag used to terminate some tests early
Accuracy_Error_Reported : Boolean := False;
 
 
-- The following value is a lower bound on the accuracy
-- required. It is normally 0.0 so that the lower bound
-- is computed from Model_Epsilon. However, for tests
-- where the expected result is only known to a certain
-- amount of precision this bound takes on a non-zero
-- value to account for that level of precision.
Error_Low_Bound : Real := 0.0;
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real) is
Max_Error : Real;
Rel_Error : Real;
Abs_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Small instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Small;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
-- take into account the low bound on the error
if Max_Error < Error_Low_Bound then
Max_Error := Error_Low_Bound;
end if;
 
if abs (Actual - Expected) > Max_Error then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Check (Actual, Expected : Complex;
Test_Name : String;
MRE : Real) is
begin
Check (Actual.Re, Expected.Re, Test_Name & " real part", MRE);
Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", MRE);
end Check;
 
 
procedure Special_Value_Test is
-- In the following tests the expected result is accurate
-- to the machine precision so the minimum guaranteed error
-- bound can be used.
--
-- The error bounds given assumed z is exact. When using
-- pi there is an extra error of 1.0ME.
-- The pi inside the exp call requires that the complex
-- component have an extra error allowance of 1.0*angle*ME.
-- Thus for pi/2,the Minimum_Error_I is
-- (2.0 + 1.0(pi/2))ME <= 3.6ME.
-- For pi, it is (2.0 + 1.0*pi)ME <= 5.2ME,
-- and for 2pi, it is (2.0 + 1.0(2pi))ME <= 8.3ME.
 
-- The addition of 1 or i to a result is so that neither of
-- the components of an expected result is 0. This is so
-- that a reasonable relative error is allowed.
Minimum_Error_C : constant := 7.0; -- for exp(Complex)
Minimum_Error_I : constant := 2.0; -- for exp(Imaginary)
begin
Check (Exp (1.0 + 0.0*i) + i,
E + i,
"exp(1+0i)",
Minimum_Error_C);
Check (Exp ((Pi / 2.0) * i) + 1.0,
1.0 + 1.0*i,
"exp(pi/2*i)",
3.6);
Check (Exp (Pi * i) + i,
-1.0 + 1.0*i,
"exp(pi*i)",
5.2);
Check (Exp (Pi * 2.0 * i) + i,
1.0 + i,
"exp(2pi*i)",
8.3);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in special value test");
when others =>
Report.Failed ("exception in special value test");
end Special_Value_Test;
 
 
 
procedure Exact_Result_Test is
No_Error : constant := 0.0;
begin
-- G.1.2(36);6.0
Check (Exp(0.0 + 0.0*i), 1.0 + 0.0 * i, "exp(0+0i)", No_Error);
Check (Exp( 0.0*i), 1.0 + 0.0 * i, "exp(0i)", No_Error);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in Exact_Result Test");
when others =>
Report.Failed ("exception in Exact_Result Test");
end Exact_Result_Test;
 
 
procedure Identity_Test (A, B : Real) is
-- For this test we use the identity
-- Exp(Z) = Exp(Z-W) * Exp (W)
-- where W = (1+i)/16
--
-- The second part of this test checks the identity
-- Exp(Z) * Exp(-Z) = 1
--
 
X, Y : Complex;
Actual1, Actual2 : Complex;
W : constant Complex := (0.0625, 0.0625);
-- the following constant was taken from the CELEFUNC EXP test.
-- This is the value EXP(W) - 1
C : constant Complex := (6.2416044877018563681e-2,
6.6487597751003112768e-2);
begin
if Real'Digits > 20 then
-- constant ExpW is accurate to 20 digits.
-- The low bound is 19 * 10**-20
Error_Low_Bound := 0.00000_00000_00019;
Report.Comment ("complex exp accuracy checked to 20 digits");
end if;
 
Accuracy_Error_Reported := False; -- reset
for II in 1..Max_Samples loop
X.Re := Real'Machine ((B - A) * Real (II) / Real (Max_Samples)
+ A);
for J in 1..Max_Samples loop
X.Im := Real'Machine ((B - A) * Real (J) / Real (Max_Samples)
+ A);
 
Actual1 := Exp(X);
 
-- Exp(X) = Exp(X-W) * Exp (W)
-- = Exp(X-W) * (1 - (1-Exp(W))
-- = Exp(X-W) * (1 + (Exp(W) - 1))
-- = Exp(X-W) * (1 + C)
Y := X - W;
Actual2 := Exp(Y);
Actual2 := Actual2 + Actual2 * C;
 
Check (Actual1, Actual2,
"Identity_1_Test " & Integer'Image (II) &
Integer'Image (J) & ": Exp((" &
Real'Image (X.Re) & ", " &
Real'Image (X.Im) & ")) ",
20.0); -- 2 exp and 1 multiply and 1 add = 2*7+1*5+1
-- Note: The above is not strictly correct, as multiply
-- has a box error, rather than a relative error.
-- Supposedly, the interval is chosen to avoid the need
-- to worry about this.
 
-- Exp(X) * Exp(-X) + i = 1 + i
-- The addition of i is to allow a reasonable relative
-- error in the imaginary part
Actual2 := (Actual1 * Exp(-X)) + i;
Check (Actual2, (1.0, 1.0),
"Identity_2_Test " & Integer'Image (II) &
Integer'Image (J) & ": Exp((" &
Real'Image (X.Re) & ", " &
Real'Image (X.Im) & ")) ",
20.0); -- 2 exp and 1 multiply and one add = 2*7+1*5+1
 
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
end loop;
end loop;
Error_Low_Bound := 0.0;
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Identity_Test" &
" for X=(" & Real'Image (X.Re) &
", " & Real'Image (X.Im) & ")");
when others =>
Report.Failed ("exception in Identity_Test" &
" for X=(" & Real'Image (X.Re) &
", " & Real'Image (X.Im) & ")");
end Identity_Test;
 
 
 
procedure Do_Test is
begin
Special_Value_Test;
Exact_Result_Test;
-- test regions where we can avoid cancellation error problems
-- See Cody page 10.
Identity_Test (0.0625, 1.0);
Identity_Test (15.0, 17.0);
Identity_Test (1.625, 3.0);
end Do_Test;
end Generic_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
package Float_Check is new Generic_Check (Float);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
package A_Long_Float_Check is new Generic_Check (A_Long_Float);
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
 
begin
Report.Test ("CXG2018",
"Check the accuracy of the complex EXP function");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
 
Report.Result;
end CXG2018;
/cxg2019.a
0,0 → 1,338
-- CXG2019.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the complex LOG function returns
-- a result that is within the error bound allowed.
--
-- TEST DESCRIPTION:
-- This test consists of a generic package that is
-- instantiated to check complex numbers based upon
-- both Float and a long float type.
-- The test for each floating point type is divided into
-- several parts:
-- Special value checks where the result is a known constant.
-- Checks that use an identity for determining the result.
-- Exception conditions.
--
-- SPECIAL REQUIREMENTS
-- The Strict Mode for the numerical accuracy must be
-- selected. The method by which this mode is selected
-- is implementation dependent.
--
-- APPLICABILITY CRITERIA:
-- This test applies only to implementations supporting the
-- Numerics Annex.
-- This test only applies to the Strict Mode for numerical
-- accuracy.
--
--
-- CHANGE HISTORY:
-- 22 Mar 96 SAIC Initial release for 2.1
--
--!
 
--
-- References:
--
-- W. J. Cody
-- CELEFUNT: A Portable Test Package for Complex Elementary Functions
-- Algorithm 714, Collected Algorithms from ACM.
-- Published in Transactions On Mathematical Software,
-- Vol. 19, No. 1, March, 1993, pp. 1-21.
--
-- CRC Standard Mathematical Tables
-- 23rd Edition
--
 
with System;
with Report;
with Ada.Numerics.Generic_Complex_Types;
with Ada.Numerics.Generic_Complex_Elementary_Functions;
procedure CXG2019 is
Verbose : constant Boolean := False;
-- Note that Max_Samples is the number of samples taken in
-- both the real and imaginary directions. Thus, for Max_Samples
-- of 100 the number of values checked is 10000.
Max_Samples : constant := 100;
 
E : constant := Ada.Numerics.E;
Pi : constant := Ada.Numerics.Pi;
 
generic
type Real is digits <>;
package Generic_Check is
procedure Do_Test;
end Generic_Check;
 
package body Generic_Check is
package Complex_Type is new
Ada.Numerics.Generic_Complex_Types (Real);
use Complex_Type;
 
package CEF is new
Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type);
 
function Log (X : Complex) return Complex renames CEF.Log;
 
-- flag used to terminate some tests early
Accuracy_Error_Reported : Boolean := False;
 
 
procedure Check (Actual, Expected : Real;
Test_Name : String;
MRE : Real) is
Max_Error : Real;
Rel_Error : Real;
Abs_Error : Real;
begin
-- In the case where the expected result is very small or 0
-- we compute the maximum error as a multiple of Model_Small instead
-- of Model_Epsilon and Expected.
Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
Abs_Error := MRE * Real'Model_Epsilon;
if Rel_Error > Abs_Error then
Max_Error := Rel_Error;
else
Max_Error := Abs_Error;
end if;
 
if abs (Actual - Expected) > Max_Error then
Accuracy_Error_Reported := True;
Report.Failed (Test_Name &
" actual: " & Real'Image (Actual) &
" expected: " & Real'Image (Expected) &
" difference: " & Real'Image (Actual - Expected) &
" max err:" & Real'Image (Max_Error) );
elsif Verbose then
if Actual = Expected then
Report.Comment (Test_Name & " exact result");
else
Report.Comment (Test_Name & " passed");
end if;
end if;
end Check;
 
 
procedure Check (Actual, Expected : Complex;
Test_Name : String;
MRE : Real) is
begin
Check (Actual.Re, Expected.Re, Test_Name & " real part", MRE);
Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", MRE);
end Check;
 
 
procedure Special_Value_Test is
-- In the following tests the expected result is accurate
-- to the machine precision so the minimum guaranteed error
-- bound can be used if the argument is exact.
--
-- When using pi there is an extra error of 1.0ME.
-- Although the real component has an error bound of 13.0,
-- the complex component must take into account this error
-- in the value for Pi.
--
-- One or i is added to the actual and expected results in
-- order to prevent the expected result from having a
-- real or imaginary part of 0. This is to allow a reasonable
-- relative error for that component.
Minimum_Error : constant := 13.0;
begin
Check (1.0 + Log (0.0 + i),
1.0 + Pi / 2.0 * i,
"1+log(0+i)",
Minimum_Error + 1.0);
Check (1.0 + Log ((-1.0, 0.0)),
1.0 + (Pi * i),
"log(-1+0i)+1 ",
Minimum_Error + 1.0);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in special value test");
when others =>
Report.Failed ("exception in special value test");
end Special_Value_Test;
 
 
 
procedure Exact_Result_Test is
No_Error : constant := 0.0;
begin
-- G.1.2(37);6.0
Check (Log(1.0 + 0.0*i), 0.0 + 0.0 * i, "log(1+0i)", No_Error);
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error raised in Exact_Result Test");
when others =>
Report.Failed ("exception in Exact_Result Test");
end Exact_Result_Test;
 
 
procedure Identity_Test (RA, RB, IA, IB : Real) is
-- Tests an identity over a range of values specified
-- by the 4 parameters. RA and RB denote the range for the
-- real part while IA and IB denote the range for the
-- imaginary part.
--
-- For this test we use the identity
-- Log(Z*Z) = 2 * Log(Z)
--
 
Scale : Real := Real (Real'Machine_Radix) ** (Real'Mantissa / 2 + 4);
W, X, Y, Z : Real;
CX, CY : Complex;
Actual1, Actual2 : Complex;
begin
Accuracy_Error_Reported := False; -- reset
for II in 1..Max_Samples loop
X := (RB - RA) * Real (II) / Real (Max_Samples) + RA;
for J in 1..Max_Samples loop
Y := (IB - IA) * Real (J) / Real (Max_Samples) + IA;
-- purify the arguments to minimize roundoff error.
-- We construct the values so that the products X*X,
-- Y*Y, and X*Y are all exact machine numbers.
-- See Cody page 7 and CELEFUNT code.
Z := X * Scale;
W := Z + X;
X := W - Z;
Z := Y * Scale;
W := Z + Y;
Y := W - Z;
CX := Compose_From_Cartesian(X,Y);
Z := X*X - Y*Y;
W := X*Y;
CY := Compose_From_Cartesian(Z,W+W);
-- The arguments are now ready so on with the
-- identity computation.
Actual1 := Log(CX);
Actual2 := Log(CY) * 0.5;
Check (Actual1, Actual2,
"Identity_1_Test " & Integer'Image (II) &
Integer'Image (J) & ": Log((" &
Real'Image (CX.Re) & ", " &
Real'Image (CX.Im) & ")) ",
26.0); -- 2 logs = 2*13. no error from this multiply
 
if Accuracy_Error_Reported then
-- only report the first error in this test in order to keep
-- lots of failures from producing a huge error log
return;
end if;
end loop;
end loop;
 
exception
when Constraint_Error =>
Report.Failed
("Constraint_Error raised in Identity_Test" &
" for X=(" & Real'Image (X) &
", " & Real'Image (X) & ")");
when others =>
Report.Failed ("exception in Identity_Test" &
" for X=(" & Real'Image (X) &
", " & Real'Image (X) & ")");
end Identity_Test;
 
 
procedure Exception_Test is
-- Check that log((0,0)) causes constraint_error.
-- G.1.2(29);
 
X : Complex := (0.0, 0.0);
begin
if not Real'Machine_Overflows then
-- not applicable: G.1.2(28);6.0
return;
end if;
 
begin
X := Log ((0.0, 0.0));
Report.Failed ("exception not raised for log(0,0)");
exception
when Constraint_Error => null; -- ok
when others =>
Report.Failed ("wrong exception raised for log(0,0)");
end;
 
-- optimizer thwarting
if Report.Ident_Bool(False) then
Report.Comment (Real'Image (X.Re + X.Im));
end if;
end Exception_Test;
 
 
procedure Do_Test is
begin
Special_Value_Test;
Exact_Result_Test;
-- test regions that do not include the unit circle so that
-- the real part of LOG(Z) does not vanish
-- See Cody page 9.
Identity_Test ( 2.0, 10.0, 0.0, 10.0);
Identity_Test (1000.0, 2000.0, -4000.0, -1000.0);
Identity_Test (Real'Model_Epsilon, 0.25,
-0.25, -Real'Model_Epsilon);
Exception_Test;
end Do_Test;
end Generic_Check;
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
package Float_Check is new Generic_Check (Float);
 
-- check the floating point type with the most digits
type A_Long_Float is digits System.Max_Digits;
package A_Long_Float_Check is new Generic_Check (A_Long_Float);
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
 
 
begin
Report.Test ("CXG2019",
"Check the accuracy of the complex LOG function");
 
if Verbose then
Report.Comment ("checking Standard.Float");
end if;
 
Float_Check.Do_Test;
 
if Verbose then
Report.Comment ("checking a digits" &
Integer'Image (System.Max_Digits) &
" floating point type");
end if;
 
A_Long_Float_Check.Do_Test;
 
 
Report.Result;
end CXG2019;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.