old-autovect-branch/gcc/testsuite/ada/acats/tests/c8/c854001.a

   1 -- C854001.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 a subprogram declaration can be completed by a
  28 --      subprogram renaming declaration. In particular, check that such a
  29 --      renaming-as-body can be given in a package body to complete a
  30 --      subprogram declared in the package specification. Check that calls
  31 --      to the subprogram invoke the body of the renamed subprogram.  Check
  32 --      that a renaming allows a copy of an inherited or predefined subprogram
  33 --      before overriding it later.  Check that renaming a dispatching
  34 --      operation calls the correct body in case of overriding.
  35 --
  36 -- TEST DESCRIPTION:
  37 --      This test declares a record type, an integer type, and a tagged type
  38 --      with a set of operations in a package. A renaming of a predefined
  39 --      equality operation of a tagged type is also defined in this package.
  40 --      The predefined operation is overridden in the private part. In a
  41 --      separate package, a subtype of the record type and integer type
  42 --      are declared.  Subset of the full set of operations for the record
  43 --      and types is reexported using renamings-as-bodies. Other operations
  44 --      are given explicit bodies.  The test verifies that the appropriate
  45 --      body is executed for each operation on the subtype.
  46 --
  47 --
  48 -- CHANGE HISTORY:
  49 --      06 Dec 94   SAIC    ACVC 2.0
  50 --      07 Nov 95   SAIC    Update and repair for ACVC 2.0.1
  51 --
  52 --!
  53
  54 package C854001_0 is
  55
  56    type Component is (Op_Of_Type, Op_Of_Subtype, Initial_Value);
  57
  58    type Root is record
  59       Called : Component := Op_Of_Subtype;
  60    end record;
  61
  62    procedure Root_Proc (P: in out Root);
  63    procedure Over_Proc (P: in out Root);
  64
  65    function Root_Func return Root;
  66    function Over_Func return Root;
  67
  68    type Short_Int is range 1 .. 98;
  69
  70    function "+" (P1, P2 : Short_Int) return Short_Int;
  71    function Name (P1, P2 : Short_Int) return Short_Int;
  72
  73    type Tag_Type is tagged record
  74       C : Component := Initial_Value;
  75    end record;
  76    -- Inherits predefined operator "=" and others.
  77
  78    function Predefined_Equal (P1, P2 : Tag_Type) return Boolean
  79      renames "=";
  80    -- Renames predefined operator "=" before overriding.
  81
  82 private
  83    function "=" (P1, P2 : Tag_Type)
  84      return Boolean;                   -- Overrides predefined operator "=".
  85
  86
  87 end C854001_0;
  88
  89
  90      --==================================================================--
  91
  92
  93 package body C854001_0 is
  94
  95    procedure Root_Proc (P: in out Root) is
  96    begin
  97       P.Called := Initial_Value;
  98    end Root_Proc;
  99
 100    ---------------------------------------
 101    procedure Over_Proc (P: in out Root) is
 102    begin
 103       P.Called := Op_Of_Type;
 104    end Over_Proc;
 105
 106    ---------------------------------------
 107    function Root_Func return Root is
 108    begin
 109       return (Called => Op_Of_Type);
 110    end Root_Func;
 111
 112    ---------------------------------------
 113    function Over_Func return Root is
 114    begin
 115       return (Called => Initial_Value);
 116    end Over_Func;
 117
 118    ---------------------------------------
 119    function "+" (P1, P2 : Short_Int) return Short_Int is
 120    begin
 121       return 15;
 122    end "+";
 123
 124    ---------------------------------------
 125    function Name (P1, P2 : Short_Int) return Short_Int is
 126    begin
 127       return 47;
 128    end Name;
 129
 130    ---------------------------------------
 131    function "=" (P1, P2 : Tag_Type) return Boolean is
 132    begin
 133       return False;
 134    end "=";
 135
 136 end C854001_0;
 137
 138      --==================================================================--
 139
 140
 141 with C854001_0;
 142 package C854001_1 is
 143
 144    subtype Root_Subtype is C854001_0.Root;
 145    subtype Short_Int_Subtype is C854001_0.Short_Int;
 146
 147    procedure Ren_Proc  (P: in out Root_Subtype);
 148    procedure Same_Proc (P: in out Root_Subtype);
 149
 150    function Ren_Func  return Root_Subtype;
 151    function Same_Func return Root_Subtype;
 152
 153    function Other_Name (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype;
 154    function "-" (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype;
 155
 156    function User_Defined_Equal (P1, P2 : C854001_0.Tag_Type) return Boolean
 157      renames C854001_0."=";                       -- Executes body of the
 158                                                   -- overriding declaration in
 159                                                   -- the private part.
 160 end C854001_1;
 161
 162
 163      --==================================================================--
 164
 165
 166 with C854001_0;
 167 package body C854001_1 is
 168
 169    --
 170    -- Renaming-as-body for procedure:
 171    --
 172
 173    procedure Ren_Proc  (P: in out Root_Subtype)
 174      renames C854001_0.Root_Proc;
 175    procedure Same_Proc (P: in out Root_Subtype)
 176      renames C854001_0.Over_Proc;
 177
 178    --
 179    -- Renaming-as-body for function:
 180    --
 181
 182    function Ren_Func  return Root_Subtype renames C854001_0.Root_Func;
 183    function Same_Func return Root_Subtype renames C854001_0.Over_Func;
 184
 185    function Other_Name (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype
 186      renames C854001_0."+";
 187    function "-" (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype
 188      renames C854001_0.Name;
 189
 190 end C854001_1;
 191
 192
 193      --==================================================================--
 194
 195 with C854001_0;
 196 with C854001_1;  -- Subtype and associated operations.
 197 use  C854001_1;
 198
 199 with Report;
 200
 201 procedure C854001 is
 202    Operand1  : Root_Subtype;
 203    Operand2  : Root_Subtype;
 204    Operand3  : Root_Subtype;
 205    Operand4  : Root_Subtype;
 206    Operand5  : Short_Int_Subtype := 55;
 207    Operand6  : Short_Int_Subtype := 46;
 208    Operand7  : Short_Int_Subtype;
 209    Operand8  : C854001_0.Tag_Type;         -- Both Operand8 & Operand9 have
 210    Operand9  : C854001_0.Tag_Type;         -- the same default values.
 211
 212    -- Direct visibility to operator symbols
 213    use type C854001_0.Component;
 214    use type C854001_0.Short_Int;
 215
 216 begin
 217    Report.Test ("C854001", "Check that a renaming-as-body can be given " &
 218                            "in a package body to complete a subprogram " &
 219                            "declared in the package specification. "     &
 220                            "Check that calls to the subprogram invoke "  &
 221                            "the body of the renamed subprogram");
 222
 223    --
 224    -- Only operations of the subtype are available.
 225    --
 226
 227    Ren_Proc  (Operand1);
 228    if Operand1.Called /= C854001_0.Initial_Value then
 229       Report.Failed ("Error calling procedure Ren_Proc");
 230    end if;
 231
 232    ---------------------------------------
 233    Same_Proc (Operand2);
 234    if Operand2.Called /= C854001_0.Op_Of_Type then
 235       Report.Failed ("Error calling procedure Same_Proc");
 236    end if;
 237
 238    ---------------------------------------
 239    Operand3 := Ren_Func;
 240    if Operand3.Called /= C854001_0.Op_Of_Type then
 241       Report.Failed ("Error calling function Ren_Func");
 242    end if;
 243
 244    ---------------------------------------
 245    Operand4 := Same_Func;
 246    if Operand4.Called /= C854001_0.Initial_Value then
 247       Report.Failed ("Error calling function Same_Func");
 248    end if;
 249
 250    ---------------------------------------
 251    Operand7 := C854001_1."-" (Operand5, Operand6);
 252    if Operand7 /= 47 then
 253       Report.Failed ("Error calling function & ""-""");
 254    end if;
 255
 256    ---------------------------------------
 257    Operand7 := Other_Name (Operand5, Operand6);
 258    if Operand7 /= 15 then
 259       Report.Failed ("Error calling function Other_Name");
 260    end if;
 261
 262    ---------------------------------------
 263    -- Executes body of the overriding declaration in the private part
 264    -- of C854001_0.
 265    if User_Defined_Equal (Operand8, Operand9) then
 266       Report.Failed ("Error calling function User_Defined_Equal");
 267    end if;
 268
 269    ---------------------------------------
 270    -- Executes predefined operation.
 271    if not C854001_0.Predefined_Equal (Operand8, Operand9) then
 272       Report.Failed ("Error calling function Predefined_Equal");
 273    end if;
 274
 275    Report.Result;
 276
 277 end C854001;