gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c3/c330001.a

   1 -- C330001.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 variable object of an indefinite type is properly
  28 --      initialized/constrained by an initial value assignment that is
  29 --      a) an aggregate, b) a function, or c) an object.  Check that objects
  30 --      of the above types do not need explicit constraints if they have
  31 --      initial values.
  32 --
  33 -- TEST DESCRIPTION:
  34 --      An indefinite subtype is either:
  35 --         a) An unconstrained array subtype.
  36 --         b) A subtype with unknown discriminants.
  37 --         c) A subtype with unconstrained discriminants without defaults.
  38 --
  39 --      Declare several indefinite types in a parent package specification.
  40 --      In the private part, complete one type with a discriminant without
  41 --      default (indefinite) and the other with a default discriminant
  42 --      (definite).  Declare objects of both indefinite and definite subtypes
  43 --      in children (private and public) with initialization expressions.  The
  44 --      test verifies all values of the objects.  It also verifies that
  45 --      Constraint_Error is raised if an attempt is made to change the
  46 --      discriminants of the objects of the indefinite subtypes.
  47 --
  48 --
  49 -- CHANGE HISTORY:
  50 --      15 Jan 95   SAIC    Initial version for ACVC 2.1
  51 --      25 Jul 96   SAIC    Modified test description. Deleted use C330001_0.
  52 --      20 Nov 98   RLB     Added Elaborate pragmas to avoid problems
  53 --                          with an unconventional, but legal, elaboration
  54 --                          order.
  55 --!
  56
  57 package C330001_0 is
  58
  59    subtype Sub_Type is Integer range 1 .. 20;
  60
  61    type Tag_W_Disc (D : Sub_Type) is tagged record
  62        C1 :  String (1 .. D);
  63    end record;
  64
  65    -- Indefinite type declarations.
  66
  67    type FullViewDefinite_Unknown_Disc (<>) is private;
  68
  69    type Indefinite_No_Disc is array (Positive range <>) of Integer;
  70
  71    type Indefinite_Tag_W_Disc (D : Sub_Type) is tagged
  72      record
  73         C1 : Boolean := False;
  74      end record;
  75
  76    type Indefinite_New_W_Disc (ND : Sub_Type) is new
  77      Indefinite_Tag_W_Disc (ND) with record
  78         C2 : Integer := 9;
  79      end record;
  80
  81    type Indefinite_W_Inherit_Disc_1 is new Tag_W_Disc with
  82      record
  83         S : Sub_Type := 18;
  84      end record;
  85
  86    type Indefinite_W_Inherit_Disc_2 is
  87      new Tag_W_Disc with private;
  88
  89    function Indef_Func_1 return FullViewDefinite_Unknown_Disc;
  90
  91    function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2;
  92
  93 private
  94
  95    type FullViewDefinite_Unknown_Disc (D : Sub_Type := 2) is
  96       record
  97         S : String (1 .. D) := "Hi";
  98       end record;
  99
 100    type Indefinite_W_Inherit_Disc_2 is new Tag_W_Disc with
 101       record
 102         S : Sub_Type;
 103       end record;
 104
 105 end C330001_0;
 106
 107      --==================================================================--
 108
 109 package body C330001_0 is
 110
 111    function Indef_Func_1 return FullViewDefinite_Unknown_Disc is
 112       Var_1 : FullViewDefinite_Unknown_Disc;      -- No need for explicit
 113                                                   -- constraints, use initial
 114    begin                                          -- values.
 115       return Var_1;
 116    end Indef_Func_1;
 117
 118    ------------------------------------------------------------------
 119    function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2 is
 120       Var_2 : Indefinite_W_Inherit_Disc_2 := (D => 5, C1 => "Hello", S => P);
 121    begin
 122       return Var_2;
 123    end Indef_Func_2;
 124
 125 end C330001_0;
 126
 127      --==================================================================--
 128
 129 with C330001_0;
 130 pragma Elaborate(C330001_0); -- Insure that the functions can be called.
 131 private
 132 package C330001_0.C330001_1 is
 133
 134    PrivateChild_Obj    : Tag_W_Disc := (D => 4, C1 => "ACVC");
 135
 136    PrivateChild_Obj_01 : Indefinite_W_Inherit_Disc_1
 137      := Indefinite_W_Inherit_Disc_1'(PrivateChild_Obj with S => 15);
 138
 139    -- Since full view of Indefinite_W_Inherit_Disc_2 is indefinite in
 140    -- the parent package, Indefinite_W_Inherit_Disc_2 needs an initialization
 141    -- expression.
 142
 143    PrivateChild_Obj_02 : Indefinite_W_Inherit_Disc_2 := Indef_Func_2 (19);
 144
 145    -- Since full view of FullViewDefinite_Unknown_Disc is definite in the
 146    -- parent package, no initialization expression needed for
 147    -- PrivateChild_Obj_03.
 148
 149    PrivateChild_Obj_03 : FullViewDefinite_Unknown_Disc;
 150
 151    PrivateChild_Obj_04 : Indefinite_No_Disc          := (12, 15);
 152
 153 end C330001_0.C330001_1;
 154
 155      --==================================================================--
 156
 157 with C330001_0;
 158 pragma Elaborate(C330001_0); -- Insure that the functions can be called.
 159 package C330001_0.C330001_2 is
 160
 161    PublicChild_Obj_01 : FullViewDefinite_Unknown_Disc := Indef_Func_1;
 162
 163    PublicChild_Obj_02 : Indefinite_W_Inherit_Disc_2   := Indef_Func_2 (4);
 164
 165    PublicChild_Obj_03 : Indefinite_No_Disc            := (38, 72, 21, 59);
 166
 167    PublicChild_Obj_04 : Indefinite_Tag_W_Disc         := (D => 7, C1 => True);
 168
 169    PublicChild_Obj_05 : Indefinite_Tag_W_Disc         := PublicChild_Obj_04;
 170
 171    PublicChild_Obj_06 : Indefinite_New_W_Disc (6);
 172
 173    procedure Assign_Private_Obj_3;
 174
 175    function Raised_CE_PublicChild_Obj return Boolean;
 176
 177    function Raised_CE_PrivateChild_Obj return Boolean;
 178
 179    -- The following functions check the private types defined in the parent
 180    -- and the private child package from within the client program.
 181
 182    function Verify_Public_Obj_1 return Boolean;
 183
 184    function Verify_Public_Obj_2 return Boolean;
 185
 186    function Verify_Private_Obj_1 return Boolean;
 187
 188    function Verify_Private_Obj_2 return Boolean;
 189
 190    function Verify_Private_Obj_3 return Boolean;
 191
 192 end C330001_0.C330001_2;
 193
 194      --==================================================================--
 195
 196 with Report;
 197 with C330001_0.C330001_1;
 198 package body C330001_0.C330001_2 is
 199
 200    procedure Assign_Private_Obj_3 is
 201    begin
 202       C330001_0.C330001_1.PrivateChild_Obj_03 := (5, "Aloha");
 203    end Assign_Private_Obj_3;
 204
 205    ------------------------------------------------------------------
 206    function Raised_CE_PublicChild_Obj return Boolean is
 207    begin
 208       PublicChild_Obj_03 := (16, 13);       -- C_E, can't change constraints
 209                                             -- of PublicChild_Obj_03.
 210
 211       Report.Failed ("Constraint_Error not raised - Public child");
 212
 213       -- Next line prevents dead assignment.
 214
 215       Report.Comment ("PublicChild_Obj_03'First is" & Integer'Image
 216                       (PublicChild_Obj_03'First) );
 217       return False;
 218
 219    exception
 220       when Constraint_Error =>
 221          return True;                       -- Exception is expected.
 222       when others           =>
 223          return False;
 224    end Raised_CE_PublicChild_Obj;
 225
 226    ------------------------------------------------------------------
 227    function Raised_CE_PrivateChild_Obj return Boolean is
 228    begin
 229       C330001_0.C330001_1.PrivateChild_Obj_04 := (21, 87, 18);
 230                                             -- C_E, can't change constraints
 231                                             -- of PrivateChild_Obj_04.
 232
 233       Report.Failed ("Constraint_Error not raised - Private child");
 234
 235       -- Next line prevents dead assignment.
 236
 237       Report.Comment ("PrivateChild_Obj_04'Last is" & Integer'Image
 238                       (C330001_0.C330001_1.PrivateChild_Obj_04'Last) );
 239       return False;
 240
 241    exception
 242       when Constraint_Error =>
 243          return True;                       -- Exception is expected.
 244       when others           =>
 245          return False;
 246    end Raised_CE_PrivateChild_Obj;
 247
 248    ------------------------------------------------------------------
 249    function Verify_Public_Obj_1 return Boolean is
 250    begin
 251       return (PublicChild_Obj_01.D = 2 and PublicChild_Obj_01.S = "Hi");
 252
 253    end Verify_Public_Obj_1;
 254
 255    ------------------------------------------------------------------
 256    function Verify_Public_Obj_2 return Boolean is
 257    begin
 258       return (PublicChild_Obj_02.D  = 5       and
 259               PublicChild_Obj_02.C1 = "Hello" and
 260               PublicChild_Obj_02.S  = 4);
 261
 262    end Verify_Public_Obj_2;
 263
 264    ------------------------------------------------------------------
 265    function Verify_Private_Obj_1 return Boolean is
 266    begin
 267       return (C330001_0.C330001_1.PrivateChild_Obj_01.D  = 4      and
 268               C330001_0.C330001_1.PrivateChild_Obj_01.C1 = "ACVC" and
 269               C330001_0.C330001_1.PrivateChild_Obj_01.S  = 15);
 270
 271    end Verify_Private_Obj_1;
 272
 273    ------------------------------------------------------------------
 274    function Verify_Private_Obj_2 return Boolean is
 275    begin
 276       return (C330001_0.C330001_1.PrivateChild_Obj_02.D  = 5       and
 277               C330001_0.C330001_1.PrivateChild_Obj_02.C1 = "Hello" and
 278               C330001_0.C330001_1.PrivateChild_Obj_02.S  = 19);
 279
 280    end Verify_Private_Obj_2;
 281
 282    ------------------------------------------------------------------
 283    function Verify_Private_Obj_3 return Boolean is
 284    begin
 285       return (C330001_0.C330001_1.PrivateChild_Obj_03.D = 5 and
 286               C330001_0.C330001_1.PrivateChild_Obj_03.S = "Aloha");
 287
 288    end Verify_Private_Obj_3;
 289
 290 end C330001_0.C330001_2;
 291
 292      --==================================================================--
 293
 294 with C330001_0.C330001_2;
 295 with Report;
 296
 297 use  C330001_0.C330001_2;
 298
 299 procedure C330001 is
 300 begin
 301    Report.Test ("C330001", "Check that a variable object of an indefinite " &
 302                 "type is properly initialized/constrained by an initial "   &
 303                 "value assignment that is a) an aggregate, b) a function, " &
 304                 "or c) an object.  Check that objects of the above types "  &
 305                 "do not need explicit constraints if they have initial "    &
 306                 "values");
 307
 308    -- Verify values of public child objects.
 309
 310    if not (Verify_Public_Obj_1 and Verify_Public_Obj_2) then
 311       Report.Failed ("Wrong values for PublicChild_Obj_01 or " &
 312                      "PublicChild_Obj_02");
 313    end if;
 314
 315    if PublicChild_Obj_03'First /= 1 or
 316       PublicChild_Obj_03'Last  /= 4 then
 317       Report.Failed ("Wrong values for PublicChild_Obj_03");
 318    end if;
 319
 320    if PublicChild_Obj_05.D  /= 7 or
 321       not PublicChild_Obj_05.C1  then
 322       Report.Failed ("Wrong values for PublicChild_Obj_05");
 323    end if;
 324
 325    if PublicChild_Obj_06.ND /= 6 or
 326       PublicChild_Obj_06.C2 /= 9 or
 327       PublicChild_Obj_06.C1      then
 328       Report.Failed ("Wrong values for PublicChild_Obj_06");
 329    end if;
 330
 331    -- Definite object can have its discriminant changed by assignment to
 332    -- the entire object.
 333
 334    Assign_Private_Obj_3;
 335
 336    -- Verify values of private child objects.
 337
 338    if not Verify_Private_Obj_1 or not
 339           Verify_Private_Obj_2 or not
 340           Verify_Private_Obj_3 then
 341       Report.Failed ("Wrong values for PrivateChild_Obj_01 or " &
 342                      "PrivateChild_Obj_02 or PrivateChild_Obj_03");
 343    end if;
 344
 345    -- Attempt to change the discriminants of the objects of the indefinite
 346    -- subtypes:  Constraint_Error.
 347
 348    if not Raised_CE_PublicChild_Obj or not Raised_CE_PrivateChild_Obj then
 349       Report.Failed ("Constraint_Error not raised");
 350    end if;
 351
 352    Report.Result;
 353
 354 end C330001;