?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Dead
[official-gcc.git] / gomp-20050608-branch / gcc / testsuite / ada / acats / tests / cxg / cxg2008.a
blob58cf367f61c8843ac5dbf3ed4f4dc759ebbe85dc
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;
Mirror of the offical gcc git repository hosted at gcc.gnu.org