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

   1 -- C460004.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 if the operand type of a type conversion is class-wide,
  28 --      Constraint_Error is raised if the tag of the operand does not
  29 --      identify a specific type that is covered by or descended from the
  30 --      target type.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      View conversions of class-wide operands to specific types are
  34 --      placed on the right and left sides of assignment statements, and
  35 --      conversions of class-wide operands to class-wide types are used
  36 --      as actual parameters to dispatching operations. In all cases, a
  37 --      check is made that Constraint_Error is raised if the tag of the
  38 --      operand does not identify a specific type covered by or descended
  39 --      from the target type, and not raised otherwise.
  40 --
  41 --      A specific type is descended from itself and from those types it is
  42 --      directly or indirectly derived from. A specific type is covered by
  43 --      itself and each class-wide type to whose class it belongs.
  44 --
  45 --      A class-wide type T'Class is descended from T and those types which
  46 --      T is descended from. A class-wide type is covered by each class-wide
  47 --      type to whose class it belongs.
  48 --
  49 --
  50 -- CHANGE HISTORY:
  51 --      19 Jul 95   SAIC    Initial prerelease version.
  52 --      18 Apr 96   SAIC    ACVC 2.1: Added a check for correct tag.
  53 --
  54 --!
  55 package C460004_0 is
  56
  57    type Tag_Type is tagged record
  58       C1 : Natural;
  59    end record;
  60
  61    procedure Proc (X : in out Tag_Type);
  62
  63
  64    type DTag_Type is new Tag_Type with record
  65       C2 : String (1 .. 5);
  66    end record;
  67
  68    procedure Proc (X : in out DTag_Type);
  69
  70
  71    type DDTag_Type is new DTag_Type with record
  72       C3 : String (1 .. 5);
  73    end record;
  74
  75    procedure Proc (X : in out DDTag_Type);
  76
  77    procedure NewProc (X : in DDTag_Type);
  78
  79    function CWFunc (X : Tag_Type'Class) return Tag_Type'Class;
  80
  81 end C460004_0;
  82
  83
  84      --==================================================================--
  85
  86 with Report;
  87 package body C460004_0 is
  88
  89    procedure Proc (X : in out Tag_Type) is
  90    begin
  91       X.C1 := 25;
  92    end Proc;
  93
  94    -----------------------------------------
  95    procedure Proc (X : in out DTag_Type) is
  96    begin
  97       Proc ( Tag_Type(X) );
  98       X.C2 := "Earth";
  99    end Proc;
 100
 101    -----------------------------------------
 102    procedure Proc (X : in out DDTag_Type) is
 103    begin
 104       Proc ( DTag_Type(X) );
 105       X.C3 := "Orbit";
 106    end Proc;
 107
 108    -----------------------------------------
 109    procedure NewProc (X : in DDTag_Type) is
 110       Y : DDTag_Type := X;
 111    begin
 112       Proc (Y);
 113    exception
 114       when others =>
 115          Report.Failed ("Unexpected exception in NewProc");
 116    end NewProc;
 117
 118    -----------------------------------------
 119    function CWFunc (X : Tag_Type'Class) return Tag_Type'Class is
 120       Y : Tag_Type'Class := X;
 121    begin
 122       Proc (Y);
 123       return Y;
 124    end CWFunc;
 125
 126 end C460004_0;
 127
 128
 129      --==================================================================--
 130
 131
 132 with C460004_0;
 133 use  C460004_0;
 134
 135 with Report;
 136 procedure C460004 is
 137
 138    Tag_Type_Init    :  constant Tag_Type   := (C1 => 0);
 139    DTag_Type_Init   :  constant DTag_Type  := (Tag_Type_Init with "Hello");
 140    DDTag_Type_Init  :  constant DDTag_Type := (DTag_Type_Init with "World");
 141
 142    Tag_Type_Value   :  constant Tag_Type   := (C1 => 25);
 143    DTag_Type_Value  :  constant DTag_Type  := (Tag_Type_Value  with "Earth");
 144    DDTag_Type_Value :  constant DDTag_Type := (DTag_Type_Value with "Orbit");
 145
 146 begin
 147
 148    Report.Test ("C460004", "Check that for a view conversion of a "      &
 149                 "class-wide operand, Constraint_Error is raised if the " &
 150                 "tag of the operand does not identify a specific type "  &
 151                 "covered by or descended from the target type");
 152
 153 --
 154 -- View conversion to specific type:
 155 --
 156
 157    declare
 158       procedure CW_Proc (P : Tag_Type'Class) is
 159          Target : Tag_Type := Tag_Type_Init;
 160       begin
 161          Target := Tag_Type(P);
 162          if (Target /= Tag_Type_Value) then
 163             Report.Failed ("Target has wrong value: #01");
 164          end if;
 165       exception
 166          when Constraint_Error =>
 167             Report.Failed ("Constraint_Error raised: #01");
 168          when others           =>
 169             Report.Failed ("Unexpected exception: #01");
 170       end CW_Proc;
 171
 172    begin
 173       CW_Proc (DDTag_Type_Value);
 174    end;
 175
 176    ----------------------------------------------------------------------
 177
 178    declare
 179       Target : DTag_Type := DTag_Type_Init;
 180    begin
 181       Target := DTag_Type(CWFunc(DDTag_Type_Value));
 182       if (Target /= DTag_Type_Value) then
 183          Report.Failed ("Target has wrong value: #02");
 184       end if;
 185    exception
 186       when Constraint_Error => Report.Failed ("Constraint_Error raised: #02");
 187       when others           => Report.Failed ("Unexpected exception: #02");
 188    end;
 189
 190    ----------------------------------------------------------------------
 191
 192    declare
 193       Target : DDTag_Type;
 194    begin
 195       Target := DDTag_Type(CWFunc(Tag_Type_Value));
 196                 -- CWFunc returns a Tag_Type; its tag is preserved through
 197                 -- the view conversion.  Constraint_Error should be raised.
 198
 199       Report.Failed ("Constraint_Error not raised: #03");
 200
 201    exception
 202       when Constraint_Error => null;                 -- expected exception
 203       when others           => Report.Failed ("Unexpected exception: #03");
 204    end;
 205
 206    ----------------------------------------------------------------------
 207
 208    declare
 209       procedure CW_Proc (P : Tag_Type'Class) is
 210       begin
 211          NewProc (DDTag_Type(P));
 212          Report.Failed ("Constraint_Error not raised: #04");
 213
 214       exception
 215          when Constraint_Error => null;              -- expected exception
 216          when others           => Report.Failed ("Unexpected exception: #04");
 217       end CW_Proc;
 218
 219    begin
 220       CW_Proc (DTag_Type_Value);
 221    end;
 222
 223    ----------------------------------------------------------------------
 224
 225    declare
 226       procedure CW_Proc (P : Tag_Type'Class) is
 227          Target : DDTag_Type := DDTag_Type_Init;
 228       begin
 229          Target := DDTag_Type(P);
 230          if (Target /= DDTag_Type_Value) then
 231             Report.Failed ("Target has wrong value: #05");
 232          end if;
 233
 234       exception
 235          when Constraint_Error =>
 236             Report.Failed ("Constraint_Error raised: #05");
 237          when others
 238             => Report.Failed ("Unexpected exception: #05");
 239       end CW_Proc;
 240
 241    begin
 242       CW_Proc (DDTag_Type_Value);
 243    end;
 244
 245
 246 --
 247 -- View conversion to class-wide type:
 248 --
 249
 250    declare
 251       procedure CW_Proc (P : Tag_Type'Class) is
 252          Operand : Tag_Type'Class := P;
 253       begin
 254          Proc( DTag_Type'Class(Operand) );
 255          Report.Failed ("Constraint_Error not raised: #06");
 256
 257       exception
 258          when Constraint_Error => null;              -- expected exception
 259          when others           => Report.Failed ("Unexpected exception: #06");
 260       end CW_Proc;
 261
 262    begin
 263       CW_Proc (Tag_Type_Init);
 264    end;
 265
 266    ----------------------------------------------------------------------
 267
 268    declare
 269       procedure CW_Proc (P : Tag_Type'Class) is
 270          Operand : Tag_Type'Class := P;
 271       begin
 272          Proc( DDTag_Type'Class(Operand) );
 273          Report.Failed ("Constraint_Error not raised: #07");
 274
 275       exception
 276          when Constraint_Error => null;              -- expected exception
 277          when others           => Report.Failed ("Unexpected exception: #07");
 278       end CW_Proc;
 279
 280    begin
 281       CW_Proc (Tag_Type_Init);
 282    end;
 283
 284    ----------------------------------------------------------------------
 285
 286    declare
 287       procedure CW_Proc (P : Tag_Type'Class) is
 288          Operand : Tag_Type'Class := P;
 289       begin
 290          Proc( DTag_Type'Class(Operand) );
 291          if Operand not in DTag_Type then
 292             Report.Failed ("Operand has wrong tag: #08");
 293          elsif (Operand /= Tag_Type'Class (DTag_Type_Value)) then
 294             Report.Failed ("Operand has wrong value: #08");
 295          end if;
 296
 297       exception
 298          when Constraint_Error =>
 299             Report.Failed ("Constraint_Error raised: #08");
 300          when others           =>
 301             Report.Failed ("Unexpected exception: #08");
 302       end CW_Proc;
 303
 304    begin
 305       CW_Proc (DTag_Type_Init);
 306    end;
 307
 308    ----------------------------------------------------------------------
 309
 310    declare
 311       procedure CW_Proc (P : Tag_Type'Class) is
 312          Operand : Tag_Type'Class := P;
 313       begin
 314          Proc( Tag_Type'Class(Operand) );
 315          if Operand not in DDTag_Type then
 316             Report.Failed ("Operand has wrong tag: #09");
 317          elsif (Operand /= Tag_Type'Class (DDTag_Type_Value)) then
 318             Report.Failed ("Operand has wrong value: #09");
 319          end if;
 320
 321       exception
 322          when Constraint_Error =>
 323             Report.Failed ("Constraint_Error raised: #09");
 324          when others           =>
 325             Report.Failed ("Unexpected exception: #09");
 326       end CW_Proc;
 327
 328    begin
 329       CW_Proc (DDTag_Type_Init);
 330    end;
 331
 332
 333    Report.Result;
 334
 335 end C460004;