diff options
| author | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
|---|---|---|
| committer | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
| commit | 554fd8c5195424bdbcabf5de30fdc183aba391bd (patch) | |
| tree | 976dc5ab7fddf506dadce60ae936f43f58787092 /gcc/testsuite/ada/acats/tests/cxg | |
| download | cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.bz2 cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.xz | |
obtained gcc-4.6.4.tar.bz2 from upstream website;upstream
verified gcc-4.6.4.tar.bz2.sig;
imported gcc-4.6.4 source tree from verified upstream tarball.
downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.
if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cxg')
29 files changed, 12171 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a new file mode 100644 index 000000000..01a0f061e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a new file mode 100644 index 000000000..39f5f00db --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a new file mode 100644 index 000000000..c3885136b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a new file mode 100644 index 000000000..f026eae70 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a new file mode 100644 index 000000000..6faad4e13 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a new file mode 100644 index 000000000..0d7afa460 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a new file mode 100644 index 000000000..6a1f322e8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a new file mode 100644 index 000000000..d1a225a50 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a new file mode 100644 index 000000000..2df296d3d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a new file mode 100644 index 000000000..4054b83d8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a new file mode 100644 index 000000000..da15dc3be --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a new file mode 100644 index 000000000..ba07df29d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a new file mode 100644 index 000000000..58cf367f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a new file mode 100644 index 000000000..0b11ca538 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a new file mode 100644 index 000000000..4140a4875 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a new file mode 100644 index 000000000..2c018b132 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a new file mode 100644 index 000000000..6a665d0e0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a new file mode 100644 index 000000000..94f180b80 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a new file mode 100644 index 000000000..48499a255 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a new file mode 100644 index 000000000..50fda5e1f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a new file mode 100644 index 000000000..832b11822 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a new file mode 100644 index 000000000..50add975f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a new file mode 100644 index 000000000..be4f1a82f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a new file mode 100644 index 000000000..0a4dddcc9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a new file mode 100644 index 000000000..1aed4ca57 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a new file mode 100644 index 000000000..db49fc845 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a new file mode 100644 index 000000000..f9e4d1cae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a new file mode 100644 index 000000000..0cdd5574e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a new file mode 100644 index 000000000..55648283e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/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; |