1-- CXG2003.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 sqrt function returns 28-- results that are within the error bound allowed. 29-- 30-- TEST DESCRIPTION: 31-- This test contains three test packages that are almost 32-- identical. The first two packages differ only in the 33-- floating point type that is being tested. The first 34-- and third package differ only in whether the generic 35-- elementary functions package or the pre-instantiated 36-- package is used. 37-- The test package is not generic so that the arguments 38-- and expected results for some of the test values 39-- can be expressed as universal real instead of being 40-- computed at runtime. 41-- 42-- SPECIAL REQUIREMENTS 43-- The Strict Mode for the numerical accuracy must be 44-- selected. The method by which this mode is selected 45-- is implementation dependent. 46-- 47-- APPLICABILITY CRITERIA: 48-- This test applies only to implementations supporting the 49-- Numerics Annex. 50-- This test only applies to the Strict Mode for numerical 51-- accuracy. 52-- 53-- 54-- CHANGE HISTORY: 55-- 2 FEB 96 SAIC Initial release for 2.1 56-- 18 AUG 96 SAIC Made Check consistent with other tests. 57-- 58--! 59 60with System; 61with Report; 62with Ada.Numerics.Generic_Elementary_Functions; 63with Ada.Numerics.Elementary_Functions; 64procedure CXG2003 is 65 Verbose : constant Boolean := False; 66 67 package Float_Check is 68 subtype Real is Float; 69 procedure Do_Test; 70 end Float_Check; 71 72 package body Float_Check is 73 package Elementary_Functions is new 74 Ada.Numerics.Generic_Elementary_Functions (Real); 75 function Sqrt (X : Real) return Real renames 76 Elementary_Functions.Sqrt; 77 function Log (X : Real) return Real renames 78 Elementary_Functions.Log; 79 function Exp (X : Real) return Real renames 80 Elementary_Functions.Exp; 81 82 -- The default Maximum Relative Error is the value specified 83 -- in the LRM. 84 Default_MRE : constant Real := 2.0; 85 86 procedure Check (Actual, Expected : Real; 87 Test_Name : String; 88 MRE : Real := Default_MRE) is 89 Rel_Error : Real; 90 Abs_Error : Real; 91 Max_Error : Real; 92 begin 93 -- In the case where the expected result is very small or 0 94 -- we compute the maximum error as a multiple of Model_Epsilon instead 95 -- of Model_Epsilon and Expected. 96 Rel_Error := MRE * abs Expected * Real'Model_Epsilon; 97 Abs_Error := MRE * Real'Model_Epsilon; 98 if Rel_Error > Abs_Error then 99 Max_Error := Rel_Error; 100 else 101 Max_Error := Abs_Error; 102 end if; 103 104 if abs (Actual - Expected) > Max_Error then 105 Report.Failed (Test_Name & 106 " actual: " & Real'Image (Actual) & 107 " expected: " & Real'Image (Expected) & 108 " difference: " & 109 Real'Image (Actual - Expected) & 110 " mre:" & Real'Image (Max_Error) ); 111 elsif Verbose then 112 if Actual = Expected then 113 Report.Comment (Test_Name & " exact result"); 114 else 115 Report.Comment (Test_Name & " passed"); 116 end if; 117 end if; 118 end Check; 119 120 121 procedure Argument_Range_Check (A, B : Real; 122 Test : String) is 123 -- test a logarithmically distributed selection of 124 -- arguments selected from the range A to B. 125 X : Real; 126 Expected : Real; 127 Y : Real; 128 C : Real := Log(B/A); 129 Max_Samples : constant := 1000; 130 131 begin 132 for I in 1..Max_Samples loop 133 Expected := A * Exp(C * Real (I) / Real (Max_Samples)); 134 X := Expected * Expected; 135 Y := Sqrt (X); 136 137 -- note that since the expected value is computed, we 138 -- must take the error in that computation into account. 139 Check (Y, Expected, 140 "test " & Test & " -" & 141 Integer'Image (I) & 142 " of argument range", 143 3.0); 144 end loop; 145 exception 146 when Constraint_Error => 147 Report.Failed 148 ("Constraint_Error raised in argument range check"); 149 when others => 150 Report.Failed ("exception in argument range check"); 151 end Argument_Range_Check; 152 153 procedure Do_Test is 154 begin 155 156 --- test 1 --- 157 declare 158 T : constant := (Real'Machine_EMax - 1) / 2; 159 X : constant := (1.0 * Real'Machine_Radix) ** (2 * T); 160 Expected : constant := (1.0 * Real'Machine_Radix) ** T; 161 Y : Real; 162 begin 163 Y := Sqrt (X); 164 Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))"); 165 exception 166 when Constraint_Error => 167 Report.Failed ("Constraint_Error raised in test 1"); 168 when others => 169 Report.Failed ("exception in test 1"); 170 end; 171 172 --- test 2 --- 173 declare 174 T : constant := (Real'Model_EMin + 1) / 2; 175 X : constant := (1.0 * Real'Machine_Radix) ** (2 * T); 176 Expected : constant := (1.0 * Real'Machine_Radix) ** T; 177 Y : Real; 178 begin 179 Y := Sqrt (X); 180 Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))"); 181 exception 182 when Constraint_Error => 183 Report.Failed ("Constraint_Error raised in test 2"); 184 when others => 185 Report.Failed ("exception in test 2"); 186 end; 187 188 --- test 3 --- 189 declare 190 X : constant := 1.0; 191 Expected : constant := 1.0; 192 Y : Real; 193 begin 194 Y := Sqrt(X); 195 Check (Y, Expected, "test 3 -- sqrt(1.0)", 196 0.0); -- no error allowed 197 exception 198 when Constraint_Error => 199 Report.Failed ("Constraint_Error raised in test 3"); 200 when others => 201 Report.Failed ("exception in test 3"); 202 end; 203 204 --- test 4 --- 205 declare 206 X : constant := 0.0; 207 Expected : constant := 0.0; 208 Y : Real; 209 begin 210 Y := Sqrt(X); 211 Check (Y, Expected, "test 4 -- sqrt(0.0)", 212 0.0); -- no error allowed 213 exception 214 when Constraint_Error => 215 Report.Failed ("Constraint_Error raised in test 4"); 216 when others => 217 Report.Failed ("exception in test 4"); 218 end; 219 220 --- test 5 --- 221 declare 222 X : constant := -1.0; 223 Y : Real; 224 begin 225 Y := Sqrt(X); 226 -- the following code should not be executed. 227 -- The call to Check is to keep the call to Sqrt from 228 -- appearing to be dead code. 229 Check (Y, -1.0, "test 5 -- sqrt(-1)" ); 230 Report.Failed ("test 5 - argument_error expected"); 231 exception 232 when Constraint_Error => 233 Report.Failed ("Constraint_Error raised in test 5"); 234 when Ada.Numerics.Argument_Error => 235 if Verbose then 236 Report.Comment ("test 5 correctly got argument_error"); 237 end if; 238 when others => 239 Report.Failed ("exception in test 5"); 240 end; 241 242 --- test 6 --- 243 declare 244 X : constant := Ada.Numerics.Pi ** 2; 245 Expected : constant := Ada.Numerics.Pi; 246 Y : Real; 247 begin 248 Y := Sqrt (X); 249 Check (Y, Expected, "test 6 -- sqrt(pi**2)"); 250 exception 251 when Constraint_Error => 252 Report.Failed ("Constraint_Error raised in test 6"); 253 when others => 254 Report.Failed ("exception in test 6"); 255 end; 256 257 --- test 7 & 8 --- 258 Argument_Range_Check (1.0/Sqrt(Real(Real'Machine_Radix)), 259 1.0, 260 "7"); 261 Argument_Range_Check (1.0, 262 Sqrt(Real(Real'Machine_Radix)), 263 "8"); 264 end Do_Test; 265 end Float_Check; 266 267 ----------------------------------------------------------------------- 268 ----------------------------------------------------------------------- 269 -- check the floating point type with the most digits 270 type A_Long_Float is digits System.Max_Digits; 271 272 273 package A_Long_Float_Check is 274 subtype Real is A_Long_Float; 275 procedure Do_Test; 276 end A_Long_Float_Check; 277 278 package body A_Long_Float_Check is 279 package Elementary_Functions is new 280 Ada.Numerics.Generic_Elementary_Functions (Real); 281 function Sqrt (X : Real) return Real renames 282 Elementary_Functions.Sqrt; 283 function Log (X : Real) return Real renames 284 Elementary_Functions.Log; 285 function Exp (X : Real) return Real renames 286 Elementary_Functions.Exp; 287 288 -- The default Maximum Relative Error is the value specified 289 -- in the LRM. 290 Default_MRE : constant Real := 2.0; 291 292 procedure Check (Actual, Expected : Real; 293 Test_Name : String; 294 MRE : Real := Default_MRE) is 295 Rel_Error : Real; 296 Abs_Error : Real; 297 Max_Error : Real; 298 begin 299 -- In the case where the expected result is very small or 0 300 -- we compute the maximum error as a multiple of Model_Epsilon instead 301 -- of Model_Epsilon and Expected. 302 Rel_Error := MRE * abs Expected * Real'Model_Epsilon; 303 Abs_Error := MRE * Real'Model_Epsilon; 304 if Rel_Error > Abs_Error then 305 Max_Error := Rel_Error; 306 else 307 Max_Error := Abs_Error; 308 end if; 309 310 if abs (Actual - Expected) > Max_Error then 311 Report.Failed (Test_Name & 312 " actual: " & Real'Image (Actual) & 313 " expected: " & Real'Image (Expected) & 314 " difference: " & 315 Real'Image (Actual - Expected) & 316 " mre:" & Real'Image (Max_Error) ); 317 elsif Verbose then 318 if Actual = Expected then 319 Report.Comment (Test_Name & " exact result"); 320 else 321 Report.Comment (Test_Name & " passed"); 322 end if; 323 end if; 324 end Check; 325 326 327 procedure Argument_Range_Check (A, B : Real; 328 Test : String) is 329 -- test a logarithmically distributed selection of 330 -- arguments selected from the range A to B. 331 X : Real; 332 Expected : Real; 333 Y : Real; 334 C : Real := Log(B/A); 335 Max_Samples : constant := 1000; 336 337 begin 338 for I in 1..Max_Samples loop 339 Expected := A * Exp(C * Real (I) / Real (Max_Samples)); 340 X := Expected * Expected; 341 Y := Sqrt (X); 342 343 -- note that since the expected value is computed, we 344 -- must take the error in that computation into account. 345 Check (Y, Expected, 346 "test " & Test & " -" & 347 Integer'Image (I) & 348 " of argument range", 349 3.0); 350 end loop; 351 exception 352 when Constraint_Error => 353 Report.Failed 354 ("Constraint_Error raised in argument range check"); 355 when others => 356 Report.Failed ("exception in argument range check"); 357 end Argument_Range_Check; 358 359 360 procedure Do_Test is 361 begin 362 363 --- test 1 --- 364 declare 365 T : constant := (Real'Machine_EMax - 1) / 2; 366 X : constant := (1.0 * Real'Machine_Radix) ** (2 * T); 367 Expected : constant := (1.0 * Real'Machine_Radix) ** T; 368 Y : Real; 369 begin 370 Y := Sqrt (X); 371 Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))"); 372 exception 373 when Constraint_Error => 374 Report.Failed ("Constraint_Error raised in test 1"); 375 when others => 376 Report.Failed ("exception in test 1"); 377 end; 378 379 --- test 2 --- 380 declare 381 T : constant := (Real'Model_EMin + 1) / 2; 382 X : constant := (1.0 * Real'Machine_Radix) ** (2 * T); 383 Expected : constant := (1.0 * Real'Machine_Radix) ** T; 384 Y : Real; 385 begin 386 Y := Sqrt (X); 387 Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))"); 388 exception 389 when Constraint_Error => 390 Report.Failed ("Constraint_Error raised in test 2"); 391 when others => 392 Report.Failed ("exception in test 2"); 393 end; 394 395 --- test 3 --- 396 declare 397 X : constant := 1.0; 398 Expected : constant := 1.0; 399 Y : Real; 400 begin 401 Y := Sqrt(X); 402 Check (Y, Expected, "test 3 -- sqrt(1.0)", 403 0.0); -- no error allowed 404 exception 405 when Constraint_Error => 406 Report.Failed ("Constraint_Error raised in test 3"); 407 when others => 408 Report.Failed ("exception in test 3"); 409 end; 410 411 --- test 4 --- 412 declare 413 X : constant := 0.0; 414 Expected : constant := 0.0; 415 Y : Real; 416 begin 417 Y := Sqrt(X); 418 Check (Y, Expected, "test 4 -- sqrt(0.0)", 419 0.0); -- no error allowed 420 exception 421 when Constraint_Error => 422 Report.Failed ("Constraint_Error raised in test 4"); 423 when others => 424 Report.Failed ("exception in test 4"); 425 end; 426 427 --- test 5 --- 428 declare 429 X : constant := -1.0; 430 Y : Real; 431 begin 432 Y := Sqrt(X); 433 -- the following code should not be executed. 434 -- The call to Check is to keep the call to Sqrt from 435 -- appearing to be dead code. 436 Check (Y, -1.0, "test 5 -- sqrt(-1)" ); 437 Report.Failed ("test 5 - argument_error expected"); 438 exception 439 when Constraint_Error => 440 Report.Failed ("Constraint_Error raised in test 5"); 441 when Ada.Numerics.Argument_Error => 442 if Verbose then 443 Report.Comment ("test 5 correctly got argument_error"); 444 end if; 445 when others => 446 Report.Failed ("exception in test 5"); 447 end; 448 449 --- test 6 --- 450 declare 451 X : constant := Ada.Numerics.Pi ** 2; 452 Expected : constant := Ada.Numerics.Pi; 453 Y : Real; 454 begin 455 Y := Sqrt (X); 456 Check (Y, Expected, "test 6 -- sqrt(pi**2)"); 457 exception 458 when Constraint_Error => 459 Report.Failed ("Constraint_Error raised in test 6"); 460 when others => 461 Report.Failed ("exception in test 6"); 462 end; 463 464 --- test 7 & 8 --- 465 Argument_Range_Check (1.0/Sqrt(Real(Real'Machine_Radix)), 466 1.0, 467 "7"); 468 Argument_Range_Check (1.0, 469 Sqrt(Real(Real'Machine_Radix)), 470 "8"); 471 end Do_Test; 472 end A_Long_Float_Check; 473 474 ----------------------------------------------------------------------- 475 ----------------------------------------------------------------------- 476 477 package Non_Generic_Check is 478 procedure Do_Test; 479 end Non_Generic_Check; 480 481 package body Non_Generic_Check is 482 package EF renames 483 Ada.Numerics.Elementary_Functions; 484 subtype Real is Float; 485 486 -- The default Maximum Relative Error is the value specified 487 -- in the LRM. 488 Default_MRE : constant Real := 2.0; 489 490 procedure Check (Actual, Expected : Real; 491 Test_Name : String; 492 MRE : Real := Default_MRE) is 493 Rel_Error : Real; 494 Abs_Error : Real; 495 Max_Error : Real; 496 begin 497 -- In the case where the expected result is very small or 0 498 -- we compute the maximum error as a multiple of Model_Epsilon instead 499 -- of Model_Epsilon and Expected. 500 Rel_Error := MRE * abs Expected * Real'Model_Epsilon; 501 Abs_Error := MRE * Real'Model_Epsilon; 502 if Rel_Error > Abs_Error then 503 Max_Error := Rel_Error; 504 else 505 Max_Error := Abs_Error; 506 end if; 507 508 if abs (Actual - Expected) > Max_Error then 509 Report.Failed (Test_Name & 510 " actual: " & Real'Image (Actual) & 511 " expected: " & Real'Image (Expected) & 512 " difference: " & 513 Real'Image (Actual - Expected) & 514 " mre:" & Real'Image (Max_Error) ); 515 elsif Verbose then 516 if Actual = Expected then 517 Report.Comment (Test_Name & " exact result"); 518 else 519 Report.Comment (Test_Name & " passed"); 520 end if; 521 end if; 522 end Check; 523 524 525 526 procedure Argument_Range_Check (A, B : Float; 527 Test : String) is 528 -- test a logarithmically distributed selection of 529 -- arguments selected from the range A to B. 530 X : Float; 531 Expected : Float; 532 Y : Float; 533 C : Float := EF.Log(B/A); 534 Max_Samples : constant := 1000; 535 536 begin 537 for I in 1..Max_Samples loop 538 Expected := A * EF.Exp(C * Float (I) / Float (Max_Samples)); 539 X := Expected * Expected; 540 Y := EF.Sqrt (X); 541 542 -- note that since the expected value is computed, we 543 -- must take the error in that computation into account. 544 Check (Y, Expected, 545 "test " & Test & " -" & 546 Integer'Image (I) & 547 " of argument range", 548 3.0); 549 end loop; 550 exception 551 when Constraint_Error => 552 Report.Failed 553 ("Constraint_Error raised in argument range check"); 554 when others => 555 Report.Failed ("exception in argument range check"); 556 end Argument_Range_Check; 557 558 559 procedure Do_Test is 560 begin 561 562 --- test 1 --- 563 declare 564 T : constant := (Float'Machine_EMax - 1) / 2; 565 X : constant := (1.0 * Float'Machine_Radix) ** (2 * T); 566 Expected : constant := (1.0 * Float'Machine_Radix) ** T; 567 Y : Float; 568 begin 569 Y := EF.Sqrt (X); 570 Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))"); 571 exception 572 when Constraint_Error => 573 Report.Failed ("Constraint_Error raised in test 1"); 574 when others => 575 Report.Failed ("exception in test 1"); 576 end; 577 578 --- test 2 --- 579 declare 580 T : constant := (Float'Model_EMin + 1) / 2; 581 X : constant := (1.0 * Float'Machine_Radix) ** (2 * T); 582 Expected : constant := (1.0 * Float'Machine_Radix) ** T; 583 Y : Float; 584 begin 585 Y := EF.Sqrt (X); 586 Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))"); 587 exception 588 when Constraint_Error => 589 Report.Failed ("Constraint_Error raised in test 2"); 590 when others => 591 Report.Failed ("exception in test 2"); 592 end; 593 594 --- test 3 --- 595 declare 596 X : constant := 1.0; 597 Expected : constant := 1.0; 598 Y : Float; 599 begin 600 Y := EF.Sqrt(X); 601 Check (Y, Expected, "test 3 -- sqrt(1.0)", 602 0.0); -- no error allowed 603 exception 604 when Constraint_Error => 605 Report.Failed ("Constraint_Error raised in test 3"); 606 when others => 607 Report.Failed ("exception in test 3"); 608 end; 609 610 --- test 4 --- 611 declare 612 X : constant := 0.0; 613 Expected : constant := 0.0; 614 Y : Float; 615 begin 616 Y := EF.Sqrt(X); 617 Check (Y, Expected, "test 4 -- sqrt(0.0)", 618 0.0); -- no error allowed 619 exception 620 when Constraint_Error => 621 Report.Failed ("Constraint_Error raised in test 4"); 622 when others => 623 Report.Failed ("exception in test 4"); 624 end; 625 626 --- test 5 --- 627 declare 628 X : constant := -1.0; 629 Y : Float; 630 begin 631 Y := EF.Sqrt(X); 632 -- the following code should not be executed. 633 -- The call to Check is to keep the call to Sqrt from 634 -- appearing to be dead code. 635 Check (Y, -1.0, "test 5 -- sqrt(-1)" ); 636 Report.Failed ("test 5 - argument_error expected"); 637 exception 638 when Constraint_Error => 639 Report.Failed ("Constraint_Error raised in test 5"); 640 when Ada.Numerics.Argument_Error => 641 if Verbose then 642 Report.Comment ("test 5 correctly got argument_error"); 643 end if; 644 when others => 645 Report.Failed ("exception in test 5"); 646 end; 647 648 --- test 6 --- 649 declare 650 X : constant := Ada.Numerics.Pi ** 2; 651 Expected : constant := Ada.Numerics.Pi; 652 Y : Float; 653 begin 654 Y := EF.Sqrt (X); 655 Check (Y, Expected, "test 6 -- sqrt(pi**2)"); 656 exception 657 when Constraint_Error => 658 Report.Failed ("Constraint_Error raised in test 6"); 659 when others => 660 Report.Failed ("exception in test 6"); 661 end; 662 663 --- test 7 & 8 --- 664 Argument_Range_Check (1.0/EF.Sqrt(Float(Float'Machine_Radix)), 665 1.0, 666 "7"); 667 Argument_Range_Check (1.0, 668 EF.Sqrt(Float(Float'Machine_Radix)), 669 "8"); 670 end Do_Test; 671 end Non_Generic_Check; 672 673 ----------------------------------------------------------------------- 674 ----------------------------------------------------------------------- 675 676begin 677 Report.Test ("CXG2003", 678 "Check the accuracy of the sqrt function"); 679 680 if Verbose then 681 Report.Comment ("checking Standard.Float"); 682 end if; 683 684 Float_Check.Do_Test; 685 686 if Verbose then 687 Report.Comment ("checking a digits" & 688 Integer'Image (System.Max_Digits) & 689 " floating point type"); 690 end if; 691 692 A_Long_Float_Check.Do_Test; 693 694 if Verbose then 695 Report.Comment ("checking non-generic package"); 696 end if; 697 698 Non_Generic_Check.Do_Test; 699 700 Report.Result; 701end CXG2003; 702