old-autovect-branch/gcc/testsuite/ada/acats/tests/c3/c390007.a

   1 -- C390007.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 tag of an object of a tagged type is preserved by
  28 --      type conversion and parameter passing.
  29 --
  30 -- TEST DESCRIPTION:
  31 --      The fact that the tag of an object is not changed is verified by
  32 --      making dispatching calls to primitive operations, and confirming that
  33 --      the proper body is executed. Objects of both specific and class-wide
  34 --      types are checked.
  35 --
  36 --      The dispatching calls are made in two contexts. The first is a
  37 --      straightforward dispatching call made from within a class-wide
  38 --      operation. The second is a redispatch from within a primitive
  39 --      operation.
  40 --
  41 --      For the parameter passing case, the initial class-wide and specific
  42 --      objects are passed directly in calls to the class-wide and primitive
  43 --      operations. The redispatch is accomplished by initializing a local
  44 --      class-wide object in the primitive operation to the value of the
  45 --      formal parameter, and using the local object as the actual in the
  46 --      (re)dispatching call.
  47 --
  48 --      For the type conversion case, the initial class-wide object is assigned
  49 --      a view conversion of an object of a specific type:
  50 --
  51 --         type T is tagged ...
  52 --         type DT is new T with ...
  53 --
  54 --         A : DT;
  55 --         B : T'Class := T(A); -- Despite conversion, tag of B is that of DT.
  56 --
  57 --      The class-wide object is then passed directly in calls to the
  58 --      class-wide and primitive operations. For the initial object of a
  59 --      specific type, however, a view conversion of the object is passed,
  60 --      forcing a non-dispatching call in the primitive operation case. Within
  61 --      the primitive operation, a view conversion of the formal parameter to
  62 --      a class-wide type is then used to force a (re)dispatching call.
  63 --
  64 --      For the type conversion and parameter passing case, a combining of
  65 --      view conversion and parameter passing of initial specific objects are
  66 --      called directly to the class-wide and primitive operations.
  67 --
  68 --
  69 -- CHANGE HISTORY:
  70 --      28 Jun 95   SAIC    Initial prerelease version.
  71 --      23 Apr 96   SAIC    Added use C390007_0 in the main.
  72 --
  73 --!
  74
  75 package C390007_0 is
  76
  77    type Call_ID_Kind is (None, Parent_Outer,  Parent_Inner,
  78                                Derived_Outer, Derived_Inner);
  79
  80    type Root_Type is abstract tagged null record;
  81
  82    procedure Outer_Proc (X : in out Root_Type) is abstract;
  83    procedure Inner_Proc (X : in out Root_Type) is abstract;
  84
  85    procedure ClassWide_Proc (X : in out Root_Type'Class);
  86
  87 end C390007_0;
  88
  89
  90      --==================================================================--
  91
  92
  93 package body C390007_0 is
  94
  95    procedure ClassWide_Proc (X : in out Root_Type'Class) is
  96    begin
  97       Inner_Proc (X);
  98    end ClassWide_Proc;
  99
 100 end C390007_0;
 101
 102
 103      --==================================================================--
 104
 105
 106 package C390007_0.C390007_1 is
 107
 108    type Param_Parent_Type is new Root_Type with record
 109       Last_Call : Call_ID_Kind := None;
 110    end record;
 111
 112    procedure Outer_Proc (X : in out Param_Parent_Type);
 113    procedure Inner_Proc (X : in out Param_Parent_Type);
 114
 115 end C390007_0.C390007_1;
 116
 117
 118      --==================================================================--
 119
 120
 121 package body C390007_0.C390007_1 is
 122
 123    procedure Outer_Proc (X : in out Param_Parent_Type) is
 124    begin
 125       X.Last_Call := Parent_Outer;
 126    end Outer_Proc;
 127
 128    procedure Inner_Proc (X : in out Param_Parent_Type) is
 129    begin
 130       X.Last_Call := Parent_Inner;
 131    end Inner_Proc;
 132
 133 end C390007_0.C390007_1;
 134
 135
 136      --==================================================================--
 137
 138
 139 package C390007_0.C390007_1.C390007_2 is
 140
 141    type Param_Derived_Type is new Param_Parent_Type with null record;
 142
 143    procedure Outer_Proc (X : in out Param_Derived_Type);
 144    procedure Inner_Proc (X : in out Param_Derived_Type);
 145
 146 end C390007_0.C390007_1.C390007_2;
 147
 148
 149      --==================================================================--
 150
 151
 152 package body C390007_0.C390007_1.C390007_2 is
 153
 154    procedure Outer_Proc (X : in out Param_Derived_Type) is
 155       Y : Root_Type'Class := X;
 156    begin
 157       Inner_Proc (Y);  -- Redispatch.
 158       Root_Type'Class (X) := Y;
 159    end Outer_Proc;
 160
 161    procedure Inner_Proc (X : in out Param_Derived_Type) is
 162    begin
 163       X.Last_Call := Derived_Inner;
 164    end Inner_Proc;
 165
 166 end C390007_0.C390007_1.C390007_2;
 167
 168
 169      --==================================================================--
 170
 171
 172 package C390007_0.C390007_3 is
 173
 174    type Convert_Parent_Type is new Root_Type with record
 175       First_Call  : Call_ID_Kind := None;
 176       Second_Call : Call_ID_Kind := None;
 177    end record;
 178
 179    procedure Outer_Proc (X : in out Convert_Parent_Type);
 180    procedure Inner_Proc (X : in out Convert_Parent_Type);
 181
 182 end C390007_0.C390007_3;
 183
 184
 185      --==================================================================--
 186
 187
 188 package body C390007_0.C390007_3 is
 189
 190    procedure Outer_Proc (X : in out Convert_Parent_Type) is
 191    begin
 192       X.First_Call := Parent_Outer;
 193       Inner_Proc (Root_Type'Class(X));  -- Redispatch.
 194    end Outer_Proc;
 195
 196    procedure Inner_Proc (X : in out Convert_Parent_Type) is
 197    begin
 198       X.Second_Call := Parent_Inner;
 199    end Inner_Proc;
 200
 201 end C390007_0.C390007_3;
 202
 203
 204      --==================================================================--
 205
 206
 207 package C390007_0.C390007_3.C390007_4 is
 208
 209    type Convert_Derived_Type is new Convert_Parent_Type with null record;
 210
 211    procedure Outer_Proc (X : in out Convert_Derived_Type);
 212    procedure Inner_Proc (X : in out Convert_Derived_Type);
 213
 214 end C390007_0.C390007_3.C390007_4;
 215
 216
 217      --==================================================================--
 218
 219
 220 package body C390007_0.C390007_3.C390007_4 is
 221
 222    procedure Outer_Proc (X : in out Convert_Derived_Type) is
 223    begin
 224       X.First_Call := Derived_Outer;
 225       Inner_Proc (Root_Type'Class(X));  -- Redispatch.
 226    end Outer_Proc;
 227
 228    procedure Inner_Proc (X : in out Convert_Derived_Type) is
 229    begin
 230       X.Second_Call := Derived_Inner;
 231    end Inner_Proc;
 232
 233 end C390007_0.C390007_3.C390007_4;
 234
 235
 236      --==================================================================--
 237
 238
 239 with C390007_0.C390007_1.C390007_2;
 240 with C390007_0.C390007_3.C390007_4;
 241 use  C390007_0;
 242
 243 with Report;
 244 procedure C390007 is
 245 begin
 246    Report.Test ("C390007", "Check that the tag of an object of a tagged " &
 247                 "type is preserved by type conversion and parameter passing");
 248
 249
 250    --
 251    -- Check that tags are preserved by parameter passing:
 252    --
 253
 254    Parameter_Passing_Subtest:
 255    declare
 256       Specific_A  : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
 257       Specific_B  : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
 258
 259       ClassWide_A : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_A;
 260       ClassWide_B : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_B;
 261
 262       use C390007_0.C390007_1;
 263       use C390007_0.C390007_1.C390007_2;
 264    begin
 265
 266       Outer_Proc (Specific_A);
 267       if Specific_A.Last_Call /= Derived_Inner then
 268          Report.Failed ("Parameter passing: tag not preserved in call to " &
 269                         "primitive operation with specific operand");
 270       end if;
 271
 272       C390007_0.ClassWide_Proc (Specific_B);
 273       if Specific_B.Last_Call /= Derived_Inner then
 274          Report.Failed ("Parameter passing: tag not preserved in call to " &
 275                         "class-wide operation with specific operand");
 276       end if;
 277
 278       Outer_Proc (ClassWide_A);
 279       if ClassWide_A.Last_Call /= Derived_Inner then
 280          Report.Failed ("Parameter passing: tag not preserved in call to " &
 281                         "primitive operation with class-wide operand");
 282       end if;
 283
 284       C390007_0.ClassWide_Proc (ClassWide_B);
 285       if ClassWide_B.Last_Call /= Derived_Inner then
 286          Report.Failed ("Parameter passing: tag not preserved in call to " &
 287                         "class-wide operation with class-wide operand");
 288       end if;
 289
 290    end Parameter_Passing_Subtest;
 291
 292
 293    --
 294    -- Check that tags are preserved by type conversion:
 295    --
 296
 297    Type_Conversion_Subtest:
 298    declare
 299       Specific_A  : C390007_0.C390007_3.C390007_4.Convert_Derived_Type;
 300       Specific_B  : C390007_0.C390007_3.C390007_4.Convert_Derived_Type;
 301
 302       ClassWide_A : C390007_0.C390007_3.Convert_Parent_Type'Class :=
 303                     C390007_0.C390007_3.Convert_Parent_Type(Specific_A);
 304       ClassWide_B : C390007_0.C390007_3.Convert_Parent_Type'Class :=
 305                     C390007_0.C390007_3.Convert_Parent_Type(Specific_B);
 306
 307       use C390007_0.C390007_3;
 308       use C390007_0.C390007_3.C390007_4;
 309    begin
 310
 311       Outer_Proc (Convert_Parent_Type(Specific_A));
 312       if (Specific_A.First_Call  /= Parent_Outer)  or
 313          (Specific_A.Second_Call /= Derived_Inner)
 314       then
 315          Report.Failed ("Type conversion: tag not preserved in call to " &
 316                         "primitive operation with specific operand");
 317       end if;
 318
 319       Outer_Proc (ClassWide_A);
 320       if (ClassWide_A.First_Call  /= Derived_Outer) or
 321          (ClassWide_A.Second_Call /= Derived_Inner)
 322       then
 323          Report.Failed ("Type conversion: tag not preserved in call to " &
 324                         "primitive operation with class-wide operand");
 325       end if;
 326
 327       C390007_0.ClassWide_Proc (Convert_Parent_Type(Specific_B));
 328       if (Specific_B.Second_Call /= Derived_Inner) then
 329          Report.Failed ("Type conversion: tag not preserved in call to " &
 330                         "class-wide operation with specific operand");
 331       end if;
 332
 333       C390007_0.ClassWide_Proc (ClassWide_B);
 334       if (ClassWide_A.Second_Call /= Derived_Inner) then
 335          Report.Failed ("Type conversion: tag not preserved in call to " &
 336                         "class-wide operation with class-wide operand");
 337       end if;
 338
 339    end Type_Conversion_Subtest;
 340
 341
 342    --
 343    -- Check that tags are preserved by type conversion and parameter passing:
 344    --
 345
 346    Type_Conversion_And_Parameter_Passing_Subtest:
 347    declare
 348       Specific_A  : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
 349       Specific_B  : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
 350
 351       use C390007_0.C390007_1;
 352       use C390007_0.C390007_1.C390007_2;
 353    begin
 354
 355       Outer_Proc (Param_Parent_Type (Specific_A));
 356       if Specific_A.Last_Call /= Parent_Outer then
 357          Report.Failed ("Type conversion and parameter passing: tag not " &
 358                         "preserved in call to primitive operation with "  &
 359                         "specific operand");
 360       end if;
 361
 362       C390007_0.ClassWide_Proc (Param_Parent_Type (Specific_B));
 363       if Specific_B.Last_Call /= Derived_Inner then
 364          Report.Failed ("Type conversion and parameter passing: tag not " &
 365                         "preserved in call to class-wide operation with "  &
 366                         "specific operand");
 367       end if;
 368
 369    end Type_Conversion_And_Parameter_Passing_Subtest;
 370
 371
 372    Report.Result;
 373
 374 end C390007;