gomp-20050608-branch/gcc/testsuite/ada/acats/tests/cd/cde0001.a

   1 -- CDE0001.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 following names can be used in the declaration of a
  28 --      generic formal parameter (object, array type, or access type) without
  29 --      causing freezing of the named type:
  30 --        (1) The name of a private type,
  31 --        (2) A name that denotes a subtype of a private type, and
  32 --        (3) A name that denotes a composite type with a subcomponent of a
  33 --           private type (or subtype).
  34 --      Check for untagged and tagged types.
  35 --
  36 -- TEST DESCRIPTION:
  37 --      This transition test defines private and limited private types,
  38 --      subtypes of these private types, records and arrays of both types and
  39 --      subtypes, a tagged type and a private extension.
  40 --      This test creates examples where the above types are used in the
  41 --      definition of several generic formal type parameters (object, array
  42 --      type, or access type) in both visible and private parts.  These
  43 --      visible and private generic packages are instantiated in the body of
  44 --      the public child and the private child, respectively.
  45 --      The main program utilizes the functions declared in the public child
  46 --      to verify results of the instantiations.
  47 --
  48 --      Inspired by B74103F.ADA.
  49 --
  50 --
  51 -- CHANGE HISTORY:
  52 --      12 Mar 96   SAIC    Initial version for ACVC 2.1.
  53 --      05 Oct 96   SAIC    ACVC 2.1: Added pragma Elaborate for CDE0001.
  54 --      21 Nov 98   RLB     Added pragma Elaborate for CDE0001 to CDE0001_3.
  55 --!
  56
  57 package CDE0001_0 is
  58
  59    subtype Small_Int is Integer range 1 .. 2;
  60
  61    type Private_Type    is private;
  62    type Limited_Private is limited private;
  63
  64    subtype Private_Subtype         is Private_Type;
  65    subtype Limited_Private_Subtype is Limited_Private;
  66
  67    type Array_Of_LP_Subtype is array (1..2) of Limited_Private_Subtype;
  68
  69    type Rec_Of_Limited_Private is
  70      record
  71         C1 : Limited_Private;
  72      end record;
  73
  74    type Rec_Of_Private_SubType is
  75      record
  76         C1 : Private_SubType;
  77      end record;
  78
  79    type Tag_Type is tagged
  80      record
  81         C1 : Small_Int;
  82      end record;
  83
  84    type New_TagType is new Tag_Type with private;
  85
  86    generic
  87
  88       Formal_Obj01 : in out Private_Type;              -- Formal objects defined
  89       Formal_Obj02 : in out Limited_Private;           -- by names of private
  90       Formal_Obj03 : in out Private_Subtype;           -- types, names that
  91       Formal_Obj04 : in out Limited_Private_Subtype;   -- denotes subtypes of
  92       Formal_Obj05 : in out New_TagType;               -- the private types.
  93
  94    package CDE0001_1 is
  95       procedure Assign_Objects;
  96
  97    end CDE0001_1;
  98
  99 private
 100
 101    generic
 102       -- Formal array types of a private type, a composite type with a
 103       -- subcomponent of a private type.
 104
 105       type Formal_Arr01 is array (Small_Int) of Private_Type;
 106       type Formal_Arr02 is array (Small_Int) of Rec_Of_Limited_Private;
 107
 108       -- Formal access types of composite types with a subcomponent of
 109       -- a private subtype.
 110
 111       type Formal_Acc01 is access Rec_Of_Private_Subtype;
 112       type Formal_Acc02 is access Array_Of_LP_Subtype;
 113
 114    package CDE0001_2 is
 115
 116       procedure Assign_Arrays (P1 : out Formal_Arr01;
 117                                P2 : out Formal_Arr02);
 118
 119       procedure Assign_Access (P1 : out Formal_Acc01;
 120                                P2 : out Formal_Acc02);
 121
 122    end CDE0001_2;
 123
 124    ----------------------------------------------------------
 125    type Private_Type    is range 1 .. 10;
 126    type Limited_Private is (Eh, Bee, Sea, Dee);
 127    type New_TagType     is new Tag_Type with
 128      record
 129         C2 : Private_Type;
 130      end record;
 131
 132 end CDE0001_0;
 133
 134      --==================================================================--
 135
 136 package body CDE0001_0 is
 137
 138    package body CDE0001_1 is
 139
 140       procedure Assign_Objects is
 141       begin
 142          Formal_Obj01 := Private_Type'First;
 143          Formal_Obj02 := Limited_Private'Last;
 144          Formal_Obj03 := Private_Subtype'Last;
 145          Formal_Obj04 := Limited_Private_Subtype'First;
 146          Formal_Obj05 := New_TagType'(C1 => 2, C2 => Private_Type'Last);
 147
 148       end Assign_Objects;
 149
 150    end CDE0001_1;
 151
 152    --===========================================================--
 153
 154    package body CDE0001_2 is
 155
 156       procedure Assign_Arrays (P1 : out Formal_Arr01;
 157                                P2 : out Formal_Arr02) is
 158       begin
 159          P1(1)    := Private_Type'Pred(Private_Type'Last);
 160          P1(2)    := Private_Type'Succ(Private_Type'First);
 161          P2(1).C1 := Limited_Private'Succ(Limited_Private'First);
 162          P2(2).C1 := Limited_Private'Pred(Limited_Private'Last);
 163
 164       end Assign_Arrays;
 165
 166       -----------------------------------------------------------------
 167       procedure Assign_Access (P1 : out Formal_Acc01;
 168                                P2 : out Formal_Acc02) is
 169       begin
 170          P1 := new Rec_Of_Private_Subtype'(C1 => Private_Subtype'Last);
 171          P2 := new Array_Of_LP_Subtype'(Eh, Dee);
 172
 173       end Assign_Access;
 174
 175    end CDE0001_2;
 176
 177 end CDE0001_0;
 178
 179      --==================================================================--
 180
 181 -- The following private child package instantiates its parent private generic
 182 -- package.
 183
 184 with CDE0001_0;
 185 pragma Elaborate (CDE0001_0); -- So generic unit can be instantiated.
 186 private
 187 package CDE0001_0.CDE0001_3 is
 188
 189    type Arr01 is array (Small_Int) of Private_Type;
 190    type Arr02 is array (Small_Int) of Rec_Of_Limited_Private;
 191    type Acc01 is access Rec_Of_Private_Subtype;
 192    type Acc02 is access Array_Of_LP_Subtype;
 193
 194    package Formal_Types_Pck is new CDE0001_2 (Arr01, Arr02, Acc01, Acc02);
 195
 196    Arr01_Obj : Arr01;
 197    Arr02_Obj : Arr02;
 198    Acc01_Obj : Acc01;
 199    Acc02_Obj : Acc02;
 200
 201 end CDE0001_0.CDE0001_3;
 202
 203      --==================================================================--
 204
 205 package CDE0001_0.CDE0001_4 is
 206
 207    -- The following functions check the private types defined in the parent
 208    -- and the private child package from within the client program.
 209
 210    function Verify_Objects return Boolean;
 211
 212    function Verify_Arrays return Boolean;
 213
 214    function Verify_Access return Boolean;
 215
 216 end CDE0001_0.CDE0001_4;
 217
 218      --==================================================================--
 219
 220 with CDE0001_0.CDE0001_3;            -- private sibling.
 221
 222 pragma Elaborate (CDE0001_0.CDE0001_3);
 223
 224 package body CDE0001_0.CDE0001_4 is
 225
 226    Obj1 : Private_Type            := 2;
 227    Obj2 : Limited_Private         := Bee;
 228    Obj3 : Private_Subtype         := 3;
 229    Obj4 : Limited_Private_Subtype := Sea;
 230    Obj5 : New_TagType             := (1, 5);
 231
 232    -- Instantiate the generic package declared in the visible part of
 233    -- the parent.
 234
 235    package Formal_Obj_Pck is new CDE0001_1 (Obj1, Obj2, Obj3, Obj4, Obj5);
 236
 237    ---------------------------------------------------
 238    function Verify_Objects return Boolean is
 239       Result : Boolean := False;
 240    begin
 241       if Obj1    = 1    and
 242          Obj2    = Dee  and
 243          Obj3    = 10   and
 244          Obj4    = Eh   and
 245          Obj5.C1 = 2    and
 246          Obj5.C2 = 10   then
 247            Result := True;
 248       end if;
 249
 250       return Result;
 251
 252    end Verify_Objects;
 253
 254    ---------------------------------------------------
 255    function Verify_Arrays return Boolean is
 256       Result : Boolean := False;
 257    begin
 258       if CDE0001_0.CDE0001_3.Arr01_Obj(1)    = 9     and
 259          CDE0001_0.CDE0001_3.Arr01_Obj(2)    = 2     and
 260          CDE0001_0.CDE0001_3.Arr02_Obj(1).C1 = Bee   and
 261          CDE0001_0.CDE0001_3.Arr02_Obj(2).C1 = Sea   then
 262            Result := True;
 263       end if;
 264
 265       return Result;
 266
 267    end Verify_Arrays;
 268
 269    ---------------------------------------------------
 270    function Verify_Access return Boolean is
 271       Result : Boolean := False;
 272    begin
 273       if CDE0001_0.CDE0001_3.Acc01_Obj.C1  = 10   and
 274          CDE0001_0.CDE0001_3.Acc02_Obj(1)  = Eh   and
 275          CDE0001_0.CDE0001_3.Acc02_Obj(2)  = Dee  then
 276             Result := True;
 277       end if;
 278
 279       return Result;
 280
 281    end Verify_Access;
 282
 283 begin
 284
 285    Formal_Obj_Pck.Assign_Objects;
 286
 287    CDE0001_0.CDE0001_3.Formal_Types_Pck.Assign_Arrays
 288      (CDE0001_0.CDE0001_3.Arr01_Obj, CDE0001_0.CDE0001_3.Arr02_Obj);
 289    CDE0001_0.CDE0001_3.Formal_Types_Pck.Assign_Access
 290      (CDE0001_0.CDE0001_3.Acc01_Obj, CDE0001_0.CDE0001_3.Acc02_Obj);
 291
 292 end CDE0001_0.CDE0001_4;
 293
 294      --==================================================================--
 295
 296 with Report;
 297 with CDE0001_0.CDE0001_4;
 298
 299 procedure CDE0001 is
 300
 301 begin
 302
 303    Report.Test ("CDE0001", "Check that the name of the private type, a "  &
 304                 "name that denotes a subtype of the private type, or a "  &
 305                 "name that denotes a composite type with a subcomponent " &
 306                 "of a private type can be used in the declaration of a "  &
 307                 "generic formal type parameter without causing freezing " &
 308                 "of the named type");
 309
 310    if not CDE0001_0.CDE0001_4.Verify_Objects then
 311       Report.Failed ("Wrong values for formal objects");
 312    end if;
 313
 314    if not CDE0001_0.CDE0001_4.Verify_Arrays then
 315       Report.Failed ("Wrong values for formal array types");
 316    end if;
 317
 318    if not CDE0001_0.CDE0001_4.Verify_Access then
 319       Report.Failed ("Wrong values for formal access types");
 320    end if;
 321
 322    Report.Result;
 323
 324 end CDE0001;