gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c7/c760012.a

   1 -- C760012.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 record components that have per-object access discriminant
  28 --      constraints are initialized in the order of their component
  29 --      declarations, and after any components that are not so constrained.
  30 --
  31 --      Check that record components that have per-object access discriminant
  32 --      constraints are finalized in the reverse order of their component
  33 --      declarations, and before any components that are not so constrained.
  34 --
  35 -- TEST DESCRIPTION:
  36 --      The type List_Item is the "container" type.  It holds two fields that
  37 --      have per-object access discriminant constraints, and two fields that
  38 --      are not discriminated.  These four fields are all controlled types.
  39 --      A fifth field is a pointer used to maintain a linked list of these
  40 --      data objects.  Each component is of a unique type which allows for
  41 --      the test to simply track the order of initialization and finalization.
  42 --
  43 --      The types and their purpose are:
  44 --        Constrained_First  - a controlled discriminated type
  45 --        Constrained_Second - a controlled discriminated type
  46 --        Simple_First       - a controlled type with no discriminant
  47 --        Simple_Second      - a controlled type with no discriminant
  48 --
  49 --      The required order of operations:
  50 --        Initialize
  51 --          ( Simple_First | Simple_Second )   -- no "internal order" required
  52 --          Constrained_First
  53 --          Constrained_Second
  54 --        Finalize
  55 --          Constrained_Second
  56 --          Constrained_First
  57 --          ( Simple_First | Simple_Second )   -- must be inverse of init.
  58 --
  59 --
  60 -- CHANGE HISTORY:
  61 --      23 MAY 95   SAIC    Initial version
  62 --      02 MAY 96   SAIC    Reorganized for 2.1
  63 --      05 DEC 96   SAIC    Simplified for 2.1; added init/fin ordering check
  64 --      31 DEC 97   EDS     Remove references to and uses of
  65 --                          Initialization_Sequence
  66 --!
  67
  68 ---------------------------------------------------------------- C760012_0
  69
  70 with Ada.Finalization;
  71 with Ada.Unchecked_Deallocation;
  72 package C760012_0 is
  73
  74   type List_Item;
  75
  76   type List is access all List_Item;
  77
  78   package Firsts is  -- distinguish first from second
  79     type Constrained_First(Container : access List_Item) is
  80            new Ada.Finalization.Limited_Controlled with null record;
  81     procedure Initialize( T : in out Constrained_First );
  82     procedure Finalize  ( T : in out Constrained_First );
  83
  84     type Simple_First is new Ada.Finalization.Controlled with
  85       record
  86         My_Init_Seq_Number : Natural;
  87       end record;
  88     procedure Initialize( T : in out Simple_First );
  89     procedure Finalize  ( T : in out Simple_First );
  90
  91   end Firsts;
  92
  93   type Constrained_Second(Container : access List_Item) is
  94          new Ada.Finalization.Limited_Controlled with null record;
  95   procedure Initialize( T : in out Constrained_Second );
  96   procedure Finalize  ( T : in out Constrained_Second );
  97
  98   type Simple_Second is new Ada.Finalization.Controlled with
  99     record
 100       My_Init_Seq_Number : Natural;
 101     end record;
 102   procedure Initialize( T : in out Simple_Second );
 103   procedure Finalize  ( T : in out Simple_Second );
 104
 105   -- by 3.8(18);6.0 the following type contains components constrained
 106   -- by per-object expressions
 107
 108
 109   type List_Item is new Ada.Finalization.Limited_Controlled
 110     with record
 111       ContentA : Firsts.Constrained_First( List_Item'Access ); -- C S
 112       SimpleA  : Firsts.Simple_First;                          -- A T
 113       SimpleB  : Simple_Second;                                -- A T
 114       ContentB : Constrained_Second( List_Item'Access );       -- D R
 115       Next     : List;                                         -- | |
 116     end record;                                                -- | |
 117   procedure Initialize( L : in out List_Item ); ------------------+ |
 118   procedure Finalize  ( L : in out List_Item ); --------------------+
 119
 120   -- the tags are the same for SimpleA and SimpleB due to the fact that
 121   -- the language does not specify an ordering with respect to this
 122   -- component pair. 7.6(12) does specify the rest of the ordering.
 123
 124   procedure Deallocate is new Ada.Unchecked_Deallocation(List_Item,List);
 125
 126 end C760012_0;
 127
 128 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 129
 130 with TCTouch;
 131 package body C760012_0 is
 132
 133   package body Firsts is
 134
 135     procedure Initialize( T : in out Constrained_First ) is
 136     begin
 137       TCTouch.Touch('C');   ----------------------------------------------- C
 138     end Initialize;
 139
 140     procedure Finalize  ( T : in out Constrained_First ) is
 141     begin
 142       TCTouch.Touch('S');   ----------------------------------------------- S
 143     end Finalize;
 144
 145     procedure Initialize( T : in out Simple_First ) is
 146     begin
 147       T.My_Init_Seq_Number := 0;
 148       TCTouch.Touch('A');   ----------------------------------------------- A
 149     end Initialize;
 150
 151     procedure Finalize  ( T : in out Simple_First ) is
 152     begin
 153       TCTouch.Touch('T');   ----------------------------------------------- T
 154     end Finalize;
 155
 156   end Firsts;
 157
 158   procedure Initialize( T : in out Constrained_Second ) is
 159   begin
 160     TCTouch.Touch('D');   ------------------------------------------------- D
 161   end Initialize;
 162
 163   procedure Finalize  ( T : in out Constrained_Second ) is
 164   begin
 165     TCTouch.Touch('R');   ------------------------------------------------- R
 166   end Finalize;
 167
 168
 169   procedure Initialize( T : in out Simple_Second ) is
 170   begin
 171     T.My_Init_Seq_Number := 0;
 172     TCTouch.Touch('A');   ------------------------------------------------- A
 173   end Initialize;
 174
 175   procedure Finalize  ( T : in out Simple_Second ) is
 176   begin
 177     TCTouch.Touch('T');   ------------------------------------------------- T
 178   end Finalize;
 179
 180   procedure Initialize( L : in out List_Item ) is
 181   begin
 182     TCTouch.Touch('F');   ------------------------------------------------- F
 183   end Initialize;
 184
 185   procedure Finalize  ( L : in out List_Item ) is
 186   begin
 187     TCTouch.Touch('Q');   ------------------------------------------------- Q
 188   end Finalize;
 189
 190 end C760012_0;
 191
 192 --------------------------------------------------------------------- C760012
 193
 194 with Report;
 195 with TCTouch;
 196 with C760012_0;
 197 procedure C760012 is
 198
 199   use type C760012_0.List;
 200
 201   procedure Subtest_1 is
 202   -- by 3.8(18);6.0 One_Of_Them is constrained by per-object constraints
 203   -- 7.6.1(9);6.0 dictates the order of finalization of the components
 204
 205     One_Of_Them : C760012_0.List_Item;
 206   begin
 207     if One_Of_Them.Next /= null then  -- just to hold the subtest in place
 208       Report.Failed("No default value for Next");
 209     end if;
 210   end Subtest_1;
 211
 212   List : C760012_0.List;
 213
 214   procedure Subtest_2 is
 215   begin
 216
 217     List := new C760012_0.List_Item;
 218
 219     List.Next := new C760012_0.List_Item;
 220
 221   end Subtest_2;
 222
 223   procedure Subtest_3 is
 224   begin
 225
 226     C760012_0.Deallocate( List.Next );
 227
 228     C760012_0.Deallocate( List );
 229
 230   end Subtest_3;
 231
 232 begin  -- Main test procedure.
 233
 234   Report.Test ("C760012", "Check that record components that have " &
 235                           "per-object access discriminant constraints " &
 236                           "are initialized in the order of their " &
 237                           "component declarations, and after any " &
 238                           "components that are not so constrained.  " &
 239                           "Check that record components that have " &
 240                           "per-object access discriminant constraints " &
 241                           "are finalized in the reverse order of their " &
 242                           "component declarations, and before any " &
 243                           "components that are not so constrained" );
 244
 245   Subtest_1;
 246   TCTouch.Validate("AACDFQRSTT", "One object");
 247
 248   Subtest_2;
 249   TCTouch.Validate("AACDFAACDF", "Two objects dynamically allocated");
 250
 251   Subtest_3;
 252   TCTouch.Validate("QRSTTQRSTT", "Two objects deallocated");
 253
 254   Report.Result;
 255
 256 end C760012;