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

   1 -- C460006.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 view conversion to a tagged type is permitted in the
  28 --      prefix of a selected component, an object renaming declaration, and
  29 --      (if the operand is a variable) on the left side of an assignment
  30 --      statement. Check that such a renaming or assignment does not change
  31 --      the tag of the operand.
  32 --
  33 --      Check that, for a view conversion of a tagged type, each
  34 --      nondiscriminant component of the new view denotes the matching
  35 --      component of the operand object. Check that reading the value of the
  36 --      view yields the result of converting the value of the operand object
  37 --      to the target subtype.
  38 --
  39 -- TEST DESCRIPTION:
  40 --      The fact that the tag of an object is not changed is verified by
  41 --      making calls to primitive operations which in turn make (re)dispatching
  42 --      calls, and confirming that the proper bodies are executed.
  43 --
  44 --      Selected components are checked in three contexts: as the object name
  45 --      in an object renaming declaration, as the left operand of an inequality
  46 --      operation, and as the left side of an assignment statement.
  47 --
  48 --      View conversions of an object of a 2nd level type extension are
  49 --      renamed as objects of an ancestor type and of a class-wide type. In
  50 --      one case the operand of the conversion is itself a renaming of an
  51 --      object.
  52 --
  53 --      View conversions of an object of a 2nd level type extension are
  54 --      checked for equality with record aggregates of various ancestor types.
  55 --      In one case, the view conversion is to a class-wide type, and it is
  56 --      checked for equality with the result of a class-wide function with
  57 --      the following structure:
  58 --
  59 --         function F return T'Class is
  60 --            A : DDT     := Expected_Value;
  61 --            X : T'Class := T(A);
  62 --         begin
  63 --            return X;
  64 --
  65 --         end F;
  66 --
  67 --         ...
  68 --
  69 --         Var : DDT := Expected_Value;
  70 --
  71 --         if (T'Class(Var) /= F) then    -- Condition should yield FALSE.
  72 --            FAIL;
  73 --         end if;
  74 --
  75 --      The view conversion to which X is initialized does not affect the
  76 --      value or tag of the operand; the tag of X is that of type DDT (not T),
  77 --      and the components are those of A. The result of this function
  78 --      should equal the value of an object of type DDT initialized to the
  79 --      same value as F.A.
  80 --
  81 --      To check that assignment to a view conversion does not change the tag
  82 --      of the operand, an assignment is made to a conversion of an object,
  83 --      and the object is then passed as an actual to a dispatching operation.
  84 --      Conversions to both specific and class-wide types are checked.
  85 --
  86 --
  87 -- CHANGE HISTORY:
  88 --      20 Jul 95   SAIC    Initial prerelease version.
  89 --      24 Apr 96   SAIC    Added type conversions.
  90 --
  91 --!
  92
  93 package C460006_0 is
  94
  95    type Call_ID_Kind is (None, Parent_Outer,     Parent_Inner,
  96                                Child_Outer,      Child_Inner,
  97                                Grandchild_Outer, Grandchild_Inner);
  98
  99    type Root_Type is abstract tagged record
 100       First_Call  : Call_ID_Kind := None;
 101       Second_Call : Call_ID_Kind := None;
 102    end record;
 103
 104    procedure Inner_Proc (X : in out Root_Type) is abstract;
 105    procedure Outer_Proc (X : in out Root_Type) is abstract;
 106
 107 end C460006_0;
 108
 109
 110      --==================================================================--
 111
 112
 113 package C460006_0.C460006_1 is
 114
 115    type Parent_Type is new Root_Type with record
 116       C1 : Integer := 0;
 117    end record;
 118
 119    procedure Inner_Proc (X : in out Parent_Type);
 120    procedure Outer_Proc (X : in out Parent_Type);
 121
 122 end C460006_0.C460006_1;
 123
 124
 125      --==================================================================--
 126
 127
 128 package body C460006_0.C460006_1 is
 129
 130    procedure Inner_Proc (X : in out Parent_Type) is
 131    begin
 132       X.Second_Call := Parent_Inner;
 133    end Inner_Proc;
 134
 135    -------------------------------------------------
 136    procedure Outer_Proc (X : in out Parent_Type) is
 137    begin
 138       X.First_Call := Parent_Outer;
 139       Inner_Proc ( Parent_Type'Class(X) );
 140    end Outer_Proc;
 141
 142 end C460006_0.C460006_1;
 143
 144
 145      --==================================================================--
 146
 147
 148 package C460006_0.C460006_1.C460006_2 is
 149
 150    type Child_Type is new Parent_Type with record
 151       C2 : String(1 .. 5) := "-----";
 152    end record;
 153
 154    procedure Inner_Proc (X : in out Child_Type);
 155    procedure Outer_Proc (X : in out Child_Type);
 156
 157 end C460006_0.C460006_1.C460006_2;
 158
 159
 160      --==================================================================--
 161
 162
 163 package body C460006_0.C460006_1.C460006_2 is
 164
 165    procedure Inner_Proc (X : in out Child_Type) is
 166    begin
 167       X.Second_Call := Child_Inner;
 168    end Inner_Proc;
 169
 170    -------------------------------------------------
 171    procedure Outer_Proc (X : in out Child_Type) is
 172    begin
 173       X.First_Call := Child_Outer;
 174       Inner_Proc ( Parent_Type'Class(X) );
 175    end Outer_Proc;
 176
 177 end C460006_0.C460006_1.C460006_2;
 178
 179
 180      --==================================================================--
 181
 182
 183 package C460006_0.C460006_1.C460006_2.C460006_3 is
 184
 185    type Grandchild_Type is new Child_Type with record
 186       C3: String(1 .. 5) := "-----";
 187    end record;
 188
 189    procedure Inner_Proc (X : in out Grandchild_Type);
 190    procedure Outer_Proc (X : in out Grandchild_Type);
 191
 192
 193    function ClassWide_Func return Parent_Type'Class;
 194
 195
 196    Grandchild_Value : constant Grandchild_Type := (First_Call  => None,
 197                                                    Second_Call => None,
 198                                                    C1          => 15,
 199                                                    C2          => "Hello",
 200                                                    C3          => "World");
 201
 202 end C460006_0.C460006_1.C460006_2.C460006_3;
 203
 204
 205      --==================================================================--
 206
 207
 208 package body C460006_0.C460006_1.C460006_2.C460006_3 is
 209
 210    procedure Inner_Proc (X : in out Grandchild_Type) is
 211    begin
 212       X.Second_Call := Grandchild_Inner;
 213    end Inner_Proc;
 214
 215    -------------------------------------------------
 216    procedure Outer_Proc (X : in out Grandchild_Type) is
 217    begin
 218       X.First_Call := Grandchild_Outer;
 219       Inner_Proc ( Parent_Type'Class(X) );
 220    end Outer_Proc;
 221
 222    -------------------------------------------------
 223    function ClassWide_Func return Parent_Type'Class is
 224       A : Grandchild_Type   := Grandchild_Value;
 225       X : Parent_Type'Class := Parent_Type(A); -- Value of X is still that of A.
 226    begin
 227       return X;
 228    end ClassWide_Func;
 229
 230 end C460006_0.C460006_1.C460006_2.C460006_3;
 231
 232
 233      --==================================================================--
 234
 235
 236 with C460006_0.C460006_1.C460006_2.C460006_3;
 237
 238 with Report;
 239 procedure C460006 is
 240
 241    package Root_Package       renames C460006_0;
 242    package Parent_Package     renames C460006_0.C460006_1;
 243    package Child_Package      renames C460006_0.C460006_1.C460006_2;
 244    package Grandchild_Package renames C460006_0.C460006_1.C460006_2.C460006_3;
 245
 246 begin
 247    Report.Test ("C460006", "Check that a view conversion to a tagged type " &
 248                 "is permitted in the prefix of a selected component, an "   &
 249                 "object renaming declaration, and (if the operand is a "    &
 250                 "variable) on the left side of an assignment statement.  "  &
 251                 "Check that such a renaming or assignment does not change " &
 252                 " the tag of the operand");
 253
 254
 255    --
 256    -- Check conversion as prefix of selected component:
 257    --
 258
 259    Selected_Component_Subtest:
 260    declare
 261       use Root_Package, Parent_Package, Child_Package, Grandchild_Package;
 262
 263       Var    : Grandchild_Type   := Grandchild_Value;
 264       CW_Var : Parent_Type'Class := Var;
 265
 266       Ren    : Integer renames Parent_Type(Var).C1;
 267
 268    begin
 269       if Ren /= 15 then
 270          Report.Failed ("Wrong value: selected component in renaming");
 271       end if;
 272
 273       if Child_Type(Var).C2 /= "Hello" then
 274          Report.Failed ("Wrong value: selected component in IF");
 275       end if;
 276
 277       Grandchild_Type(CW_Var).C3(2..4) := "eir";
 278       if CW_Var /= Parent_Type'Class
 279                    (Grandchild_Type'(None, None, 15, "Hello", "Weird"))
 280       then
 281          Report.Failed ("Wrong value: selected component in assignment");
 282       end if;
 283    end Selected_Component_Subtest;
 284
 285
 286    --
 287    -- Check conversion in object renaming:
 288    --
 289
 290    Object_Renaming_Subtest:
 291    declare
 292       use Root_Package, Parent_Package, Child_Package, Grandchild_Package;
 293
 294       Var : Grandchild_Type := Grandchild_Value;
 295       Ren1 : Parent_Type       renames Parent_Type(Var);
 296       Ren2 : Child_Type        renames Child_Type(Var);
 297       Ren3 : Parent_Type'Class renames Parent_Type'Class(Var);
 298       Ren4 : Parent_Type       renames Parent_Type(Ren2); -- Rename of rename.
 299    begin
 300       Outer_Proc (Ren1);
 301       if Ren1 /= (Parent_Outer, Grandchild_Inner, 15) then
 302          Report.Failed ("Value or tag not preserved by object renaming: Ren1");
 303       end if;
 304
 305       Outer_Proc (Ren2);
 306       if Ren2 /= (Child_Outer, Grandchild_Inner, 15, "Hello") then
 307          Report.Failed ("Value or tag not preserved by object renaming: Ren2");
 308       end if;
 309
 310       Outer_Proc (Ren3);
 311       if Ren3 /= Parent_Type'Class
 312                  (Grandchild_Type'(Grandchild_Outer,
 313                                    Grandchild_Inner,
 314                                    15,
 315                                    "Hello",
 316                                    "World"))
 317       then
 318          Report.Failed ("Value or tag not preserved by object renaming: Ren3");
 319       end if;
 320
 321       Outer_Proc (Ren4);
 322       if Ren4 /= (Parent_Outer, Grandchild_Inner, 15) then
 323          Report.Failed ("Value or tag not preserved by object renaming: Ren4");
 324       end if;
 325    end Object_Renaming_Subtest;
 326
 327
 328    --
 329    -- Check reading view conversion, and conversion as left side of assignment:
 330    --
 331
 332    View_Conversion_Subtest:
 333    declare
 334       use Root_Package, Parent_Package, Child_Package, Grandchild_Package;
 335
 336       Var : Grandchild_Type := Grandchild_Value;
 337       Specific  : Child_Type;
 338       ClassWide : Parent_Type'Class := Var;   -- Grandchild_Type tag.
 339    begin
 340       if Parent_Type(Var) /= (None, None, 15) then
 341          Report.Failed ("View has wrong value: #1");
 342       end if;
 343
 344       if Child_Type(Var) /= (None, None, 15, "Hello") then
 345          Report.Failed ("View has wrong value: #2");
 346       end if;
 347
 348       if Parent_Type'Class(Var) /= ClassWide_Func then
 349          Report.Failed ("Upward view conversion did not preserve " &
 350                         "extension's components");
 351       end if;
 352
 353
 354       Parent_Type(Specific) := (None, None, 26); -- Assign to view.
 355       Outer_Proc (Specific);                     -- Call dispatching op.
 356
 357       if Specific /= (Child_Outer, Child_Inner, 26, "-----") then
 358          Report.Failed ("Value or tag not preserved by assignment: Specific");
 359       end if;
 360
 361
 362       Parent_Type(ClassWide) := (None, None, 44); -- Assign to view.
 363       Outer_Proc (ClassWide);                     -- Call dispatching op.
 364
 365       if ClassWide /= Parent_Type'Class
 366                       (Grandchild_Type'(Grandchild_Outer,
 367                                         Grandchild_Inner,
 368                                         44,
 369                                         "Hello",
 370                                         "World"))
 371       then
 372          Report.Failed ("Value or tag not preserved by assignment: ClassWide");
 373       end if;
 374    end View_Conversion_Subtest;
 375
 376    Report.Result;
 377
 378 end C460006;