cxa5015.a

来自「linux下编程用 编译软件」· A 代码 · 共 343 行

-- CXA5015.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 following representation-oriented attributes are 
--      available and that the produce correct results: 
--      'Denorm, 'Signed_Zeros, 'Exponent 'Fraction, 'Compose, 'Scaling, 
--      'Floor, 'Ceiling, 'Rounding, 'Unbiased_Rounding, 'Truncation, 
--      'Remainder, 'Adjacent, 'Copy_Sign, 'Leading_Part, 'Machine, and 
--      'Model_Small.
--      
-- TEST DESCRIPTION:
--      This test checks whether certain attributes of floating point types
--      are available from an implementation.  Where attribute correctness 
--      can be verified in a straight forward manner, the appropriate checks 
--      are included here.  However, this test is not intended to ensure the 
--      correctness of the results returned from all of the attributes 
--      examined in this test; that process will occur in the tests of the 
--      Numerics_Annex. 
--      
--       
-- CHANGE HISTORY:
--      26 Jun 95   SAIC    Initial prerelease version.
--      29 Apr 96   SAIC    Incorporated reviewer comments for ACVC 2.1.
--      01 DEC 97   EDS     Fix value for checking the S'Adjacent attribute
--!

with Report;

procedure CXA5015 is

   subtype Float_Subtype   is Float range -10.0..10.0;
   type    Derived_Float_1 is digits  8;
   type    Derived_Float_2 is new Derived_Float_1 range -10.0..10.0E10;

   use type Float, Float_Subtype, Derived_Float_1, Derived_Float_2;

   TC_Boolean   : Boolean;
   TC_Float     : Float;
   TC_SFloat    : Float_Subtype;
   TC_DFloat_1  : Derived_Float_1;
   TC_DFloat_2  : Derived_Float_2;
   TC_Tolerance : Float := 0.001;

   function Not_Equal (Actual_Result, Expected_Result, Tolerance : Float)
     return Boolean is
   begin
      return abs(Actual_Result - Expected_Result) > Tolerance;
   end Not_Equal;


begin

   Report.Test ("CXA5015", "Check that certain representation-oriented " &
                           "attributes are available and that they "     &
                           "produce correct results");

   -- New Representation-Oriented Attributes.
   --
   -- Check the S'Denorm attribute.

   TC_Boolean := Float'Denorm;
   TC_Boolean := Float_Subtype'Denorm;
   TC_Boolean := Derived_Float_1'Denorm;
   TC_Boolean := Derived_Float_2'Denorm;


   -- Check the S'Signed_Zeroes attribute.

   TC_Boolean := Float'Signed_Zeros;
   TC_Boolean := Float_Subtype'Signed_Zeros;
   TC_Boolean := Derived_Float_1'Signed_Zeros;
   TC_Boolean := Derived_Float_2'Signed_Zeros;


   -- New Primitive Function Attributes.
   --
   -- Check the S'Exponent attribute.

   TC_Float    := 0.5;
   TC_SFloat   := 0.99;
   TC_DFloat_1 := 2.45;
   TC_DFloat_2 := 2.65;

   if Float'Exponent(TC_Float) > Float_Subtype'Exponent(TC_SFloat) or
      Float'Exponent(TC_Float) > 2
   then
      Report.Failed("Incorrect result from the 'Exponent attribute");
   end if;


   -- Check the S'Fraction attribute.

   if Not_Equal 
        (Float'Fraction(TC_Float), 
         TC_Float * Float(Float'Machine_Radix)**(-Float'Exponent(TC_Float)),
         TC_Tolerance)
   then
      Report.Failed("Incorrect result from the 'Fraction attribute - 1");
   end if;

   if Float'Fraction(TC_Float) < 
      (1.0/Float(Float'Machine_Radix)) - TC_Tolerance  or
      Float'Fraction(TC_Float) >= 1.0 - TC_Tolerance    
   then
      Report.Failed("Incorrect result from the 'Fraction attribute - 2");
   end if;


   -- Check the S'Compose attribute.

   if Not_Equal 
       (Float'Compose(TC_Float, 3),
        TC_Float * Float(Float'Machine_Radix)**(3-Float'Exponent(TC_Float)),
        TC_Tolerance)
   then
      Report.Failed("Incorrect result from the 'Compose attribute");
   end if;


   -- Check the S'Scaling attribute.

   if Not_Equal 
        (Float'Scaling(TC_Float, 2),
         TC_Float * Float(Float'Machine_Radix)**2,
         TC_Tolerance)
   then
      Report.Failed("Incorrect result from the 'Scaling attribute");
   end if;


   -- Check the S'Floor attribute.

   TC_Float    :=  0.99;
   TC_SFloat   :=  1.00;
   TC_DFloat_1 :=  2.50;
   TC_DFloat_2 := -2.50;

   if Float'Floor(TC_Float)               /=  0.0  or
      Float_Subtype'Floor(TC_SFloat)      /=  1.0  or
      Derived_Float_1'Floor(TC_DFloat_1)  /=  2.0  or
      Derived_Float_2'Floor(TC_DFloat_2)  /= -3.0
   then
      Report.Failed("Incorrect result from the 'Floor attribute");
   end if;


   -- Check the S'Ceiling attribute.

   TC_Float    :=  0.99;
   TC_SFloat   :=  1.00;
   TC_DFloat_1 :=  2.50;
   TC_DFloat_2 := -2.99;

   if Float'Ceiling(TC_Float)               /=  1.0  or
      Float_Subtype'Ceiling(TC_SFloat)      /=  1.0  or
      Derived_Float_1'Ceiling(TC_DFloat_1)  /=  3.0  or
      Derived_Float_2'Ceiling(TC_DFloat_2)  /= -2.0
   then
      Report.Failed("Incorrect result from the 'Ceiling attribute");
   end if;


   -- Check the S'Rounding attribute.

   TC_Float    :=  0.49;
   TC_SFloat   :=  1.00;
   TC_DFloat_1 :=  2.50;
   TC_DFloat_2 := -2.50;

   if Float'Rounding(TC_Float)               /=  0.0  or
      Float_Subtype'Rounding(TC_SFloat)      /=  1.0  or
      Derived_Float_1'Rounding(TC_DFloat_1)  /=  3.0  or
      Derived_Float_2'Rounding(TC_DFloat_2)  /= -3.0
   then
      Report.Failed("Incorrect result from the 'Rounding attribute");
   end if;


   -- Check the S'Unbiased_Rounding attribute.

   TC_Float    :=  0.50;
   TC_SFloat   :=  1.50;
   TC_DFloat_1 :=  2.50;
   TC_DFloat_2 := -2.50;

   if Float'Unbiased_Rounding(TC_Float)               /=  0.0  or
      Float_Subtype'Unbiased_Rounding(TC_SFloat)      /=  2.0  or
      Derived_Float_1'Unbiased_Rounding(TC_DFloat_1)  /=  2.0  or
      Derived_Float_2'Unbiased_Rounding(TC_DFloat_2)  /= -2.0
   then
      Report.Failed("Incorrect result from the 'Unbiased_Rounding " &
                    "attribute");
   end if;


   -- Check the S'Truncation attribute.

   TC_Float    := -0.99;
   TC_SFloat   :=  1.50;
   TC_DFloat_1 :=  2.99;
   TC_DFloat_2 := -2.50;

   if Float'Truncation(TC_Float)               /=  0.0  or
      Float_Subtype'Truncation(TC_SFloat)      /=  1.0  or
      Derived_Float_1'Truncation(TC_DFloat_1)  /=  2.0  or
      Derived_Float_2'Truncation(TC_DFloat_2)  /= -2.0
   then
      Report.Failed("Incorrect result from the 'Truncation attribute");
   end if;


   -- Check the S'Remainder attribute.

   TC_Float    :=  9.0;
   TC_SFloat   :=  7.5;
   TC_DFloat_1 :=  5.0;
   TC_DFloat_2 :=  8.0;

   if Float'Remainder(TC_Float, 2.0)                /=  1.0  or
      Float_Subtype'Remainder(TC_SFloat, 3.0)       /=  1.5  or
      Derived_Float_1'Remainder(TC_DFloat_1, 2.0)   /=  1.0  or
      Derived_Float_2'Remainder(TC_DFloat_2, 4.0)   /=  0.0
   then
      Report.Failed("Incorrect result from the 'Remainder attribute");
   end if;


   -- Check the S'Adjacent attribute.

   TC_Float    :=  4.0;
   TC_SFloat   := -1.0;

   if Float'Adjacent(TC_Float, TC_Float)           /=  TC_Float  or
      Float_Subtype'Adjacent(TC_SFloat, -1.0)      /=  TC_SFloat 
   then
      Report.Failed("Incorrect result from the 'Adjacent attribute");
   end if;


   -- Check the S'Copy_Sign attribute.

   TC_Float    :=  0.0;
   TC_SFloat   := -1.0;
   TC_DFloat_1 :=  5.0;
   TC_DFloat_2 := -2.5;

   if Float'Copy_Sign(TC_Float, -2.0)               /=  0.0  or
      Float_Subtype'Copy_Sign(TC_SFloat, 4.0)       /=  1.0  or
      Derived_Float_1'Copy_Sign(TC_DFloat_1, -2.0)  /= -5.0  or
      Derived_Float_2'Copy_Sign(TC_DFloat_2, -2.0)  /= -2.5
   then
      Report.Failed("Incorrect result from the 'Copy_Sign attribute");
   end if;


   -- Check the S'Leading_Part attribute.

   TC_Float    :=  0.0;
   TC_SFloat   := -1.0;
   TC_DFloat_1 :=  5.88;
   TC_DFloat_2 := -2.52;

   -- Leading part obtained in the variables.
   TC_Float    :=  Float'Leading_Part(TC_Float, 2);
   TC_SFloat   :=  Float_Subtype'Leading_Part(TC_SFloat, 2);
   TC_DFloat_1 :=  Derived_Float_1'Leading_Part(TC_DFloat_1, 2);
   TC_DFloat_2 :=  Derived_Float_2'Leading_Part(TC_DFloat_2, 2);

   -- Checking for the leading part of the variables at this point should
   -- produce the same values.
   if Float'Leading_Part(TC_Float, 2)              /= TC_Float    or
      Float_Subtype'Leading_Part(TC_SFloat, 2)     /= TC_SFloat   or
      Derived_Float_1'Leading_Part(TC_DFloat_1, 2) /= TC_DFloat_1 or
      Derived_Float_2'Leading_Part(TC_DFloat_2, 2) /= TC_DFloat_2
   then
      Report.Failed("Incorrect result from the 'Leading_Part attribute");
   end if;


   -- Check the S'Machine attribute.

   TC_Float    :=  0.0;
   TC_SFloat   := -1.0;
   TC_DFloat_1 :=  5.88;
   TC_DFloat_2 := -2.52;

   -- Closest machine number obtained in the variables.
   TC_Float    :=  Float'Machine(TC_Float);
   TC_SFloat   :=  Float_Subtype'Machine(TC_SFloat);
   TC_DFloat_1 :=  Derived_Float_1'Machine(TC_DFloat_1);
   TC_DFloat_2 :=  Derived_Float_2'Machine(TC_DFloat_2);

   -- Checking for the closest machine number to each of the variables at 
   -- this point should produce the same values.
   if Float'Machine(TC_Float)              /= TC_Float    or
      Float_Subtype'Machine(TC_SFloat)     /= TC_SFloat   or
      Derived_Float_1'Machine(TC_DFloat_1) /= TC_DFloat_1 or
      Derived_Float_2'Machine(TC_DFloat_2) /= TC_DFloat_2
   then
      Report.Failed("Incorrect result from the 'Machine attribute");
   end if;


   -- New Model-Oriented Attributes.
   --
   -- Check the S'Model_Small attribute.

   if Not_Equal 
        (Float'Model_Small,
         Float(Float'Machine_Radix)**(Float'Model_Emin-1),
         TC_Tolerance)
   then
      Report.Failed("Incorrect result from the 'Model_Small attribute");
   end if;


   Report.Result;

end CXA5015;