-- 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. -- 17 Apr 14 RLB Repaired calculation of Model_Mantisaa to reflect -- correction in Amendment. -- --! -- 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) - corrected by Amendment 1. -- 'Model_Mantissa >= ceiling(d*log(10)/log(radix))+g, -- where g is 0 for decimal machines and 1 for other machines. Min_Mantissa_Digits := Integer ( Real'Ceiling ( Real(Real'Digits) * Log(10.0) / Log(Real(Real'Machine_Radix)) ) ); if Real'Machine_Radix = 10 or else Real'Machine_Radix = 100 or else Real'Machine_Radix = 1000 then 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) & "] (decimal)"); end if; else if Real'Model_Mantissa < (Min_Mantissa_Digits+1) then Report.Failed ("Model_Mantissa [" & Integer'Image (Real'Model_Mantissa) & "] < minimum mantissa digits [" & Integer'Image (Min_Mantissa_Digits+1) & "]"); end if; 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;