gomp-20050608-branch/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a

   1 -- CXA5015.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- OBJECTIVE:
  27 --      Check that the following representation-oriented attributes are
  28 --      available and that the produce correct results:
  29 --      'Denorm, 'Signed_Zeros, 'Exponent 'Fraction, 'Compose, 'Scaling,
  30 --      'Floor, 'Ceiling, 'Rounding, 'Unbiased_Rounding, 'Truncation,
  31 --      'Remainder, 'Adjacent, 'Copy_Sign, 'Leading_Part, 'Machine, and
  32 --      'Model_Small.
  33 --
  34 -- TEST DESCRIPTION:
  35 --      This test checks whether certain attributes of floating point types
  36 --      are available from an implementation.  Where attribute correctness
  37 --      can be verified in a straight forward manner, the appropriate checks
  38 --      are included here.  However, this test is not intended to ensure the
  39 --      correctness of the results returned from all of the attributes
  40 --      examined in this test; that process will occur in the tests of the
  41 --      Numerics_Annex.
  42 --
  43 --
  44 -- CHANGE HISTORY:
  45 --      26 Jun 95   SAIC    Initial prerelease version.
  46 --      29 Apr 96   SAIC    Incorporated reviewer comments for ACVC 2.1.
  47 --      01 DEC 97   EDS     Fix value for checking the S'Adjacent attribute
  48 --!
  49
  50 with Report;
  51
  52 procedure CXA5015 is
  53
  54    subtype Float_Subtype   is Float range -10.0..10.0;
  55    type    Derived_Float_1 is digits  8;
  56    type    Derived_Float_2 is new Derived_Float_1 range -10.0..10.0E10;
  57
  58    use type Float, Float_Subtype, Derived_Float_1, Derived_Float_2;
  59
  60    TC_Boolean   : Boolean;
  61    TC_Float     : Float;
  62    TC_SFloat    : Float_Subtype;
  63    TC_DFloat_1  : Derived_Float_1;
  64    TC_DFloat_2  : Derived_Float_2;
  65    TC_Tolerance : Float := 0.001;
  66
  67    function Not_Equal (Actual_Result, Expected_Result, Tolerance : Float)
  68      return Boolean is
  69    begin
  70       return abs(Actual_Result - Expected_Result) > Tolerance;
  71    end Not_Equal;
  72
  73
  74 begin
  75
  76    Report.Test ("CXA5015", "Check that certain representation-oriented " &
  77                            "attributes are available and that they "     &
  78                            "produce correct results");
  79
  80    -- New Representation-Oriented Attributes.
  81    --
  82    -- Check the S'Denorm attribute.
  83
  84    TC_Boolean := Float'Denorm;
  85    TC_Boolean := Float_Subtype'Denorm;
  86    TC_Boolean := Derived_Float_1'Denorm;
  87    TC_Boolean := Derived_Float_2'Denorm;
  88
  89
  90    -- Check the S'Signed_Zeroes attribute.
  91
  92    TC_Boolean := Float'Signed_Zeros;
  93    TC_Boolean := Float_Subtype'Signed_Zeros;
  94    TC_Boolean := Derived_Float_1'Signed_Zeros;
  95    TC_Boolean := Derived_Float_2'Signed_Zeros;
  96
  97
  98    -- New Primitive Function Attributes.
  99    --
 100    -- Check the S'Exponent attribute.
 101
 102    TC_Float    := 0.5;
 103    TC_SFloat   := 0.99;
 104    TC_DFloat_1 := 2.45;
 105    TC_DFloat_2 := 2.65;
 106
 107    if Float'Exponent(TC_Float) > Float_Subtype'Exponent(TC_SFloat) or
 108       Float'Exponent(TC_Float) > 2
 109    then
 110       Report.Failed("Incorrect result from the 'Exponent attribute");
 111    end if;
 112
 113
 114    -- Check the S'Fraction attribute.
 115
 116    if Not_Equal
 117         (Float'Fraction(TC_Float),
 118          TC_Float * Float(Float'Machine_Radix)**(-Float'Exponent(TC_Float)),
 119          TC_Tolerance)
 120    then
 121       Report.Failed("Incorrect result from the 'Fraction attribute - 1");
 122    end if;
 123
 124    if Float'Fraction(TC_Float) <
 125       (1.0/Float(Float'Machine_Radix)) - TC_Tolerance  or
 126       Float'Fraction(TC_Float) >= 1.0 - TC_Tolerance
 127    then
 128       Report.Failed("Incorrect result from the 'Fraction attribute - 2");
 129    end if;
 130
 131
 132    -- Check the S'Compose attribute.
 133
 134    if Not_Equal
 135        (Float'Compose(TC_Float, 3),
 136         TC_Float * Float(Float'Machine_Radix)**(3-Float'Exponent(TC_Float)),
 137         TC_Tolerance)
 138    then
 139       Report.Failed("Incorrect result from the 'Compose attribute");
 140    end if;
 141
 142
 143    -- Check the S'Scaling attribute.
 144
 145    if Not_Equal
 146         (Float'Scaling(TC_Float, 2),
 147          TC_Float * Float(Float'Machine_Radix)**2,
 148          TC_Tolerance)
 149    then
 150       Report.Failed("Incorrect result from the 'Scaling attribute");
 151    end if;
 152
 153
 154    -- Check the S'Floor attribute.
 155
 156    TC_Float    :=  0.99;
 157    TC_SFloat   :=  1.00;
 158    TC_DFloat_1 :=  2.50;
 159    TC_DFloat_2 := -2.50;
 160
 161    if Float'Floor(TC_Float)               /=  0.0  or
 162       Float_Subtype'Floor(TC_SFloat)      /=  1.0  or
 163       Derived_Float_1'Floor(TC_DFloat_1)  /=  2.0  or
 164       Derived_Float_2'Floor(TC_DFloat_2)  /= -3.0
 165    then
 166       Report.Failed("Incorrect result from the 'Floor attribute");
 167    end if;
 168
 169
 170    -- Check the S'Ceiling attribute.
 171
 172    TC_Float    :=  0.99;
 173    TC_SFloat   :=  1.00;
 174    TC_DFloat_1 :=  2.50;
 175    TC_DFloat_2 := -2.99;
 176
 177    if Float'Ceiling(TC_Float)               /=  1.0  or
 178       Float_Subtype'Ceiling(TC_SFloat)      /=  1.0  or
 179       Derived_Float_1'Ceiling(TC_DFloat_1)  /=  3.0  or
 180       Derived_Float_2'Ceiling(TC_DFloat_2)  /= -2.0
 181    then
 182       Report.Failed("Incorrect result from the 'Ceiling attribute");
 183    end if;
 184
 185
 186    -- Check the S'Rounding attribute.
 187
 188    TC_Float    :=  0.49;
 189    TC_SFloat   :=  1.00;
 190    TC_DFloat_1 :=  2.50;
 191    TC_DFloat_2 := -2.50;
 192
 193    if Float'Rounding(TC_Float)               /=  0.0  or
 194       Float_Subtype'Rounding(TC_SFloat)      /=  1.0  or
 195       Derived_Float_1'Rounding(TC_DFloat_1)  /=  3.0  or
 196       Derived_Float_2'Rounding(TC_DFloat_2)  /= -3.0
 197    then
 198       Report.Failed("Incorrect result from the 'Rounding attribute");
 199    end if;
 200
 201
 202    -- Check the S'Unbiased_Rounding attribute.
 203
 204    TC_Float    :=  0.50;
 205    TC_SFloat   :=  1.50;
 206    TC_DFloat_1 :=  2.50;
 207    TC_DFloat_2 := -2.50;
 208
 209    if Float'Unbiased_Rounding(TC_Float)               /=  0.0  or
 210       Float_Subtype'Unbiased_Rounding(TC_SFloat)      /=  2.0  or
 211       Derived_Float_1'Unbiased_Rounding(TC_DFloat_1)  /=  2.0  or
 212       Derived_Float_2'Unbiased_Rounding(TC_DFloat_2)  /= -2.0
 213    then
 214       Report.Failed("Incorrect result from the 'Unbiased_Rounding " &
 215                     "attribute");
 216    end if;
 217
 218
 219    -- Check the S'Truncation attribute.
 220
 221    TC_Float    := -0.99;
 222    TC_SFloat   :=  1.50;
 223    TC_DFloat_1 :=  2.99;
 224    TC_DFloat_2 := -2.50;
 225
 226    if Float'Truncation(TC_Float)               /=  0.0  or
 227       Float_Subtype'Truncation(TC_SFloat)      /=  1.0  or
 228       Derived_Float_1'Truncation(TC_DFloat_1)  /=  2.0  or
 229       Derived_Float_2'Truncation(TC_DFloat_2)  /= -2.0
 230    then
 231       Report.Failed("Incorrect result from the 'Truncation attribute");
 232    end if;
 233
 234
 235    -- Check the S'Remainder attribute.
 236
 237    TC_Float    :=  9.0;
 238    TC_SFloat   :=  7.5;
 239    TC_DFloat_1 :=  5.0;
 240    TC_DFloat_2 :=  8.0;
 241
 242    if Float'Remainder(TC_Float, 2.0)                /=  1.0  or
 243       Float_Subtype'Remainder(TC_SFloat, 3.0)       /=  1.5  or
 244       Derived_Float_1'Remainder(TC_DFloat_1, 2.0)   /=  1.0  or
 245       Derived_Float_2'Remainder(TC_DFloat_2, 4.0)   /=  0.0
 246    then
 247       Report.Failed("Incorrect result from the 'Remainder attribute");
 248    end if;
 249
 250
 251    -- Check the S'Adjacent attribute.
 252
 253    TC_Float    :=  4.0;
 254    TC_SFloat   := -1.0;
 255
 256    if Float'Adjacent(TC_Float, TC_Float)           /=  TC_Float  or
 257       Float_Subtype'Adjacent(TC_SFloat, -1.0)      /=  TC_SFloat
 258    then
 259       Report.Failed("Incorrect result from the 'Adjacent attribute");
 260    end if;
 261
 262
 263    -- Check the S'Copy_Sign attribute.
 264
 265    TC_Float    :=  0.0;
 266    TC_SFloat   := -1.0;
 267    TC_DFloat_1 :=  5.0;
 268    TC_DFloat_2 := -2.5;
 269
 270    if Float'Copy_Sign(TC_Float, -2.0)               /=  0.0  or
 271       Float_Subtype'Copy_Sign(TC_SFloat, 4.0)       /=  1.0  or
 272       Derived_Float_1'Copy_Sign(TC_DFloat_1, -2.0)  /= -5.0  or
 273       Derived_Float_2'Copy_Sign(TC_DFloat_2, -2.0)  /= -2.5
 274    then
 275       Report.Failed("Incorrect result from the 'Copy_Sign attribute");
 276    end if;
 277
 278
 279    -- Check the S'Leading_Part attribute.
 280
 281    TC_Float    :=  0.0;
 282    TC_SFloat   := -1.0;
 283    TC_DFloat_1 :=  5.88;
 284    TC_DFloat_2 := -2.52;
 285
 286    -- Leading part obtained in the variables.
 287    TC_Float    :=  Float'Leading_Part(TC_Float, 2);
 288    TC_SFloat   :=  Float_Subtype'Leading_Part(TC_SFloat, 2);
 289    TC_DFloat_1 :=  Derived_Float_1'Leading_Part(TC_DFloat_1, 2);
 290    TC_DFloat_2 :=  Derived_Float_2'Leading_Part(TC_DFloat_2, 2);
 291
 292    -- Checking for the leading part of the variables at this point should
 293    -- produce the same values.
 294    if Float'Leading_Part(TC_Float, 2)              /= TC_Float    or
 295       Float_Subtype'Leading_Part(TC_SFloat, 2)     /= TC_SFloat   or
 296       Derived_Float_1'Leading_Part(TC_DFloat_1, 2) /= TC_DFloat_1 or
 297       Derived_Float_2'Leading_Part(TC_DFloat_2, 2) /= TC_DFloat_2
 298    then
 299       Report.Failed("Incorrect result from the 'Leading_Part attribute");
 300    end if;
 301
 302
 303    -- Check the S'Machine attribute.
 304
 305    TC_Float    :=  0.0;
 306    TC_SFloat   := -1.0;
 307    TC_DFloat_1 :=  5.88;
 308    TC_DFloat_2 := -2.52;
 309
 310    -- Closest machine number obtained in the variables.
 311    TC_Float    :=  Float'Machine(TC_Float);
 312    TC_SFloat   :=  Float_Subtype'Machine(TC_SFloat);
 313    TC_DFloat_1 :=  Derived_Float_1'Machine(TC_DFloat_1);
 314    TC_DFloat_2 :=  Derived_Float_2'Machine(TC_DFloat_2);
 315
 316    -- Checking for the closest machine number to each of the variables at
 317    -- this point should produce the same values.
 318    if Float'Machine(TC_Float)              /= TC_Float    or
 319       Float_Subtype'Machine(TC_SFloat)     /= TC_SFloat   or
 320       Derived_Float_1'Machine(TC_DFloat_1) /= TC_DFloat_1 or
 321       Derived_Float_2'Machine(TC_DFloat_2) /= TC_DFloat_2
 322    then
 323       Report.Failed("Incorrect result from the 'Machine attribute");
 324    end if;
 325
 326
 327    -- New Model-Oriented Attributes.
 328    --
 329    -- Check the S'Model_Small attribute.
 330
 331    if Not_Equal
 332         (Float'Model_Small,
 333          Float(Float'Machine_Radix)**(Float'Model_Emin-1),
 334          TC_Tolerance)
 335    then
 336       Report.Failed("Incorrect result from the 'Model_Small attribute");
 337    end if;
 338
 339
 340    Report.Result;
 341
 342 end CXA5015;