--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,322 @@
+-- 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;