gcc/testsuite/ada/acats/tests/c4/c490001.a

   1 -- C490001.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, for a real static expression that is not part of a larger
  28 --      static expression, and whose expected type T is a floating point type
  29 --      that is not a descendant of a formal scalar type, the value is rounded
  30 --      to the nearest machine number of T if T'Machine_Rounds is true, and is
  31 --      truncated otherwise. Check that if rounding is performed, and the value
  32 --      is exactly halfway between two machine numbers, one of the two machine
  33 --      numbers is used.
  34 --
  35 -- TEST DESCRIPTION:
  36 --      The test obtains a machine number M1 for a floating point subtype S by
  37 --      passing a real literal to S'Machine. It then obtains an adjacent
  38 --      machine number M2 by using S'Succ (or S'Pred). It then constructs
  39 --      values which lie between these two machine numbers: one (A) which is
  40 --      closer to M1, one (B) which is exactly halfway between M1 and M2, and
  41 --      one (C) which is closer to M2. This is done for both positive and
  42 --      negative machine numbers.
  43 --
  44 --      Let M1 be closer to zero than M2. Then if S'Machine_Rounds is true,
  45 --      C must be rounded to M2, A must be rounded to M1, and B must be rounded
  46 --      to either M1 or M2. If S'Machine_Rounds is false, all the values must
  47 --      be truncated to M1.
  48 --
  49 --      A, B, and C are constructed using the following static expressions:
  50 --
  51 --         A: constant S := M1 + (M2 - M1)*Z; -- Z slightly less than 0.5.
  52 --         B: constant S := M1 + (M2 - M1)*Z; -- Z equals 0.5.
  53 --         C: constant S := M1 + (M2 - M1)*Z; -- Z slightly more than 0.5.
  54 --
  55 --      Since these are static expressions, they must be evaluated exactly,
  56 --      and no rounding may occur until the final result is calculated.
  57 --
  58 --      The checks for equality between the members of (A, B, C) and (M1, M2)
  59 --      are performed at run-time within the body of a subprogram.
  60 --
  61 --      The test performs additional checks that the rounding performed on
  62 --      real literals is consistent for a floating point subtype. A literal is
  63 --      assigned to a constant of a floating point subtype S. The same literal
  64 --      is then passed to a subprogram, along with the constant, and an
  65 --      equality check is performed within the body of the subprogram.
  66 --
  67 --
  68 -- CHANGE HISTORY:
  69 --      25 Sep 95   SAIC    Initial prerelease version.
  70 --      25 May 01   RLB     Repaired to work with the repeal of the round away
  71 --                          rule by AI-268.
  72 --
  73 --!
  74
  75 with System;
  76 package C490001_0 is
  77
  78    type My_Flt is digits System.Max_Digits;
  79
  80    procedure Float_Subtest (A, B: in My_Flt; Msg: in String);
  81
  82    procedure Float_Subtest (A, B, C: in My_Flt; Msg: in String);
  83
  84
  85 --
  86 -- Positive cases:
  87 --
  88
  89    --  |----|-------------|-----------------|-------------------|-----------|
  90    --  |    |             |                 |                   |           |
  91    --  0   P_M1  Less_Pos_Than_Half  Pos_Exactly_Half  More_Pos_Than_Half  P_M2
  92
  93
  94    Positive_Float : constant My_Flt := 12.440193950021943;
  95
  96    -- The literal value 12.440193950021943 is rounded up or down to the
  97    -- nearest machine number of My_Flt when Positive_Float is initialized.
  98    -- The value of Positive_Float should therefore be a machine number, and
  99    -- the use of 'Machine in the initialization of P_M1 will be redundant for
 100    -- a correct implementation. It's done anyway to make certain that P_M1 is
 101    -- a machine number, independent of whether an implementation correctly
 102    -- performs rounding.
 103
 104    P_M1 : constant My_Flt := My_Flt'Machine(Positive_Float);
 105    P_M2 : constant My_Flt := My_Flt'Succ(P_M1);
 106
 107    -- P_M1 and P_M2 are adjacent machine numbers. Note that because it is not
 108    -- certain whether 12.440193950021943 is a machine number, nor whether
 109    -- 'Machine rounds it up or down, 12.440193950021943 may not lie between
 110    -- P_M1 and P_M2. The test does not depend on this information, however;
 111    -- the literal is only used as a "seed" to obtain the machine numbers.
 112
 113
 114    -- The following entities are used to verify that rounding is performed
 115    -- according to the value of 'Machine_Rounds. If language rules are
 116    -- obeyed, the intermediate expressions in the following static
 117    -- initialization expressions will not be rounded; all calculations will
 118    -- be performed exactly. The final result, however, will be rounded to
 119    -- a machine number (either P_M1 or P_M2, depending on the value of
 120    -- My_Flt'Machine_Rounds). Thus, the value of each constant below will
 121    -- equal that of P_M1 or P_M2.
 122
 123    Less_Pos_Than_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)*2.9/6.0);
 124    Pos_Exactly_Half   : constant My_Flt := P_M1 + ((P_M2 - P_M1)/2.0);
 125    More_Pos_Than_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)*4.6/9.0);
 126
 127
 128 --
 129 -- Negative cases:
 130 --
 131
 132    --  -|-------------|-----------------|-------------------|-----------|----|
 133    --   |             |                 |                   |           |    |
 134    --  N_M2  More_Neg_Than_Half  Neg_Exactly_Half  Less_Neg_Than_Half  N_M1  0
 135
 136
 137    -- The descriptions for the positive cases above apply to the negative
 138    -- cases below as well. Note that, for N_M2, 'Pred is used rather than
 139    -- 'Succ. Thus, N_M2 is further from 0.0 (i.e. more negative) than N_M1.
 140
 141    Negative_Float : constant My_Flt := -0.692074550952117;
 142
 143
 144    N_M1 : constant My_Flt := My_Flt'Machine(Negative_Float);
 145    N_M2 : constant My_Flt := My_Flt'Pred(N_M1);
 146
 147    More_Neg_Than_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)*4.1/8.0);
 148    Neg_Exactly_Half   : constant My_Flt := N_M1 + ((N_M2 - N_M1)/2.0);
 149    Less_Neg_Than_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)*2.4/5.0);
 150
 151 end C490001_0;
 152
 153
 154      --==================================================================--
 155
 156
 157 with TCTouch;
 158 package body C490001_0 is
 159
 160    procedure Float_Subtest (A, B: in My_Flt; Msg: in String) is
 161    begin
 162        TCTouch.Assert (A = B, Msg);
 163    end Float_Subtest;
 164
 165    procedure Float_Subtest (A, B, C: in My_Flt; Msg: in String) is
 166    begin
 167        TCTouch.Assert (A = B or A = C, Msg);
 168    end Float_Subtest;
 169
 170 end C490001_0;
 171
 172
 173      --==================================================================--
 174
 175
 176 with C490001_0;  -- Floating point support.
 177 use  C490001_0;
 178
 179 with Report;
 180 procedure C490001 is
 181 begin
 182    Report.Test ("C490001", "Rounding of real static expressions: " &
 183                 "floating point subtypes");
 184
 185
 186    -- Check that rounding direction is consistent for literals:
 187
 188    Float_Subtest (12.440193950021943, P_M1, "Positive Float: literal");
 189    Float_Subtest (-0.692074550952117, N_M1, "Negative Float: literal");
 190
 191
 192    -- Now check that rounding is performed correctly for values between
 193    -- machine numbers, according to the value of 'Machine_Rounds:
 194
 195    if My_Flt'Machine_Rounds then
 196       Float_Subtest (Pos_Exactly_Half,   P_M1, P_M2, "Positive Float: = half");
 197       Float_Subtest (More_Pos_Than_Half, P_M2, "Positive Float: > half");
 198       Float_Subtest (Less_Pos_Than_Half, P_M1, "Positive Float: < half");
 199
 200       Float_Subtest (Neg_Exactly_Half,   N_M1, N_M2, "Negative Float: = half");
 201       Float_Subtest (More_Neg_Than_Half, N_M2, "Negative Float: > half");
 202       Float_Subtest (Less_Neg_Than_Half, N_M1, "Negative Float: < half");
 203    else
 204       Float_Subtest (Pos_Exactly_Half,   P_M1, "Positive Float: = half");
 205       Float_Subtest (More_Pos_Than_Half, P_M1, "Positive Float: > half");
 206       Float_Subtest (Less_Pos_Than_Half, P_M1, "Positive Float: < half");
 207
 208       Float_Subtest (Neg_Exactly_Half,   N_M1, "Negative Float: = half");
 209       Float_Subtest (More_Neg_Than_Half, N_M1, "Negative Float: > half");
 210       Float_Subtest (Less_Neg_Than_Half, N_M1, "Negative Float: < half");
 211    end if;
 212
 213
 214    Report.Result;
 215 end C490001;