| -- 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; |
