Subversion Repositories openrisc_me

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