gcc/testsuite/ada/acats/tests/c8/c840001.a

   1 -- C840001.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 the type determined by the subtype mark of a use type
  28 --      clause, the declaration of each primitive operator is use-visible
  29 --      within the scope of the clause, even if explicit operators with the
  30 --      same names as the type's operators are declared for the subtype. Check
  31 --      that a call to such an operator executes the body of the type's
  32 --      operation.
  33 --
  34 -- TEST DESCRIPTION:
  35 --      A type may declare a primitive operator, and a subtype of that type
  36 --      may overload the operator. If a use type clause names the subtype,
  37 --      it is the primitive operator of the type (not the subtype) which
  38 --      is made directly visible, and the primitive operator may be called
  39 --      unambiguously. Such a call executes the body of the type's operation.
  40 --
  41 --      In a package, declare a type for which a predefined operator is
  42 --      overridden.  In another package, declare a subtype of the type in the
  43 --      previous package.  Declare another version of the predefined operator
  44 --      for the subtype.
  45 --
  46 --      The main program declares objects of both the type and the explicit
  47 --      subtype, and uses the "**" operator for both.  In all cases, the
  48 --      operator declared for the 1st subtype should be the one executed,
  49 --      since it is the primitive operators of the *type* that are made
  50 --      visible; the operators which were declared for the explicit subtype
  51 --      are not primitive operators of the type, since they were declared in
  52 --      a separate package from the original type.
  53 --
  54 --
  55 -- CHANGE HISTORY:
  56 --      06 Dec 94   SAIC    ACVC 2.0
  57 --      23 Sep 99   RLB     Added test case where operator made visible is
  58 --                          not visible by selection (as in AI-00122).
  59 --
  60 --!
  61
  62 package C840001_0 is
  63 -- Usage scenario: the predefined operators for a floating point type
  64 -- are overridden in order to take advantage of improved algorithms.
  65
  66    type Precision_Float is new Float range -100.0 .. 100.0;
  67    -- Implicit: function "**" (Left: Precision_Float; Right: Integer'Base)
  68    -- return Precision_Float;
  69
  70    function "**" (Left: Precision_Float; Right: Integer'Base)
  71      return Precision_Float;
  72    -- Overrides predefined operator.
  73
  74    function "+" (Right: Precision_Float)
  75      return Precision_Float;
  76    -- Overrides predefined operator.
  77
  78    -- ... Other overridden operations.
  79
  80    TC_Expected : constant Precision_Float := 68.0;
  81
  82 end C840001_0;
  83
  84
  85      --==================================================================--
  86
  87 package body C840001_0 is
  88
  89    function "**" (Left: Precision_Float; Right: Integer'Base)
  90      return Precision_Float is
  91    begin
  92       -- ... Utilize desired algorithm.
  93       return (TC_Expected);  -- Artificial for testing purposes.
  94    end "**";
  95
  96    function "+" (Right: Precision_Float)
  97      return Precision_Float is
  98    -- Overrides predefined operator.
  99    begin
 100       return Right*2.0;
 101    end "+";
 102
 103 end C840001_0;
 104
 105
 106      --==================================================================--
 107
 108 -- Take advantage of some even better algorithms designed for positive
 109 -- floating point values.
 110
 111 with C840001_0;
 112 package C840001_1 is
 113
 114    subtype Precision_Pos_Float is C840001_0.Precision_Float
 115      range 0.0 .. 100.0;
 116
 117 -- This is not a new type, so it has no primitives of it own. However, it
 118 -- can declare another version of the operator and call it as long as both it
 119 -- and the corresponding operator of the 1st subtype are not directly visible
 120 -- in the same place.
 121
 122    function "**" (Left: Precision_Pos_Float; Right: Natural'Base)
 123      return Precision_Pos_Float;           -- Accepts only positive exponent.
 124
 125 end C840001_1;
 126
 127
 128      --==================================================================--
 129
 130 package body C840001_1 is
 131
 132    function "**" (Left: Precision_Pos_Float; Right: Natural'Base)
 133      return Precision_Pos_Float is
 134    begin
 135       -- ... Utilize some other algorithms.
 136       return 57.0;           -- Artificial for testing purposes.
 137    end "**";
 138
 139 end C840001_1;
 140
 141
 142      --==================================================================--
 143
 144 with Report;
 145 with C840001_1;
 146 procedure C840001_2 is
 147
 148    -- Note that C840001_0 and it's contents is not visible in any form here.
 149
 150    TC_Operand   : C840001_1.Precision_Pos_Float := 41.0;
 151
 152    TC_Operand2  : C840001_1.Precision_Pos_Float;
 153
 154    use type C840001_1.Precision_Pos_Float;
 155       -- Makes the operators of its parent type directly visible, even though
 156       -- the parent type and operators are not otherwise visible at all.
 157
 158 begin
 159
 160    TC_Operand2 := +TC_Operand; -- Overridden operator is visible and called.
 161
 162    if TC_Operand2 /= 82.0 then -- Predefined equality.
 163       Report.Failed ("3rd test: type's overridden operation not called for " &
 164                      "operand of 1st subtype");
 165    end if;
 166    if TC_Operand + 3.0 >= TC_Operand2 - 13.0 then -- Various predefined operators.
 167       Report.Failed ("3rd test: wrong result from predefined operators");
 168    end if;
 169
 170 end C840001_2;
 171
 172      --==================================================================--
 173
 174
 175 with C840001_0;
 176 with C840001_1;
 177 with C840001_2;
 178
 179 with Report;
 180
 181 procedure C840001 is
 182
 183 begin
 184    Report.Test ("C840001", "Check that, for the type determined by the "   &
 185                 "subtype mark of a use type clause, the declaration of "   &
 186                 "each primitive operator is use-visible within the scope " &
 187                 "of the clause, even if explicit operators with the same " &
 188                 "names as the type's operators are declared for the subtype");
 189
 190
 191    Use_Type_Precision_Pos_Float:
 192    declare
 193       TC_Operand          : C840001_0.Precision_Float
 194                           := C840001_0.Precision_Float(-2.0);
 195       TC_Positive_Operand : C840001_1.Precision_Pos_Float :=  6.0;
 196
 197       TC_Actual_Type      : C840001_0.Precision_Float;
 198       TC_Actual_Subtype   : C840001_1.Precision_Pos_Float;
 199
 200       use type C840001_1.Precision_Pos_Float;
 201       -- Both calls to "**" should return 68.0 (that is, Precision_Float's
 202       -- operation should be called).
 203
 204    begin
 205
 206       TC_Actual_Type := TC_Operand**2;
 207
 208       if C840001_0."/="(TC_Actual_Type, C840001_0.TC_Expected) then
 209          Report.Failed ("1st block: type's operation not called for " &
 210                         "operand of 1st subtype");
 211       end if;
 212
 213       TC_Actual_Subtype := TC_Positive_Operand**2;
 214
 215       if not (C840001_0."="
 216              (TC_Actual_Subtype, C840001_0.TC_Expected)) then
 217          Report.Failed ("1st block: type's operation not called for " &
 218                         "operand of explicit subtype");
 219       end if;
 220
 221    end Use_Type_Precision_Pos_Float;
 222
 223    Use_Type_Precision_Float:
 224    declare
 225       TC_Operand          : C840001_0.Precision_Float
 226                           := C840001_0.Precision_Float(4.0);
 227       TC_Positive_Operand : C840001_1.Precision_Pos_Float :=  7.0;
 228
 229       TC_Actual_Type      : C840001_0.Precision_Float;
 230       TC_Actual_Subtype   : C840001_1.Precision_Pos_Float;
 231
 232       use type C840001_0.Precision_Float;
 233       -- Again, both calls to "**" should return 68.0.
 234
 235   begin
 236
 237       TC_Actual_Type := TC_Operand**2;
 238
 239       if C840001_0."/="(TC_Actual_Type, C840001_0.TC_Expected) then
 240          Report.Failed ("2nd block: type's operation not called for " &
 241                         "operand of 1st subtype");
 242       end if;
 243
 244       TC_Actual_Subtype := TC_Positive_Operand**2;
 245
 246       if not C840001_0."=" (TC_Actual_Subtype, C840001_0.TC_Expected) then
 247          Report.Failed ("2nd block: type's operation not called for " &
 248                         "operand of explicit subtype");
 249       end if;
 250
 251    end Use_Type_Precision_Float;
 252
 253    C840001_2; -- 3rd test.
 254
 255    Report.Result;
 256
 257 end C840001;