old-autovect-branch/gcc/testsuite/ada/acats/tests/c7/c760002.a

   1 -- C760002.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 assignment to an object of a (non-limited) controlled
  28 --      type causes the Adjust operation of the type to be called.
  29 --      Check that Adjust is called after copying the value of the
  30 --      source expression to the target object.
  31 --
  32 --      Check that Adjust is called for all controlled components when
  33 --      the containing object is assigned.  (Test this for the cases
  34 --      where the type of the containing object is controlled and
  35 --      noncontrolled; test this for initialization as well as
  36 --      assignment statements.)
  37 --
  38 --      Check that for an object of a controlled type with controlled
  39 --      components, Adjust for each of the components is called before
  40 --      the containing object is adjusted.
  41 --
  42 --      Check that an Adjust procedure for a Limited_Controlled type is
  43 --      not called by the implementation.
  44 --
  45 -- TEST DESCRIPTION:
  46 --      This test is loosely "derived" from C760001.
  47 --
  48 --      Visit Tags:
  49 --        D - Default value at declaration
  50 --        d - Default value at declaration, limited root
  51 --        I - initialize at root controlled
  52 --        i - initialize at root limited controlled
  53 --        A - adjust at root controlled
  54 --        X,Y,Z,x,y,z - used in test body
  55 --
  56 --
  57 -- CHANGE HISTORY:
  58 --      06 Dec 94   SAIC    ACVC 2.0
  59 --      19 Dec 94   SAIC    Correct test assertion logic for Sinister case
  60 --
  61 --!
  62
  63 ---------------------------------------------------------------- C760002_0
  64
  65 with Ada.Finalization;
  66 package C760002_0 is
  67   subtype Unique_ID is Natural;
  68   function Unique_Value return Unique_ID;
  69   -- increments each time it's called
  70
  71   function Most_Recent_Unique_Value return Unique_ID;
  72   -- returns the same value as the most recent call to Unique_Value
  73
  74   type Root is tagged record
  75     My_ID      : Unique_ID := Unique_Value;
  76     Visit_Tag  : Character := 'D';  -- Default
  77   end record;
  78
  79   procedure Initialize( R: in out Root );
  80   procedure Adjust    ( R: in out Root );
  81
  82   type Root_Controlled is new Ada.Finalization.Controlled with record
  83     My_ID      : Unique_ID := Unique_Value;
  84     Visit_Tag  : Character := 'D'; ---------------------------------------- D
  85   end record;
  86
  87   procedure Initialize( R: in out Root_Controlled );
  88   procedure Adjust    ( R: in out Root_Controlled );
  89
  90   type Root_Limited_Controlled is
  91        new Ada.Finalization.Limited_Controlled with record
  92     My_ID      : Unique_ID := Unique_Value;
  93     Visit_Tag  : Character := 'd'; ---------------------------------------- d
  94   end record;
  95
  96   procedure Initialize( R: in out Root_Limited_Controlled );
  97   procedure Adjust    ( R: in out Root_Limited_Controlled );
  98
  99 end C760002_0;
 100
 101 with Report;
 102 package body C760002_0 is
 103
 104   Global_Unique_Counter : Unique_ID := 0;
 105
 106   function Unique_Value return Unique_ID is
 107   begin
 108     Global_Unique_Counter := Global_Unique_Counter +1;
 109     return Global_Unique_Counter;
 110   end Unique_Value;
 111
 112   function Most_Recent_Unique_Value return Unique_ID is
 113   begin
 114     return Global_Unique_Counter;
 115   end Most_Recent_Unique_Value;
 116
 117   procedure Initialize( R: in out Root ) is
 118   begin
 119     Report.Failed("Initialize called for Non_Controlled type");
 120   end Initialize;
 121
 122   procedure Adjust    ( R: in out Root ) is
 123   begin
 124     Report.Failed("Adjust called for Non_Controlled type");
 125   end Adjust;
 126
 127   procedure Initialize( R: in out Root_Controlled ) is
 128   begin
 129     R.Visit_Tag := 'I'; --------------------------------------------------- I
 130   end Initialize;
 131
 132   procedure Adjust( R: in out Root_Controlled ) is
 133   begin
 134     R.Visit_Tag := 'A'; --------------------------------------------------- A
 135   end Adjust;
 136
 137   procedure Initialize( R: in out Root_Limited_Controlled ) is
 138   begin
 139     R.Visit_Tag := 'i'; --------------------------------------------------- i
 140   end Initialize;
 141
 142   procedure Adjust( R: in out Root_Limited_Controlled ) is
 143   begin
 144     Report.Failed("Adjust called for Limited_Controlled type");
 145   end Adjust;
 146
 147 end C760002_0;
 148
 149 ---------------------------------------------------------------- C760002_1
 150
 151 with Ada.Finalization;
 152 with C760002_0;
 153 package C760002_1 is
 154
 155   type Proc_ID is (None, Init, Adj, Fin);
 156
 157   type Test_Controlled is new C760002_0.Root_Controlled with record
 158     Last_Proc_Called: Proc_ID := None;
 159   end record;
 160
 161   procedure Initialize( TC: in out Test_Controlled );
 162   procedure Adjust    ( TC: in out Test_Controlled );
 163   procedure Finalize  ( TC: in out Test_Controlled );
 164
 165   type Nested_Controlled is new C760002_0.Root_Controlled with record
 166     Nested : C760002_0.Root_Controlled;
 167     Last_Proc_Called: Proc_ID := None;
 168   end record;
 169
 170   procedure Initialize( TC: in out Nested_Controlled );
 171   procedure Adjust    ( TC: in out Nested_Controlled );
 172   procedure Finalize  ( TC: in out Nested_Controlled );
 173
 174   type Test_Limited_Controlled is
 175        new C760002_0.Root_Limited_Controlled with record
 176     Last_Proc_Called: Proc_ID := None;
 177   end record;
 178
 179   procedure Initialize( TC: in out Test_Limited_Controlled );
 180   procedure Adjust    ( TC: in out Test_Limited_Controlled );
 181   procedure Finalize  ( TC: in out Test_Limited_Controlled );
 182
 183   type Nested_Limited_Controlled is
 184        new C760002_0.Root_Limited_Controlled with record
 185     Nested : C760002_0.Root_Limited_Controlled;
 186     Last_Proc_Called: Proc_ID := None;
 187   end record;
 188
 189   procedure Initialize( TC: in out Nested_Limited_Controlled );
 190   procedure Adjust    ( TC: in out Nested_Limited_Controlled );
 191   procedure Finalize  ( TC: in out Nested_Limited_Controlled );
 192
 193 end C760002_1;
 194
 195 with Report;
 196 package body C760002_1 is
 197
 198   procedure Initialize( TC: in out Test_Controlled ) is
 199   begin
 200     TC.Last_Proc_Called := Init;
 201     C760002_0.Initialize(C760002_0.Root_Controlled(TC));
 202   end Initialize;
 203
 204   procedure Adjust    ( TC: in out Test_Controlled ) is
 205   begin
 206     TC.Last_Proc_Called := Adj;
 207     C760002_0.Adjust(C760002_0.Root_Controlled(TC));
 208   end Adjust;
 209
 210   procedure Finalize  ( TC: in out Test_Controlled ) is
 211   begin
 212     TC.Last_Proc_Called := Fin;
 213   end Finalize;
 214
 215   procedure Initialize( TC: in out Nested_Controlled ) is
 216   begin
 217     TC.Last_Proc_Called := Init;
 218     C760002_0.Initialize(C760002_0.Root_Controlled(TC));
 219   end Initialize;
 220
 221   procedure Adjust    ( TC: in out Nested_Controlled ) is
 222   begin
 223     TC.Last_Proc_Called := Adj;
 224     C760002_0.Adjust(C760002_0.Root_Controlled(TC));
 225   end Adjust;
 226
 227   procedure Finalize  ( TC: in out Nested_Controlled ) is
 228   begin
 229     TC.Last_Proc_Called := Fin;
 230   end Finalize;
 231
 232   procedure Initialize( TC: in out Test_Limited_Controlled ) is
 233   begin
 234     TC.Last_Proc_Called := Init;
 235     C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC));
 236   end Initialize;
 237
 238   procedure Adjust    ( TC: in out Test_Limited_Controlled ) is
 239   begin
 240     Report.Failed("Adjust called for Test_Limited_Controlled");
 241   end Adjust;
 242
 243   procedure Finalize  ( TC: in out Test_Limited_Controlled ) is
 244   begin
 245     TC.Last_Proc_Called := Fin;
 246   end Finalize;
 247
 248   procedure Initialize( TC: in out Nested_Limited_Controlled ) is
 249   begin
 250     TC.Last_Proc_Called := Init;
 251     C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC));
 252   end Initialize;
 253
 254   procedure Adjust    ( TC: in out Nested_Limited_Controlled ) is
 255   begin
 256     Report.Failed("Adjust called for Nested_Limited_Controlled");
 257   end Adjust;
 258
 259   procedure Finalize  ( TC: in out Nested_Limited_Controlled ) is
 260   begin
 261     TC.Last_Proc_Called := Fin;
 262   end Finalize;
 263
 264 end C760002_1;
 265
 266 ---------------------------------------------------------------- C760002
 267
 268 with Report;
 269 with TCTouch;
 270 with C760002_0;
 271 with C760002_1;
 272 with Ada.Finalization;
 273 procedure C760002 is
 274
 275   use type C760002_1.Proc_ID;
 276
 277   -- in the first test, test the simple cases.
 278   -- Also check that assignment causes a call to Adjust for a controlled
 279   -- object.  Check that assignment of a non-controlled object does not call
 280   -- an Adjust procedure.
 281
 282   procedure Check_Simple_Objects is
 283
 284     A,B : C760002_0.Root;
 285     S,T : C760002_1.Test_Controlled;
 286     Q   : C760002_1.Test_Limited_Controlled;  -- Adjust call shouldn't happen
 287   begin
 288
 289     S := T;
 290
 291     TCTouch.Assert((S.Last_Proc_Called = C760002_1.Adj),
 292                    "Adjust for simple object");
 293     TCTouch.Assert((S.My_ID = T.My_ID),
 294                    "Assignment failed for simple object");
 295
 296     -- Check that adjust was called
 297     TCTouch.Assert((S.Visit_Tag = 'A'), "Adjust timing incorrect");
 298
 299     -- Check that Adjust has not been called
 300     TCTouch.Assert_Not((T.Visit_Tag = 'A'), "Adjust incorrectly called");
 301
 302     -- Check that Adjust does not get called
 303     A.My_ID := A.My_ID +1;
 304     B := A;  -- see: Adjust: Report.Failed
 305
 306   end Check_Simple_Objects;
 307
 308   -- in the second test, test a more complex case, check that a controlled
 309   -- component of a controlled object gets processed correctly
 310
 311   procedure Check_Nested_Objects is
 312     NO1 : C760002_1.Nested_Controlled;
 313     NO2 : C760002_1.Nested_Controlled := NO1;
 314
 315   begin
 316
 317     -- NO2 should be flagged with adjust markers
 318     TCTouch.Assert((NO2.Last_Proc_Called = C760002_1.Adj),
 319                    "Adjust not called for NO2 enclosure declaration");
 320     TCTouch.Assert((NO2.Nested.Visit_Tag = 'A'),
 321                    "Adjust not called for NO2 enclosed declaration");
 322
 323     NO2.Visit_Tag := 'x';
 324     NO2.Nested.Visit_Tag := 'y';
 325
 326     NO1 := NO2;
 327
 328     -- NO1 should be flagged with adjust markers
 329     TCTouch.Assert((NO1.Visit_Tag = 'A'),
 330                    "Adjust not called for NO1 enclosure declaration");
 331     TCTouch.Assert((NO1.Nested.Visit_Tag = 'A'),
 332                    "Adjust not called for NO1 enclosed declaration");
 333
 334   end Check_Nested_Objects;
 335
 336   procedure Check_Array_Case is
 337     type Array_Simple is array(1..4) of C760002_1.Test_Controlled;
 338     type Array_Nested is array(1..4) of C760002_1.Nested_Controlled;
 339
 340     Left,Right      : Array_Simple;
 341     Overlap         : Array_Simple := Left;
 342
 343     Sinister,Dexter : Array_Nested;
 344     Underlap        : Array_Nested := Sinister;
 345
 346     Now : Natural;
 347
 348   begin
 349
 350     -- get a current unique value since initializations
 351     Now := C760002_0.Unique_Value;
 352
 353     -- check results of declarations
 354     for N in 1..4 loop
 355       TCTouch.Assert(Left(N).My_Id < Now,
 356                      "Initialize for array initial value");
 357       TCTouch.Assert(Overlap(N).My_Id < Now,
 358                      "Adjust for nested array (outer) initial value");
 359       TCTouch.Assert(Sinister(N).Nested.My_Id < Now,
 360                      "Initialize for nested array (inner) initial value");
 361       TCTouch.Assert(Sinister(N).My_Id < Sinister(N).Nested.My_Id,
 362                      "Initialize for enclosure should be after enclosed");
 363       TCTouch.Assert(Overlap(N).Visit_Tag = 'A',"Adjust at declaration");
 364       TCTouch.Assert(Underlap(N).Nested.Visit_Tag = 'A',
 365                      "Adjust at declaration, nested object");
 366     end loop;
 367
 368     -- set visit tags
 369     for O in 1..4 loop
 370       Overlap(O).Visit_Tag         := 'X';
 371       Underlap(O).Visit_Tag        := 'Y';
 372       Underlap(O).Nested.Visit_Tag := 'y';
 373     end loop;
 374
 375     -- check that overlapping assignments don't cause odd grief
 376     Overlap(1..3)  := Overlap(2..4);
 377     Underlap(2..4) := Underlap(1..3);
 378
 379     for M in 2..3 loop
 380       TCTouch.Assert(Overlap(M).Last_Proc_Called = C760002_1.Adj,
 381                      "Adjust for overlap");
 382       TCTouch.Assert(Overlap(M).Visit_Tag = 'A',
 383                      "Adjust for overlap ID");
 384       TCTouch.Assert(Underlap(M).Last_Proc_Called = C760002_1.Adj,
 385                      "Adjust for Underlap");
 386       TCTouch.Assert(Underlap(M).Nested.Visit_Tag = 'A',
 387                      "Adjust for Underlaps nested ID");
 388     end loop;
 389
 390   end Check_Array_Case;
 391
 392   procedure Check_Access_Case is
 393     type TC_Ref is access C760002_1.Test_Controlled;
 394     type NC_Ref is access C760002_1.Nested_Controlled;
 395     type TL_Ref is access C760002_1.Test_Limited_Controlled;
 396     type NL_Ref is access C760002_1.Nested_Limited_Controlled;
 397
 398     A,B : TC_Ref;
 399     C,D : NC_Ref;
 400     E   : TL_Ref;
 401     F   : NL_Ref;
 402
 403   begin
 404
 405     A := new C760002_1.Test_Controlled;
 406     B := new C760002_1.Test_Controlled'( A.all );
 407
 408     C := new C760002_1.Nested_Controlled;
 409     D := new C760002_1.Nested_Controlled'( C.all );
 410
 411     E := new C760002_1.Test_Limited_Controlled;
 412     F := new C760002_1.Nested_Limited_Controlled;
 413
 414     TCTouch.Assert(A.Visit_Tag = 'I',"TC Allocation");
 415     TCTouch.Assert(B.Visit_Tag = 'A',"TC Allocation, with value");
 416
 417     TCTouch.Assert(C.Visit_Tag = 'I',"NC Allocation");
 418     TCTouch.Assert(C.Nested.Visit_Tag = 'I',"NC Allocation, Nested");
 419     TCTouch.Assert(D.Visit_Tag = 'A',"NC Allocation, with value");
 420     TCTouch.Assert(D.Nested.Visit_Tag = 'A',
 421                    "NC Allocation, Nested, with value");
 422
 423     TCTouch.Assert(E.Visit_Tag = 'i',"TL Allocation");
 424     TCTouch.Assert(F.Visit_Tag = 'i',"NL Allocation");
 425
 426     A.all := B.all;
 427     C.all := D.all;
 428
 429     TCTouch.Assert(A.Visit_Tag = 'A',"TC Assignment");
 430     TCTouch.Assert(C.Visit_Tag = 'A',"NC Assignment");
 431     TCTouch.Assert(C.Nested.Visit_Tag = 'A',"NC Assignment, Nested");
 432
 433   end Check_Access_Case;
 434
 435   procedure Check_Access_Limited_Array_Case is
 436     type Array_Simple is array(1..4) of C760002_1.Test_Limited_Controlled;
 437     type AS_Ref is access Array_Simple;
 438     type Array_Nested is array(1..4) of C760002_1.Nested_Limited_Controlled;
 439     type AN_Ref is access Array_Nested;
 440
 441     Simple_Array_Limited : AS_Ref;
 442
 443     Nested_Array_Limited : AN_Ref;
 444
 445   begin
 446
 447     Simple_Array_Limited := new Array_Simple;
 448
 449     Nested_Array_Limited := new Array_Nested;
 450
 451     for N in 1..4 loop
 452       TCTouch.Assert(Simple_Array_Limited(N).Last_Proc_Called
 453                      = C760002_1.Init,
 454                      "Initialize for array initial value");
 455       TCTouch.Assert(Nested_Array_Limited(N).Last_Proc_Called
 456                      = C760002_1.Init,
 457                      "Initialize for nested array (outer) initial value");
 458       TCTouch.Assert(Nested_Array_Limited(N).Nested.Visit_Tag = 'i',
 459                      "Initialize for nested array (inner) initial value");
 460     end loop;
 461   end Check_Access_Limited_Array_Case;
 462
 463 begin  -- Main test procedure.
 464
 465   Report.Test ("C760002", "Check that assignment causes the Adjust " &
 466                           "operation of the type to be called.  Check " &
 467                           "that Adjust is called after copying the " &
 468                           "value of the source expression to the target " &
 469                           "object.  Check that Adjust is called for all " &
 470                           "controlled components when the containing " &
 471                           "object is assigned.  Check that Adjust is " &
 472                           "called for components before the containing " &
 473                           "object is adjusted.  Check that Adjust is not " &
 474                           "called for a Limited_Controlled type by the " &
 475                           "implementation" );
 476
 477   Check_Simple_Objects;
 478
 479   Check_Nested_Objects;
 480
 481   Check_Array_Case;
 482
 483   Check_Access_Case;
 484
 485   Check_Access_Limited_Array_Case;
 486
 487   Report.Result;
 488
 489 end C760002;