gcc/testsuite/ada/acats/tests/cxg/cxg2008.a

   1 -- CXG2008.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- OBJECTIVE:
  27 --      Check that the complex multiplication and division
  28 --      operations return results that are within the allowed
  29 --      error bound.
  30 --      Check that all the required pure Numerics packages are pure.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      This test contains three test packages that are almost
  34 --      identical.  The first two packages differ only in the
  35 --      floating point type that is being tested.  The first
  36 --      and third package differ only in whether the generic
  37 --      complex types package or the pre-instantiated
  38 --      package is used.
  39 --      The test package is not generic so that the arguments
  40 --      and expected results for some of the test values
  41 --      can be expressed as universal real instead of being
  42 --      computed at runtime.
  43 --
  44 -- SPECIAL REQUIREMENTS
  45 --      The Strict Mode for the numerical accuracy must be
  46 --      selected.  The method by which this mode is selected
  47 --      is implementation dependent.
  48 --
  49 -- APPLICABILITY CRITERIA:
  50 --      This test applies only to implementations supporting the
  51 --      Numerics Annex.
  52 --      This test only applies to the Strict Mode for numerical
  53 --      accuracy.
  54 --
  55 --
  56 -- CHANGE HISTORY:
  57 --      24 FEB 96   SAIC    Initial release for 2.1
  58 --      03 JUN 98   EDS     Correct the test program's incorrect assumption
  59 --                          that Constraint_Error must be raised by complex
  60 --                          division by zero, which is contrary to the
  61 --                          allowance given by the Ada 95 standard G.1.1(40).
  62 --      13 MAR 01   RLB     Replaced commented out Pure check on non-generic
  63 --                          packages, as required by Defect Report
  64 --                          8652/0020 and as reflected in Technical
  65 --                          Corrigendum 1.
  66 --!
  67
  68 ------------------------------------------------------------------------------
  69 -- Check that the required pure packages are pure by withing them from a
  70 -- pure package. The non-generic versions of those packages are required to
  71 -- be pure by Defect Report 8652/0020, Technical Corrigendum 1 [A.5.1(9/1) and
  72 -- G.1.1(25/1)].
  73 with Ada.Numerics.Generic_Elementary_Functions;
  74 with Ada.Numerics.Elementary_Functions;
  75 with Ada.Numerics.Generic_Complex_Types;
  76 with Ada.Numerics.Complex_Types;
  77 with Ada.Numerics.Generic_Complex_Elementary_Functions;
  78 with Ada.Numerics.Complex_Elementary_Functions;
  79 package CXG2008_0 is
  80   pragma Pure;
  81    -- CRC Standard Mathematical Tables;  23rd Edition; pg 738
  82    Sqrt2 : constant :=
  83         1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
  84    Sqrt3 : constant :=
  85         1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
  86 end CXG2008_0;
  87
  88 ------------------------------------------------------------------------------
  89
  90 with System;
  91 with Report;
  92 with Ada.Numerics.Generic_Complex_Types;
  93 with Ada.Numerics.Complex_Types;
  94 with CXG2008_0;  use CXG2008_0;
  95 procedure CXG2008 is
  96    Verbose : constant Boolean := False;
  97
  98    package Float_Check is
  99       subtype Real is Float;
 100       procedure Do_Test;
 101    end Float_Check;
 102
 103    package body Float_Check is
 104       package Complex_Types is new
 105            Ada.Numerics.Generic_Complex_Types (Real);
 106       use Complex_Types;
 107
 108       -- keep track if an accuracy failure has occurred so the test
 109       -- can be short-circuited to avoid thousands of error messages.
 110       Failure_Detected : Boolean := False;
 111
 112       Mult_MBE : constant Real := 5.0;
 113       Divide_MBE : constant Real := 13.0;
 114
 115
 116       procedure Check (Actual, Expected : Complex;
 117                        Test_Name : String;
 118                        MBE : Real) is
 119          Rel_Error : Real;
 120          Abs_Error : Real;
 121          Max_Error : Real;
 122       begin
 123          -- In the case where the expected result is very small or 0
 124          -- we compute the maximum error as a multiple of Model_Epsilon instead
 125          -- of Model_Epsilon and Expected.
 126          Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon;
 127          Abs_Error := MBE * Real'Model_Epsilon;
 128          if Rel_Error > Abs_Error then
 129             Max_Error := Rel_Error;
 130          else
 131             Max_Error := Abs_Error;
 132          end if;
 133
 134          if abs (Actual.Re - Expected.Re) > Max_Error then
 135             Failure_Detected := True;
 136             Report.Failed (Test_Name &
 137                            " actual.re: " & Real'Image (Actual.Re) &
 138                            " expected.re: " & Real'Image (Expected.Re) &
 139                            " difference.re " &
 140                            Real'Image (Actual.Re - Expected.Re) &
 141                            " mre:" & Real'Image (Max_Error) );
 142          elsif Verbose then
 143             if Actual = Expected then
 144                Report.Comment (Test_Name & " exact result for real part");
 145             else
 146                Report.Comment (Test_Name & " passed for real part");
 147             end if;
 148          end if;
 149
 150          Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon;
 151          if Rel_Error > Abs_Error then
 152             Max_Error := Rel_Error;
 153          else
 154             Max_Error := Abs_Error;
 155          end if;
 156          if abs (Actual.Im - Expected.Im) > Max_Error then
 157             Failure_Detected := True;
 158             Report.Failed (Test_Name &
 159                            " actual.im: " & Real'Image (Actual.Im) &
 160                            " expected.im: " & Real'Image (Expected.Im) &
 161                            " difference.im " &
 162                            Real'Image (Actual.Im - Expected.Im) &
 163                            " mre:" & Real'Image (Max_Error) );
 164          elsif Verbose then
 165             if Actual = Expected then
 166                Report.Comment (Test_Name & " exact result for imaginary part");
 167             else
 168                Report.Comment (Test_Name & " passed for imaginary part");
 169             end if;
 170          end if;
 171       end Check;
 172
 173
 174       procedure Special_Values is
 175       begin
 176
 177          --- test 1 ---
 178          declare
 179             T : constant := (Real'Machine_EMax - 1) / 2;
 180             Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
 181             Expected : Complex := (0.0, 0.0);
 182             X : Complex := (0.0, 0.0);
 183             Y : Complex := (Big, Big);
 184             Z : Complex;
 185          begin
 186             Z := X * Y;
 187             Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)",
 188                    Mult_MBE);
 189             Z := Y * X;
 190             Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)",
 191                    Mult_MBE);
 192          exception
 193             when Constraint_Error =>
 194                Report.Failed ("Constraint_Error raised in test 1");
 195             when others =>
 196                Report.Failed ("exception in test 1");
 197          end;
 198
 199          --- test 2 ---
 200          declare
 201             T : constant := Real'Model_EMin + 1;
 202             Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
 203             U : Complex := (Tiny, Tiny);
 204             X : Complex := (0.0, 0.0);
 205             Expected : Complex := (0.0, 0.0);
 206             Z : Complex;
 207          begin
 208             Z := U * X;
 209             Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)",
 210                    Mult_MBE);
 211          exception
 212             when Constraint_Error =>
 213                Report.Failed ("Constraint_Error raised in test 2");
 214             when others =>
 215                Report.Failed ("exception in test 2");
 216          end;
 217
 218          --- test 3 ---
 219          declare
 220             T : constant := (Real'Machine_EMax - 1) / 2;
 221             Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
 222             B : Complex := (Big, Big);
 223             X : Complex := (0.0, 0.0);
 224             Z : Complex;
 225          begin
 226             if Real'Machine_Overflows then
 227                Z := B / X;
 228                Report.Failed ("test 3 - Constraint_Error not raised");
 229                Check (Z, Z, "not executed - optimizer thwarting", 0.0);
 230             end if;
 231          exception
 232             when Constraint_Error => null;  -- expected
 233             when others =>
 234                Report.Failed ("exception in test 3");
 235          end;
 236
 237          --- test 4 ---
 238          declare
 239             T : constant := Real'Model_EMin + 1;
 240             Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
 241             U : Complex := (Tiny, Tiny);
 242             X : Complex := (0.0, 0.0);
 243             Z : Complex;
 244          begin
 245             if Real'Machine_Overflows then
 246                Z := U / X;
 247                Report.Failed ("test 4 - Constraint_Error not raised");
 248                Check (Z, Z, "not executed - optimizer thwarting", 0.0);
 249             end if;
 250          exception
 251             when Constraint_Error => null;  -- expected
 252             when others =>
 253                Report.Failed ("exception in test 4");
 254          end;
 255
 256
 257          --- test 5 ---
 258          declare
 259             X : Complex := (Sqrt2, Sqrt2);
 260             Z : Complex;
 261             Expected : constant Complex := (0.0, 4.0);
 262          begin
 263             Z := X * X;
 264             Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)",
 265                    Mult_MBE);
 266          exception
 267             when Constraint_Error =>
 268                Report.Failed ("Constraint_Error raised in test 5");
 269             when others =>
 270                Report.Failed ("exception in test 5");
 271          end;
 272
 273          --- test 6 ---
 274          declare
 275             X : Complex := Sqrt3 - Sqrt3 * i;
 276             Z : Complex;
 277             Expected : constant Complex := (0.0, -6.0);
 278          begin
 279             Z := X * X;
 280             Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)",
 281                    Mult_MBE);
 282          exception
 283             when Constraint_Error =>
 284                Report.Failed ("Constraint_Error raised in test 6");
 285             when others =>
 286                Report.Failed ("exception in test 6");
 287          end;
 288
 289          --- test 7 ---
 290          declare
 291             X : Complex := Sqrt2 + Sqrt2 * i;
 292             Y : Complex := Sqrt2 - Sqrt2 * i;
 293             Z : Complex;
 294             Expected : constant Complex := 0.0 + i;
 295          begin
 296             Z := X / Y;
 297             Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)",
 298                    Divide_MBE);
 299          exception
 300             when Constraint_Error =>
 301                Report.Failed ("Constraint_Error raised in test 7");
 302             when others =>
 303                Report.Failed ("exception in test 7");
 304          end;
 305       end Special_Values;
 306
 307
 308       procedure Do_Mult_Div (X, Y : Complex) is
 309          Z : Complex;
 310          Args : constant String :=
 311            "X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " &
 312            "Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ;
 313       begin
 314          Z := (X * X) / X;
 315          Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE);
 316          Z := (X * Y) / X;
 317          Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE);
 318          Z := (X * Y) / Y;
 319          Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE);
 320       exception
 321          when Constraint_Error =>
 322             Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args);
 323          when others =>
 324             Report.Failed ("exception in Do_Mult_Div for " & Args);
 325       end Do_Mult_Div;
 326
 327       -- select complex values X and Y where the real and imaginary
 328       -- parts are selected from the ranges (1/radix..1) and
 329       -- (1..radix).  This translates into quite a few combinations.
 330       procedure Mult_Div_Check is
 331          Samples : constant := 17;
 332          Radix : constant Real := Real(Real'Machine_Radix);
 333          Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix);
 334          Low_Sample : Real;  -- (1/radix .. 1)
 335          High_Sample : Real; -- (1 .. radix)
 336          Sample : array (1..2) of Real;
 337          X, Y : Complex;
 338       begin
 339          for I in 1 .. Samples loop
 340             Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) +
 341                           Inv_Radix;
 342             Sample (1) := Low_Sample;
 343             for J in 1 .. Samples loop
 344                High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) +
 345                               Radix;
 346                Sample (2) := High_Sample;
 347                for K in 1 .. 2 loop
 348                   for L in 1 .. 2 loop
 349                      X := Complex'(Sample (K), Sample (L));
 350                      Y := Complex'(Sample (L), Sample (K));
 351                      Do_Mult_Div (X, Y);
 352                      if Failure_Detected then
 353                         return;   -- minimize flood of error messages
 354                      end if;
 355                   end loop;
 356                end loop;
 357             end loop;  -- J
 358          end loop;  -- I
 359       end Mult_Div_Check;
 360
 361
 362       procedure Do_Test is
 363       begin
 364          Special_Values;
 365          Mult_Div_Check;
 366       end Do_Test;
 367    end Float_Check;
 368
 369    -----------------------------------------------------------------------
 370    -----------------------------------------------------------------------
 371    -- check the floating point type with the most digits
 372
 373    package A_Long_Float_Check is
 374       type A_Long_Float is digits System.Max_Digits;
 375       subtype Real is A_Long_Float;
 376       procedure Do_Test;
 377    end A_Long_Float_Check;
 378
 379    package body A_Long_Float_Check is
 380
 381       package Complex_Types is new
 382            Ada.Numerics.Generic_Complex_Types (Real);
 383       use Complex_Types;
 384
 385       -- keep track if an accuracy failure has occurred so the test
 386       -- can be short-circuited to avoid thousands of error messages.
 387       Failure_Detected : Boolean := False;
 388
 389       Mult_MBE : constant Real := 5.0;
 390       Divide_MBE : constant Real := 13.0;
 391
 392
 393       procedure Check (Actual, Expected : Complex;
 394                        Test_Name : String;
 395                        MBE : Real) is
 396          Rel_Error : Real;
 397          Abs_Error : Real;
 398          Max_Error : Real;
 399       begin
 400          -- In the case where the expected result is very small or 0
 401          -- we compute the maximum error as a multiple of Model_Epsilon instead
 402          -- of Model_Epsilon and Expected.
 403          Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon;
 404          Abs_Error := MBE * Real'Model_Epsilon;
 405          if Rel_Error > Abs_Error then
 406             Max_Error := Rel_Error;
 407          else
 408             Max_Error := Abs_Error;
 409          end if;
 410
 411          if abs (Actual.Re - Expected.Re) > Max_Error then
 412             Failure_Detected := True;
 413             Report.Failed (Test_Name &
 414                            " actual.re: " & Real'Image (Actual.Re) &
 415                            " expected.re: " & Real'Image (Expected.Re) &
 416                            " difference.re " &
 417                            Real'Image (Actual.Re - Expected.Re) &
 418                            " mre:" & Real'Image (Max_Error) );
 419          elsif Verbose then
 420             if Actual = Expected then
 421                Report.Comment (Test_Name & " exact result for real part");
 422             else
 423                Report.Comment (Test_Name & " passed for real part");
 424             end if;
 425          end if;
 426
 427          Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon;
 428          if Rel_Error > Abs_Error then
 429             Max_Error := Rel_Error;
 430          else
 431             Max_Error := Abs_Error;
 432          end if;
 433          if abs (Actual.Im - Expected.Im) > Max_Error then
 434             Failure_Detected := True;
 435             Report.Failed (Test_Name &
 436                            " actual.im: " & Real'Image (Actual.Im) &
 437                            " expected.im: " & Real'Image (Expected.Im) &
 438                            " difference.im " &
 439                            Real'Image (Actual.Im - Expected.Im) &
 440                            " mre:" & Real'Image (Max_Error) );
 441          elsif Verbose then
 442             if Actual = Expected then
 443                Report.Comment (Test_Name & " exact result for imaginary part");
 444             else
 445                Report.Comment (Test_Name & " passed for imaginary part");
 446             end if;
 447          end if;
 448       end Check;
 449
 450
 451       procedure Special_Values is
 452       begin
 453
 454          --- test 1 ---
 455          declare
 456             T : constant := (Real'Machine_EMax - 1) / 2;
 457             Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
 458             Expected : Complex := (0.0, 0.0);
 459             X : Complex := (0.0, 0.0);
 460             Y : Complex := (Big, Big);
 461             Z : Complex;
 462          begin
 463             Z := X * Y;
 464             Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)",
 465                    Mult_MBE);
 466             Z := Y * X;
 467             Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)",
 468                    Mult_MBE);
 469          exception
 470             when Constraint_Error =>
 471                Report.Failed ("Constraint_Error raised in test 1");
 472             when others =>
 473                Report.Failed ("exception in test 1");
 474          end;
 475
 476          --- test 2 ---
 477          declare
 478             T : constant := Real'Model_EMin + 1;
 479             Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
 480             U : Complex := (Tiny, Tiny);
 481             X : Complex := (0.0, 0.0);
 482             Expected : Complex := (0.0, 0.0);
 483             Z : Complex;
 484          begin
 485             Z := U * X;
 486             Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)",
 487                    Mult_MBE);
 488          exception
 489             when Constraint_Error =>
 490                Report.Failed ("Constraint_Error raised in test 2");
 491             when others =>
 492                Report.Failed ("exception in test 2");
 493          end;
 494
 495          --- test 3 ---
 496          declare
 497             T : constant := (Real'Machine_EMax - 1) / 2;
 498             Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
 499             B : Complex := (Big, Big);
 500             X : Complex := (0.0, 0.0);
 501             Z : Complex;
 502          begin
 503             if Real'Machine_Overflows then
 504                Z := B / X;
 505                Report.Failed ("test 3 - Constraint_Error not raised");
 506                Check (Z, Z, "not executed - optimizer thwarting", 0.0);
 507             end if;
 508          exception
 509             when Constraint_Error => null;  -- expected
 510             when others =>
 511                Report.Failed ("exception in test 3");
 512          end;
 513
 514          --- test 4 ---
 515          declare
 516             T : constant := Real'Model_EMin + 1;
 517             Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
 518             U : Complex := (Tiny, Tiny);
 519             X : Complex := (0.0, 0.0);
 520             Z : Complex;
 521          begin
 522             if Real'Machine_Overflows then
 523                Z := U / X;
 524                Report.Failed ("test 4 - Constraint_Error not raised");
 525                Check (Z, Z, "not executed - optimizer thwarting", 0.0);
 526             end if;
 527          exception
 528             when Constraint_Error => null;  -- expected
 529             when others =>
 530                Report.Failed ("exception in test 4");
 531          end;
 532
 533
 534          --- test 5 ---
 535          declare
 536             X : Complex := (Sqrt2, Sqrt2);
 537             Z : Complex;
 538             Expected : constant Complex := (0.0, 4.0);
 539          begin
 540             Z := X * X;
 541             Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)",
 542                    Mult_MBE);
 543          exception
 544             when Constraint_Error =>
 545                Report.Failed ("Constraint_Error raised in test 5");
 546             when others =>
 547                Report.Failed ("exception in test 5");
 548          end;
 549
 550          --- test 6 ---
 551          declare
 552             X : Complex := Sqrt3 - Sqrt3 * i;
 553             Z : Complex;
 554             Expected : constant Complex := (0.0, -6.0);
 555          begin
 556             Z := X * X;
 557             Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)",
 558                    Mult_MBE);
 559          exception
 560             when Constraint_Error =>
 561                Report.Failed ("Constraint_Error raised in test 6");
 562             when others =>
 563                Report.Failed ("exception in test 6");
 564          end;
 565
 566          --- test 7 ---
 567          declare
 568             X : Complex := Sqrt2 + Sqrt2 * i;
 569             Y : Complex := Sqrt2 - Sqrt2 * i;
 570             Z : Complex;
 571             Expected : constant Complex := 0.0 + i;
 572          begin
 573             Z := X / Y;
 574             Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)",
 575                    Divide_MBE);
 576          exception
 577             when Constraint_Error =>
 578                Report.Failed ("Constraint_Error raised in test 7");
 579             when others =>
 580                Report.Failed ("exception in test 7");
 581          end;
 582       end Special_Values;
 583
 584
 585       procedure Do_Mult_Div (X, Y : Complex) is
 586          Z : Complex;
 587          Args : constant String :=
 588            "X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " &
 589            "Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ;
 590       begin
 591          Z := (X * X) / X;
 592          Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE);
 593          Z := (X * Y) / X;
 594          Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE);
 595          Z := (X * Y) / Y;
 596          Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE);
 597       exception
 598          when Constraint_Error =>
 599             Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args);
 600          when others =>
 601             Report.Failed ("exception in Do_Mult_Div for " & Args);
 602       end Do_Mult_Div;
 603
 604       -- select complex values X and Y where the real and imaginary
 605       -- parts are selected from the ranges (1/radix..1) and
 606       -- (1..radix).  This translates into quite a few combinations.
 607       procedure Mult_Div_Check is
 608          Samples : constant := 17;
 609          Radix : constant Real := Real(Real'Machine_Radix);
 610          Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix);
 611          Low_Sample : Real;  -- (1/radix .. 1)
 612          High_Sample : Real; -- (1 .. radix)
 613          Sample : array (1..2) of Real;
 614          X, Y : Complex;
 615       begin
 616          for I in 1 .. Samples loop
 617             Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) +
 618                           Inv_Radix;
 619             Sample (1) := Low_Sample;
 620             for J in 1 .. Samples loop
 621                High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) +
 622                               Radix;
 623                Sample (2) := High_Sample;
 624                for K in 1 .. 2 loop
 625                   for L in 1 .. 2 loop
 626                      X := Complex'(Sample (K), Sample (L));
 627                      Y := Complex'(Sample (L), Sample (K));
 628                      Do_Mult_Div (X, Y);
 629                      if Failure_Detected then
 630                         return;   -- minimize flood of error messages
 631                      end if;
 632                   end loop;
 633                end loop;
 634             end loop;  -- J
 635          end loop;  -- I
 636       end Mult_Div_Check;
 637
 638
 639       procedure Do_Test is
 640       begin
 641          Special_Values;
 642          Mult_Div_Check;
 643       end Do_Test;
 644    end A_Long_Float_Check;
 645
 646    -----------------------------------------------------------------------
 647    -----------------------------------------------------------------------
 648
 649    package Non_Generic_Check is
 650       subtype Real is Float;
 651       procedure Do_Test;
 652    end Non_Generic_Check;
 653
 654    package body Non_Generic_Check is
 655
 656       use Ada.Numerics.Complex_Types;
 657
 658       -- keep track if an accuracy failure has occurred so the test
 659       -- can be short-circuited to avoid thousands of error messages.
 660       Failure_Detected : Boolean := False;
 661
 662       Mult_MBE : constant Real := 5.0;
 663       Divide_MBE : constant Real := 13.0;
 664
 665
 666       procedure Check (Actual, Expected : Complex;
 667                        Test_Name : String;
 668                        MBE : Real) is
 669          Rel_Error : Real;
 670          Abs_Error : Real;
 671          Max_Error : Real;
 672       begin
 673          -- In the case where the expected result is very small or 0
 674          -- we compute the maximum error as a multiple of Model_Epsilon instead
 675          -- of Model_Epsilon and Expected.
 676          Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon;
 677          Abs_Error := MBE * Real'Model_Epsilon;
 678          if Rel_Error > Abs_Error then
 679             Max_Error := Rel_Error;
 680          else
 681             Max_Error := Abs_Error;
 682          end if;
 683
 684          if abs (Actual.Re - Expected.Re) > Max_Error then
 685             Failure_Detected := True;
 686             Report.Failed (Test_Name &
 687                            " actual.re: " & Real'Image (Actual.Re) &
 688                            " expected.re: " & Real'Image (Expected.Re) &
 689                            " difference.re " &
 690                            Real'Image (Actual.Re - Expected.Re) &
 691                            " mre:" & Real'Image (Max_Error) );
 692          elsif Verbose then
 693             if Actual = Expected then
 694                Report.Comment (Test_Name & " exact result for real part");
 695             else
 696                Report.Comment (Test_Name & " passed for real part");
 697             end if;
 698          end if;
 699
 700          Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon;
 701          if Rel_Error > Abs_Error then
 702             Max_Error := Rel_Error;
 703          else
 704             Max_Error := Abs_Error;
 705          end if;
 706          if abs (Actual.Im - Expected.Im) > Max_Error then
 707             Failure_Detected := True;
 708             Report.Failed (Test_Name &
 709                            " actual.im: " & Real'Image (Actual.Im) &
 710                            " expected.im: " & Real'Image (Expected.Im) &
 711                            " difference.im " &
 712                            Real'Image (Actual.Im - Expected.Im) &
 713                            " mre:" & Real'Image (Max_Error) );
 714          elsif Verbose then
 715             if Actual = Expected then
 716                Report.Comment (Test_Name & " exact result for imaginary part");
 717             else
 718                Report.Comment (Test_Name & " passed for imaginary part");
 719             end if;
 720          end if;
 721       end Check;
 722
 723
 724       procedure Special_Values is
 725       begin
 726
 727          --- test 1 ---
 728          declare
 729             T : constant := (Real'Machine_EMax - 1) / 2;
 730             Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
 731             Expected : Complex := (0.0, 0.0);
 732             X : Complex := (0.0, 0.0);
 733             Y : Complex := (Big, Big);
 734             Z : Complex;
 735          begin
 736             Z := X * Y;
 737             Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)",
 738                    Mult_MBE);
 739             Z := Y * X;
 740             Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)",
 741                    Mult_MBE);
 742          exception
 743             when Constraint_Error =>
 744                Report.Failed ("Constraint_Error raised in test 1");
 745             when others =>
 746                Report.Failed ("exception in test 1");
 747          end;
 748
 749          --- test 2 ---
 750          declare
 751             T : constant := Real'Model_EMin + 1;
 752             Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
 753             U : Complex := (Tiny, Tiny);
 754             X : Complex := (0.0, 0.0);
 755             Expected : Complex := (0.0, 0.0);
 756             Z : Complex;
 757          begin
 758             Z := U * X;
 759             Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)",
 760                    Mult_MBE);
 761          exception
 762             when Constraint_Error =>
 763                Report.Failed ("Constraint_Error raised in test 2");
 764             when others =>
 765                Report.Failed ("exception in test 2");
 766          end;
 767
 768          --- test 3 ---
 769          declare
 770             T : constant := (Real'Machine_EMax - 1) / 2;
 771             Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
 772             B : Complex := (Big, Big);
 773             X : Complex := (0.0, 0.0);
 774             Z : Complex;
 775          begin
 776             if Real'Machine_Overflows then
 777                Z := B / X;
 778                Report.Failed ("test 3 - Constraint_Error not raised");
 779                Check (Z, Z, "not executed - optimizer thwarting", 0.0);
 780             end if;
 781          exception
 782             when Constraint_Error => null;  -- expected
 783             when others =>
 784                Report.Failed ("exception in test 3");
 785          end;
 786
 787          --- test 4 ---
 788          declare
 789             T : constant := Real'Model_EMin + 1;
 790             Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
 791             U : Complex := (Tiny, Tiny);
 792             X : Complex := (0.0, 0.0);
 793             Z : Complex;
 794          begin
 795             if Real'Machine_Overflows then
 796                Z := U / X;
 797                Report.Failed ("test 4 - Constraint_Error not raised");
 798                Check (Z, Z, "not executed - optimizer thwarting", 0.0);
 799             end if;
 800          exception
 801             when Constraint_Error => null;  -- expected
 802             when others =>
 803                Report.Failed ("exception in test 4");
 804          end;
 805
 806
 807          --- test 5 ---
 808          declare
 809             X : Complex := (Sqrt2, Sqrt2);
 810             Z : Complex;
 811             Expected : constant Complex := (0.0, 4.0);
 812          begin
 813             Z := X * X;
 814             Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)",
 815                    Mult_MBE);
 816          exception
 817             when Constraint_Error =>
 818                Report.Failed ("Constraint_Error raised in test 5");
 819             when others =>
 820                Report.Failed ("exception in test 5");
 821          end;
 822
 823          --- test 6 ---
 824          declare
 825             X : Complex := Sqrt3 - Sqrt3 * i;
 826             Z : Complex;
 827             Expected : constant Complex := (0.0, -6.0);
 828          begin
 829             Z := X * X;
 830             Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)",
 831                    Mult_MBE);
 832          exception
 833             when Constraint_Error =>
 834                Report.Failed ("Constraint_Error raised in test 6");
 835             when others =>
 836                Report.Failed ("exception in test 6");
 837          end;
 838
 839          --- test 7 ---
 840          declare
 841             X : Complex := Sqrt2 + Sqrt2 * i;
 842             Y : Complex := Sqrt2 - Sqrt2 * i;
 843             Z : Complex;
 844             Expected : constant Complex := 0.0 + i;
 845          begin
 846             Z := X / Y;
 847             Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)",
 848                    Divide_MBE);
 849          exception
 850             when Constraint_Error =>
 851                Report.Failed ("Constraint_Error raised in test 7");
 852             when others =>
 853                Report.Failed ("exception in test 7");
 854          end;
 855       end Special_Values;
 856
 857
 858       procedure Do_Mult_Div (X, Y : Complex) is
 859          Z : Complex;
 860          Args : constant String :=
 861            "X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " &
 862            "Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ;
 863       begin
 864          Z := (X * X) / X;
 865          Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE);
 866          Z := (X * Y) / X;
 867          Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE);
 868          Z := (X * Y) / Y;
 869          Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE);
 870       exception
 871          when Constraint_Error =>
 872             Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args);
 873          when others =>
 874             Report.Failed ("exception in Do_Mult_Div for " & Args);
 875       end Do_Mult_Div;
 876
 877       -- select complex values X and Y where the real and imaginary
 878       -- parts are selected from the ranges (1/radix..1) and
 879       -- (1..radix).  This translates into quite a few combinations.
 880       procedure Mult_Div_Check is
 881          Samples : constant := 17;
 882          Radix : constant Real := Real(Real'Machine_Radix);
 883          Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix);
 884          Low_Sample : Real;  -- (1/radix .. 1)
 885          High_Sample : Real; -- (1 .. radix)
 886          Sample : array (1..2) of Real;
 887          X, Y : Complex;
 888       begin
 889          for I in 1 .. Samples loop
 890             Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) +
 891                           Inv_Radix;
 892             Sample (1) := Low_Sample;
 893             for J in 1 .. Samples loop
 894                High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) +
 895                               Radix;
 896                Sample (2) := High_Sample;
 897                for K in 1 .. 2 loop
 898                   for L in 1 .. 2 loop
 899                      X := Complex'(Sample (K), Sample (L));
 900                      Y := Complex'(Sample (L), Sample (K));
 901                      Do_Mult_Div (X, Y);
 902                      if Failure_Detected then
 903                         return;   -- minimize flood of error messages
 904                      end if;
 905                   end loop;
 906                end loop;
 907             end loop;  -- J
 908          end loop;  -- I
 909       end Mult_Div_Check;
 910
 911
 912       procedure Do_Test is
 913       begin
 914          Special_Values;
 915          Mult_Div_Check;
 916       end Do_Test;
 917    end Non_Generic_Check;
 918
 919    -----------------------------------------------------------------------
 920    -----------------------------------------------------------------------
 921
 922 begin
 923    Report.Test ("CXG2008",
 924                 "Check the accuracy of the complex multiplication and" &
 925                 " division operators");
 926
 927    if Verbose then
 928       Report.Comment ("checking Standard.Float");
 929    end if;
 930
 931    Float_Check.Do_Test;
 932
 933    if Verbose then
 934       Report.Comment ("checking a digits" &
 935                       Integer'Image (System.Max_Digits) &
 936                       " floating point type");
 937    end if;
 938
 939    A_Long_Float_Check.Do_Test;
 940
 941    if Verbose then
 942       Report.Comment ("checking non-generic package");
 943    end if;
 944
 945    Non_Generic_Check.Do_Test;
 946
 947    Report.Result;
 948 end CXG2008;