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

   1 -- C490002.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 an ordinary fixed
  29 --      point type that is not a descendant of a formal scalar type, the value
  30 --      is rounded to the nearest integral multiple of the small of T if
  31 --      T'Machine_Rounds is true, and is truncated otherwise. Check that if
  32 --      rounding is performed, and the value is exactly halfway between two
  33 --      multiples of the small, one of the two multiples of small is used.
  34 --
  35 -- TEST DESCRIPTION:
  36 --      The test obtains an integral multiple M1 of the small of an ordinary
  37 --      fixed point subtype S by dividing a real literal by S'Small, and then
  38 --      truncating the result using 'Truncation. It then obtains an adjacent
  39 --      multiple M2 of the small by using S'Succ (or S'Pred). It then
  40 --      constructs values which lie between these multiples: one (A) which is
  41 --      closer to M1, one (B) which is exactly halfway between M1 and M2, and
  42 --      one (C) which is closer to M2. This is done for both positive and
  43 --      negative multiples of the small.
  44 --
  45 --      Let M1 be closer to zero than M2. Then if S'Machine_Rounds is true,
  46 --      C must be rounded to M2, A must be rounded to M1, and B must be rounded
  47 --      to either M1 or M2. If S'Machine_Rounds is false, all the values must
  48 --      be truncated to M1.
  49 --
  50 --      A, B, and C are constructed using the following static expressions:
  51 --
  52 --         A: constant S := M1 + (M2 - M1)/Z; -- Z slightly more than 2.0.
  53 --         B: constant S := M1 + (M2 - M1)/Z; -- Z equals 2.0.
  54 --         C: constant S := M1 + (M2 - M1)/Z; -- Z slightly less than 2.0.
  55 --
  56 --      Since these are static expressions, they must be evaluated exactly,
  57 --      and no rounding may occur until the final result is calculated.
  58 --
  59 --      The checks for equality between the members of (A, B, C) and (M1, M2)
  60 --      are performed at run-time within the body of a subprogram.
  61 --
  62 --      The test performs additional checks that the rounding performed on
  63 --      real literals is consistent for ordinary fixed point subtypes. A
  64 --      named number (initialized with a literal) is assigned to a constant of
  65 --      a fixed point subtype S. The same literal is then passed to a
  66 --      subprogram, along with the constant, and an equality check is
  67 --      performed within the body of the subprogram.
  68 --
  69 --
  70 -- CHANGE HISTORY:
  71 --      26 Sep 95   SAIC    Initial prerelease version.
  72 --
  73 --!
  74
  75 package C490002_0 is
  76
  77    type My_Fix is delta 0.0625 range -1000.0 .. 1000.0;
  78
  79    Small : constant := My_Fix'Small;                      -- Named number.
  80
  81    procedure Fixed_Subtest (A, B: in My_Fix; Msg: in String);
  82
  83    procedure Fixed_Subtest (A, B, C: in My_Fix; Msg: in String);
  84
  85
  86 --
  87 -- Positive cases:
  88 --
  89
  90    --  |----|-------------|-----------------|-------------------|-----------|
  91    --  |    |             |                 |                   |           |
  92    --  0   P_M1  Less_Pos_Than_Half  Pos_Exactly_Half  More_Pos_Than_Half  P_M2
  93
  94
  95    Positive_Real  : constant := 0.11433;          -- Named number.
  96    Pos_Multiplier : constant := Float'Truncation(Positive_Real/Small);
  97
  98    -- Pos_Multiplier is the number of integral multiples of small contained
  99    -- in Positive_Real. P_M1 is thus the largest integral multiple of
 100    -- small less than or equal to Positive_Real. Note that since Positive_Real
 101    -- is a named number and not a fixed point object, P_M1 is generated
 102    -- without assuming that rounding is performed correctly for fixed point
 103    -- subtypes.
 104
 105    Positive_Fixed : constant My_Fix := Positive_Real;
 106
 107    P_M1 : constant My_Fix := Pos_Multiplier * Small;
 108    P_M2 : constant My_Fix := My_Fix'Succ(P_M1);
 109
 110    -- P_M1 and P_M2 are adjacent multiples of the small of My_Fix. Note that
 111    -- 0.11433 either equals P_M1 (if it is an integral multiple of the small)
 112    -- or lies between P_M1 and P_M2 (since truncation was forced in
 113    -- generating Pos_Multiplier). It is not certain, however, exactly where
 114    -- it lies between them (halfway, less than halfway, more than halfway).
 115    -- This fact is irrelevant to the test.
 116
 117
 118    -- The following entities are used to verify that rounding is performed
 119    -- according to the value of 'Machine_Rounds. If language rules are
 120    -- obeyed, the intermediate expressions in the following static
 121    -- initialization expressions will not be rounded; all calculations will
 122    -- be performed exactly. The final result, however, will be rounded to
 123    -- an integral multiple of the small (either P_M1 or P_M2, depending on the
 124    -- value of My_Fix'Machine_Rounds). Thus, the value of each constant below
 125    -- will equal that of P_M1 or P_M2.
 126
 127    Less_Pos_Than_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/2.050);
 128    Pos_Exactly_Half   : constant My_Fix := P_M1 + ((P_M2 - P_M1)/2.000);
 129    More_Pos_Than_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/1.975);
 130
 131
 132 --
 133 -- Negative cases:
 134 --
 135
 136    --  -|-------------|-----------------|-------------------|-----------|----|
 137    --   |             |                 |                   |           |    |
 138    --  N_M2  More_Neg_Than_Half  Neg_Exactly_Half  Less_Neg_Than_Half  N_M1  0
 139
 140
 141    -- The descriptions for the positive cases above apply to the negative
 142    -- cases below as well. Note that, for N_M2, 'Pred is used rather than
 143    -- 'Succ. Thus, N_M2 is further from 0.0 (i.e. more negative) than N_M1.
 144
 145    Negative_Real  : constant := -467.13988;       -- Named number.
 146    Neg_Multiplier : constant := Float'Truncation(Negative_Real/Small);
 147
 148    Negative_Fixed : constant My_Fix := Negative_Real;
 149
 150    N_M1 : constant My_Fix := Neg_Multiplier * Small;
 151    N_M2 : constant My_Fix := My_Fix'Pred(N_M1);
 152
 153    More_Neg_Than_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/1.980);
 154    Neg_Exactly_Half   : constant My_Fix := N_M1 + ((N_M2 - N_M1)/2.000);
 155    Less_Neg_Than_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/2.033);
 156
 157 end C490002_0;
 158
 159
 160      --==================================================================--
 161
 162
 163 with TCTouch;
 164 package body C490002_0 is
 165
 166    procedure Fixed_Subtest (A, B: in My_Fix; Msg: in String) is
 167    begin
 168        TCTouch.Assert (A = B, Msg);
 169    end Fixed_Subtest;
 170
 171    procedure Fixed_Subtest (A, B, C: in My_Fix; Msg: in String) is
 172    begin
 173        TCTouch.Assert (A = B or A = C, Msg);
 174    end Fixed_Subtest;
 175
 176 end C490002_0;
 177
 178
 179      --==================================================================--
 180
 181
 182 with C490002_0;  -- Fixed point support.
 183 use  C490002_0;
 184
 185 with Report;
 186 procedure C490002 is
 187 begin
 188    Report.Test ("C490002", "Rounding of real static expressions: " &
 189                 "ordinary fixed point subtypes");
 190
 191
 192    -- Literal cases: If the named numbers used to initialize Positive_Fixed
 193    -- and Negative_Fixed are rounded to an integral multiple of the small
 194    -- prior to assignment (as expected), then Positive_Fixed and
 195    -- Negative_Fixed are already integral multiples of the small, and
 196    -- equal either P_M1 or P_M2 (resp., N_M1 or N_M2). An equality check
 197    -- can determine in which direction rounding occurred. For example:
 198    --
 199    --        if (Positive_Fixed = P_M1) then -- Rounding was toward 0.0.
 200    --
 201    -- Check here that the rounding direction is consistent for literals:
 202
 203    if (Positive_Fixed = P_M1) then
 204       Fixed_Subtest (0.11433, P_M1, "Positive Fixed: literal");
 205    else
 206       Fixed_Subtest (0.11433, P_M2, "Positive Fixed: literal");
 207    end if;
 208
 209    if (Negative_Fixed = N_M1) then
 210       Fixed_Subtest (-467.13988, N_M1, "Negative Fixed: literal");
 211    else
 212       Fixed_Subtest (-467.13988, N_M2, "Negative Fixed: literal");
 213    end if;
 214
 215
 216    -- Now check that rounding is performed correctly for values between
 217    -- multiples of the small, according to the value of 'Machine_Rounds:
 218
 219    if My_Fix'Machine_Rounds then
 220       Fixed_Subtest (Pos_Exactly_Half,   P_M1, P_M2, "Positive Fixed: = half");
 221       Fixed_Subtest (More_Pos_Than_Half, P_M2, "Positive Fixed: > half");
 222       Fixed_Subtest (Less_Pos_Than_Half, P_M1, "Positive Fixed: < half");
 223
 224       Fixed_Subtest (Neg_Exactly_Half,   N_M1, N_M2, "Negative Fixed: = half");
 225       Fixed_Subtest (More_Neg_Than_Half, N_M2, "Negative Fixed: > half");
 226       Fixed_Subtest (Less_Neg_Than_Half, N_M1, "Negative Fixed: < half");
 227    else
 228       Fixed_Subtest (Pos_Exactly_Half,   P_M1, "Positive Fixed: = half");
 229       Fixed_Subtest (More_Pos_Than_Half, P_M1, "Positive Fixed: > half");
 230       Fixed_Subtest (Less_Pos_Than_Half, P_M1, "Positive Fixed: < half");
 231
 232       Fixed_Subtest (Neg_Exactly_Half,   N_M1, "Negative Fixed: = half");
 233       Fixed_Subtest (More_Neg_Than_Half, N_M1, "Negative Fixed: > half");
 234       Fixed_Subtest (Less_Neg_Than_Half, N_M1, "Negative Fixed: < half");
 235    end if;
 236
 237
 238    Report.Result;
 239 end C490002;