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

   1 -- C760001.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 Initialize is called for objects and components of
  28 --      a controlled type when the objects and components are not
  29 --      assigned explicit initial values.  Check this for "simple" controlled
  30 --      objects, controlled record components and arrays with controlled
  31 --      components.
  32 --
  33 --      Check that if an explicit initial value is assigned to an object
  34 --      or component of a controlled type then Initialize is not called.
  35 --
  36 -- TEST DESCRIPTION:
  37 --      This test derives a type for Ada.Finalization.Controlled, and
  38 --      overrides the Initialize and Adjust operations for the type.  The
  39 --      intent of the type is that it should carry incremental values
  40 --      indicating the ordering of events with respect to these (and default
  41 --      initialization) operations.  The body of the test uses these values
  42 --      to determine that the implicit calls to these subprograms happen
  43 --      (or don't) at the appropriate times.
  44 --
  45 --      The test further derives types from this "root" type, which are the
  46 --      actual types used in the test.  One of the types is "simply" derived
  47 --      from the "root" type, the other contains a component of the first
  48 --      type, thus nesting a controlled object as a record component in
  49 --      controlled objects.
  50 --
  51 --      The main program declares objects of these types and checks the
  52 --      values of the components to ascertain that they have been touched
  53 --      as expected.
  54 --
  55 --      Note that Finalization procedures are provided.  This test does not
  56 --      test that the calls to Finalization are made correctly.  The
  57 --      Finalization procedures are provided to catch an implementation that
  58 --      calls Finalization at an incorrect time.
  59 --
  60 --
  61 -- CHANGE HISTORY:
  62 --      06 Dec 94   SAIC    ACVC 2.0
  63 --      10 Oct 95   SAIC    Update and repair for ACVC 2.0.1
  64 --
  65 --!
  66
  67 ---------------------------------------------------------------- C760001_0
  68
  69 with Ada.Finalization;
  70 package C760001_0 is
  71   subtype Unique_ID is Natural;
  72   function Unique_Value return Unique_ID;
  73   -- increments each time it's called
  74
  75   function Most_Recent_Unique_Value return Unique_ID;
  76   -- returns the same value as the most recent call to Unique_Value
  77
  78   type Root_Controlled is new Ada.Finalization.Controlled with record
  79     My_ID      : Unique_ID := Unique_Value;
  80     My_Init_ID : Unique_ID := Unique_ID'First;
  81     My_Adj_ID  : Unique_ID := Unique_ID'First;
  82   end record;
  83
  84   procedure Initialize( R: in out Root_Controlled );
  85   procedure Adjust    ( R: in out Root_Controlled );
  86
  87   TC_Initialize_Calls_Is_Failing : Boolean := False;
  88
  89 end C760001_0;
  90
  91 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
  92
  93 with Report;
  94 package body C760001_0 is
  95
  96   Global_Unique_Counter : Unique_ID := 0;
  97
  98   function Unique_Value return Unique_ID is
  99   begin
 100     Global_Unique_Counter := Global_Unique_Counter +1;
 101     return Global_Unique_Counter;
 102   end Unique_Value;
 103
 104   function Most_Recent_Unique_Value return Unique_ID is
 105   begin
 106     return Global_Unique_Counter;
 107   end Most_Recent_Unique_Value;
 108
 109   procedure Initialize( R: in out Root_Controlled ) is
 110   begin
 111     if TC_Initialize_Calls_Is_Failing then
 112       Report.Failed("Initialized incorrectly called");
 113     end if;
 114     R.My_Init_ID := Unique_Value;
 115   end Initialize;
 116
 117   procedure Adjust( R: in out Root_Controlled ) is
 118   begin
 119     R.My_Adj_ID := Unique_Value;
 120   end Adjust;
 121
 122 end C760001_0;
 123
 124 ---------------------------------------------------------------- C760001_1
 125
 126 with Ada.Finalization;
 127 with C760001_0;
 128 package C760001_1 is
 129
 130   type Proc_ID is (None, Init, Adj, Fin);
 131
 132   type Test_Controlled is new C760001_0.Root_Controlled with record
 133     Last_Proc_Called: Proc_ID := None;
 134   end record;
 135
 136   procedure Initialize( TC: in out Test_Controlled );
 137   procedure Adjust    ( TC: in out Test_Controlled );
 138   procedure Finalize  ( TC: in out Test_Controlled );
 139
 140   type Nested_Controlled is new C760001_0.Root_Controlled with record
 141     Nested : C760001_0.Root_Controlled;
 142     Last_Proc_Called: Proc_ID := None;
 143   end record;
 144
 145   procedure Initialize( TC: in out Nested_Controlled );
 146   procedure Adjust    ( TC: in out Nested_Controlled );
 147   procedure Finalize  ( TC: in out Nested_Controlled );
 148
 149 end C760001_1;
 150
 151 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 152
 153 with Report;
 154 package body C760001_1 is
 155
 156   procedure Initialize( TC: in out Test_Controlled ) is
 157   begin
 158     if TC.Last_Proc_Called /= None then
 159       Report.Failed("Initialize for Test_Controlled");
 160     end if;
 161     TC.Last_Proc_Called := Init;
 162     C760001_0.Initialize(C760001_0.Root_Controlled(TC));
 163   end Initialize;
 164
 165   procedure Adjust    ( TC: in out Test_Controlled ) is
 166   begin
 167     TC.Last_Proc_Called := Adj;
 168     C760001_0.Adjust(C760001_0.Root_Controlled(TC));
 169   end Adjust;
 170
 171   procedure Finalize  ( TC: in out Test_Controlled ) is
 172   begin
 173     TC.Last_Proc_Called := Fin;
 174   end Finalize;
 175
 176   procedure Initialize( TC: in out Nested_Controlled ) is
 177   begin
 178     if TC.Last_Proc_Called /= None then
 179       Report.Failed("Initialize for Nested_Controlled");
 180     end if;
 181     TC.Last_Proc_Called := Init;
 182     C760001_0.Initialize(C760001_0.Root_Controlled(TC));
 183   end Initialize;
 184
 185   procedure Adjust    ( TC: in out Nested_Controlled ) is
 186   begin
 187     TC.Last_Proc_Called := Adj;
 188     C760001_0.Adjust(C760001_0.Root_Controlled(TC));
 189   end Adjust;
 190
 191   procedure Finalize  ( TC: in out Nested_Controlled ) is
 192   begin
 193     TC.Last_Proc_Called := Fin;
 194   end Finalize;
 195
 196 end C760001_1;
 197
 198 ---------------------------------------------------------------- C760001
 199
 200 with Report;
 201 with TCTouch;
 202 with C760001_0;
 203 with C760001_1;
 204 with Ada.Finalization;
 205 procedure C760001 is
 206
 207   use type C760001_1.Proc_ID;
 208
 209   -- in the first test, test the simple case.  Check that a controlled object
 210   -- causes a call to the procedure Initialize.
 211   -- Also check that assignment causes a call to Adjust.
 212
 213   procedure Check_Simple_Objects is
 214     S,T : C760001_1.Test_Controlled;
 215   begin
 216     TCTouch.Assert(S.My_ID < S.My_Init_ID,"Default before dispatch");
 217     TCTouch.Assert((S.Last_Proc_Called = C760001_1.Init) and
 218                                         (T.Last_Proc_Called = C760001_1.Init),
 219                    "Initialize for simple object");
 220     S := T;
 221     TCTouch.Assert((S.Last_Proc_Called = C760001_1.Adj),
 222                    "Adjust for simple object");
 223     TCTouch.Assert((S.My_ID = T.My_ID),
 224                    "Simple object My_ID's don't match");
 225     TCTouch.Assert((S.My_Init_ID = T.My_Init_ID),
 226                    "Simple object My_Init_ID's don't match");
 227     TCTouch.Assert((S.My_Adj_ID > T.My_Adj_ID),
 228                    "Simple object My_Adj_ID's in wrong order");
 229   end Check_Simple_Objects;
 230
 231   -- in the second test, test a more complex case, check that a controlled
 232   -- component of a controlled object gets processed correctly
 233
 234   procedure Check_Nested_Objects is
 235     NO1 : C760001_1.Nested_Controlled;
 236   begin
 237     TCTouch.Assert((NO1.My_ID < NO1.My_Init_Id),
 238                    "Default value order incorrect");
 239     TCTouch.Assert((NO1.My_Init_Id > NO1.Nested.My_Init_ID),
 240                    "Initialization call order incorrect");
 241   end Check_Nested_Objects;
 242
 243   -- check that objects assigned an initial value at declaration are Adjusted
 244   -- and NOT Initialized
 245
 246   procedure Check_Objects_With_Initial_Values is
 247
 248     TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value;
 249
 250     A: C760001_1.Test_Controlled :=
 251       ( Ada.Finalization.Controlled
 252         with TC_Now,
 253              TC_Now,
 254              TC_Now,
 255              C760001_1.None);
 256
 257     B: C760001_1.Nested_Controlled :=
 258       ( Ada.Finalization.Controlled
 259         with TC_Now,
 260              TC_Now,
 261              TC_Now,
 262              C760001_0.Root_Controlled(A),
 263              C760001_1.None);
 264
 265   begin
 266     -- the implementation may or may not call Adjust for the values
 267     -- assigned into A and B,
 268     -- but should NOT call Initialize.
 269     -- if the value used in the aggregate is overwritten by Initialize,
 270     -- this indicates failure
 271     TCTouch.Assert(A.My_Init_Id = TC_Now,
 272                    "Initialize was called for A with initial value");
 273     TCTouch.Assert(B.My_Init_Id = TC_Now,
 274                    "Initialize was called for B with initial value");
 275     TCTouch.Assert(B.Nested.My_Init_ID = TC_Now,
 276                    "Initialize was called for B.Nested initial value");
 277   end Check_Objects_With_Initial_Values;
 278
 279   procedure Check_Array_Case is
 280     type Array_Simple is array(1..4) of C760001_1.Test_Controlled;
 281     type Array_Nested is array(1..4) of C760001_1.Nested_Controlled;
 282
 283     Simple_Array_Default : Array_Simple;
 284
 285     Nested_Array_Default : Array_Nested;
 286
 287     TC_A_Bit_Later : C760001_0.Unique_ID;
 288
 289   begin
 290     TC_A_Bit_Later := C760001_0.Unique_Value;
 291     for N in 1..4 loop
 292       TCTouch.Assert(Simple_Array_Default(N).Last_Proc_Called
 293                      = C760001_1.Init,
 294                      "Initialize for array initial value");
 295
 296       TCTouch.Assert( (Simple_Array_Default(N).My_Init_ID
 297                        > C760001_0.Unique_ID'First)
 298                       and (Simple_Array_Default(N).My_Init_ID
 299                        < TC_A_Bit_Later),
 300                      "Initialize timing for simple array");
 301
 302       TCTouch.Assert( (Nested_Array_Default(N).My_Init_ID
 303                        > C760001_0.Unique_ID'First)
 304                       and (Nested_Array_Default(N).My_Init_ID
 305                        < TC_A_Bit_Later),
 306                      "Initialize timing for container array");
 307
 308       TCTouch.Assert(Nested_Array_Default(N).Last_Proc_Called
 309                      = C760001_1.Init,
 310                      "Initialize for nested array (outer) initial value");
 311
 312       TCTouch.Assert( (Nested_Array_Default(N).Nested.My_Init_ID
 313                        > C760001_0.Unique_ID'First)
 314                       and (Nested_Array_Default(N).Nested.My_Init_ID
 315                        < Nested_Array_Default(N).My_Init_ID),
 316                      "Initialize timing for array content");
 317     end loop;
 318   end Check_Array_Case;
 319
 320   procedure Check_Array_Case_With_Initial_Values is
 321
 322     TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value;
 323
 324     type Array_Simple is array(1..4) of C760001_1.Test_Controlled;
 325     type Array_Nested is array(1..4) of C760001_1.Nested_Controlled;
 326
 327     Simple_Array_Explicit : Array_Simple := ( 1..4 => (
 328         Ada.Finalization.Controlled
 329         with TC_Now,
 330              TC_Now,
 331              TC_Now,
 332              C760001_1.None                 )         );
 333
 334     A : constant C760001_0.Root_Controlled :=
 335       ( Ada.Finalization.Controlled
 336         with others => TC_Now);
 337
 338     Nested_Array_Explicit : Array_Nested := ( 1..4 => (
 339         Ada.Finalization.Controlled
 340         with TC_Now,
 341              TC_Now,
 342              TC_Now,
 343              A,
 344              C760001_1.None                 )         );
 345
 346   begin
 347     -- the implementation may or may not call Adjust for the values
 348     -- assigned into Simple_Array_Explicit and Nested_Array_Explicit,
 349     -- but should NOT call Initialize.
 350     -- if the value used in the aggregate is overwritten by Initialize,
 351     -- this indicates failure
 352     for N in 1..4 loop
 353       TCTouch.Assert(Simple_Array_Explicit(N).My_Init_ID
 354                      = TC_Now,
 355                      "Initialize was called for array with initial value");
 356       TCTouch.Assert(Nested_Array_Explicit(N).My_Init_ID
 357                      = TC_Now,
 358         "Initialize was called for nested array (outer) with initial value");
 359       TCTouch.Assert(Nested_Array_Explicit(N).Nested.My_Init_ID = TC_Now,
 360         "Initialize was called for nested array (inner) with initial value");
 361     end loop;
 362   end Check_Array_Case_With_Initial_Values;
 363
 364 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 365
 366 begin  -- Main test procedure.
 367
 368   Report.Test ("C760001", "Check that Initialize is called for objects " &
 369                           "and components of a controlled type when the " &
 370                           "objects and components are not assigned " &
 371                           "explicit initial values.  Check that if an " &
 372                           "explicit initial value is assigned to an " &
 373                           "object or component of a controlled type " &
 374                           "then Initialize is not called" );
 375
 376   Check_Simple_Objects;
 377
 378   Check_Nested_Objects;
 379
 380   Check_Array_Case;
 381
 382   C760001_0.TC_Initialize_Calls_Is_Failing := True;
 383
 384   Check_Objects_With_Initial_Values;
 385
 386   Check_Array_Case_With_Initial_Values;
 387
 388   Report.Result;
 389
 390 end C760001;