path: root/gcc/testsuite/ada/acats/tests/c7/c760002.a

-- C760002.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
--      Check that assignment to an object of a (non-limited) controlled
--      type causes the Adjust operation of the type to be called.
--      Check that Adjust is called after copying the value of the
--      source expression to the target object.
--
--      Check that Adjust is called for all controlled components when
--      the containing object is assigned.  (Test this for the cases
--      where the type of the containing object is controlled and
--      noncontrolled; test this for initialization as well as
--      assignment statements.)
--
--      Check that for an object of a controlled type with controlled
--      components, Adjust for each of the components is called before
--      the containing object is adjusted.
--
--      Check that an Adjust procedure for a Limited_Controlled type is
--      not called by the implementation.
--
-- TEST DESCRIPTION:
--      This test is loosely "derived" from C760001.
--
--      Visit Tags:
--        D - Default value at declaration
--        d - Default value at declaration, limited root
--        I - initialize at root controlled
--        i - initialize at root limited controlled
--        A - adjust at root controlled
--        X,Y,Z,x,y,z - used in test body
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      19 Dec 94   SAIC    Correct test assertion logic for Sinister case
--
--!

---------------------------------------------------------------- C760002_0

with Ada.Finalization;
package C760002_0 is
  subtype Unique_ID is Natural;
  function Unique_Value return Unique_ID;
  -- increments each time it's called

  function Most_Recent_Unique_Value return Unique_ID;
  -- returns the same value as the most recent call to Unique_Value

  type Root is tagged record
    My_ID      : Unique_ID := Unique_Value;
    Visit_Tag  : Character := 'D';  -- Default
  end record;

  procedure Initialize( R: in out Root );
  procedure Adjust    ( R: in out Root );

  type Root_Controlled is new Ada.Finalization.Controlled with record
    My_ID      : Unique_ID := Unique_Value;
    Visit_Tag  : Character := 'D'; ---------------------------------------- D
  end record;

  procedure Initialize( R: in out Root_Controlled );
  procedure Adjust    ( R: in out Root_Controlled );

  type Root_Limited_Controlled is
       new Ada.Finalization.Limited_Controlled with record
    My_ID      : Unique_ID := Unique_Value;
    Visit_Tag  : Character := 'd'; ---------------------------------------- d
  end record;

  procedure Initialize( R: in out Root_Limited_Controlled );
  procedure Adjust    ( R: in out Root_Limited_Controlled );

end C760002_0;

with Report;
package body C760002_0 is

  Global_Unique_Counter : Unique_ID := 0;
  
  function Unique_Value return Unique_ID is
  begin
    Global_Unique_Counter := Global_Unique_Counter +1;
    return Global_Unique_Counter;
  end Unique_Value;
  
  function Most_Recent_Unique_Value return Unique_ID is
  begin
    return Global_Unique_Counter;
  end Most_Recent_Unique_Value;

  procedure Initialize( R: in out Root ) is
  begin
    Report.Failed("Initialize called for Non_Controlled type");
  end Initialize;

  procedure Adjust    ( R: in out Root ) is
  begin
    Report.Failed("Adjust called for Non_Controlled type");
  end Adjust;

  procedure Initialize( R: in out Root_Controlled ) is
  begin
    R.Visit_Tag := 'I'; --------------------------------------------------- I
  end Initialize;

  procedure Adjust( R: in out Root_Controlled ) is
  begin
    R.Visit_Tag := 'A'; --------------------------------------------------- A
  end Adjust;

  procedure Initialize( R: in out Root_Limited_Controlled ) is
  begin
    R.Visit_Tag := 'i'; --------------------------------------------------- i
  end Initialize;

  procedure Adjust( R: in out Root_Limited_Controlled ) is
  begin
    Report.Failed("Adjust called for Limited_Controlled type");
  end Adjust;

end C760002_0;

---------------------------------------------------------------- C760002_1

with Ada.Finalization;
with C760002_0;
package C760002_1 is

  type Proc_ID is (None, Init, Adj, Fin);

  type Test_Controlled is new C760002_0.Root_Controlled with record
    Last_Proc_Called: Proc_ID := None;
  end record;

  procedure Initialize( TC: in out Test_Controlled );
  procedure Adjust    ( TC: in out Test_Controlled );
  procedure Finalize  ( TC: in out Test_Controlled );

  type Nested_Controlled is new C760002_0.Root_Controlled with record
    Nested : C760002_0.Root_Controlled;
    Last_Proc_Called: Proc_ID := None;
  end record;

  procedure Initialize( TC: in out Nested_Controlled );
  procedure Adjust    ( TC: in out Nested_Controlled );
  procedure Finalize  ( TC: in out Nested_Controlled );

  type Test_Limited_Controlled is
       new C760002_0.Root_Limited_Controlled with record
    Last_Proc_Called: Proc_ID := None;
  end record;

  procedure Initialize( TC: in out Test_Limited_Controlled );
  procedure Adjust    ( TC: in out Test_Limited_Controlled );
  procedure Finalize  ( TC: in out Test_Limited_Controlled );

  type Nested_Limited_Controlled is
       new C760002_0.Root_Limited_Controlled with record
    Nested : C760002_0.Root_Limited_Controlled;
    Last_Proc_Called: Proc_ID := None;
  end record;

  procedure Initialize( TC: in out Nested_Limited_Controlled );
  procedure Adjust    ( TC: in out Nested_Limited_Controlled );
  procedure Finalize  ( TC: in out Nested_Limited_Controlled );

end C760002_1;

with Report;
package body C760002_1 is

  procedure Initialize( TC: in out Test_Controlled ) is
  begin
    TC.Last_Proc_Called := Init;
    C760002_0.Initialize(C760002_0.Root_Controlled(TC));
  end Initialize;

  procedure Adjust    ( TC: in out Test_Controlled ) is
  begin
    TC.Last_Proc_Called := Adj;
    C760002_0.Adjust(C760002_0.Root_Controlled(TC));
  end Adjust;

  procedure Finalize  ( TC: in out Test_Controlled ) is
  begin
    TC.Last_Proc_Called := Fin;
  end Finalize;

  procedure Initialize( TC: in out Nested_Controlled ) is
  begin
    TC.Last_Proc_Called := Init;
    C760002_0.Initialize(C760002_0.Root_Controlled(TC));
  end Initialize;

  procedure Adjust    ( TC: in out Nested_Controlled ) is
  begin
    TC.Last_Proc_Called := Adj;
    C760002_0.Adjust(C760002_0.Root_Controlled(TC));
  end Adjust;

  procedure Finalize  ( TC: in out Nested_Controlled ) is
  begin
    TC.Last_Proc_Called := Fin;
  end Finalize;

  procedure Initialize( TC: in out Test_Limited_Controlled ) is
  begin
    TC.Last_Proc_Called := Init;
    C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC));
  end Initialize;

  procedure Adjust    ( TC: in out Test_Limited_Controlled ) is
  begin
    Report.Failed("Adjust called for Test_Limited_Controlled");
  end Adjust;

  procedure Finalize  ( TC: in out Test_Limited_Controlled ) is
  begin
    TC.Last_Proc_Called := Fin;
  end Finalize;

  procedure Initialize( TC: in out Nested_Limited_Controlled ) is
  begin
    TC.Last_Proc_Called := Init;
    C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC));
  end Initialize;

  procedure Adjust    ( TC: in out Nested_Limited_Controlled ) is
  begin
    Report.Failed("Adjust called for Nested_Limited_Controlled");
  end Adjust;

  procedure Finalize  ( TC: in out Nested_Limited_Controlled ) is
  begin
    TC.Last_Proc_Called := Fin;
  end Finalize;

end C760002_1;

---------------------------------------------------------------- C760002

with Report;
with TCTouch;
with C760002_0;
with C760002_1;
with Ada.Finalization;
procedure C760002 is

  use type C760002_1.Proc_ID;

  -- in the first test, test the simple cases.
  -- Also check that assignment causes a call to Adjust for a controlled
  -- object.  Check that assignment of a non-controlled object does not call
  -- an Adjust procedure.

  procedure Check_Simple_Objects is

    A,B : C760002_0.Root;
    S,T : C760002_1.Test_Controlled;
    Q   : C760002_1.Test_Limited_Controlled;  -- Adjust call shouldn't happen
  begin

    S := T;

    TCTouch.Assert((S.Last_Proc_Called = C760002_1.Adj),
                   "Adjust for simple object");
    TCTouch.Assert((S.My_ID = T.My_ID),
                   "Assignment failed for simple object");

    -- Check that adjust was called
    TCTouch.Assert((S.Visit_Tag = 'A'), "Adjust timing incorrect");

    -- Check that Adjust has not been called
    TCTouch.Assert_Not((T.Visit_Tag = 'A'), "Adjust incorrectly called");

    -- Check that Adjust does not get called
    A.My_ID := A.My_ID +1;
    B := A;  -- see: Adjust: Report.Failed

  end Check_Simple_Objects;

  -- in the second test, test a more complex case, check that a controlled
  -- component of a controlled object gets processed correctly

  procedure Check_Nested_Objects is
    NO1 : C760002_1.Nested_Controlled;
    NO2 : C760002_1.Nested_Controlled := NO1;

  begin

    -- NO2 should be flagged with adjust markers
    TCTouch.Assert((NO2.Last_Proc_Called = C760002_1.Adj),
                   "Adjust not called for NO2 enclosure declaration");
    TCTouch.Assert((NO2.Nested.Visit_Tag = 'A'),
                   "Adjust not called for NO2 enclosed declaration");

    NO2.Visit_Tag := 'x';
    NO2.Nested.Visit_Tag := 'y';

    NO1 := NO2;

    -- NO1 should be flagged with adjust markers
    TCTouch.Assert((NO1.Visit_Tag = 'A'),
                   "Adjust not called for NO1 enclosure declaration");
    TCTouch.Assert((NO1.Nested.Visit_Tag = 'A'),
                   "Adjust not called for NO1 enclosed declaration");

  end Check_Nested_Objects;

  procedure Check_Array_Case is
    type Array_Simple is array(1..4) of C760002_1.Test_Controlled;
    type Array_Nested is array(1..4) of C760002_1.Nested_Controlled;

    Left,Right      : Array_Simple;
    Overlap         : Array_Simple := Left;

    Sinister,Dexter : Array_Nested;
    Underlap        : Array_Nested := Sinister;

    Now : Natural;

  begin

    -- get a current unique value since initializations
    Now := C760002_0.Unique_Value;

    -- check results of declarations
    for N in 1..4 loop
      TCTouch.Assert(Left(N).My_Id < Now,
                     "Initialize for array initial value");
      TCTouch.Assert(Overlap(N).My_Id < Now,
                     "Adjust for nested array (outer) initial value");
      TCTouch.Assert(Sinister(N).Nested.My_Id < Now,
                     "Initialize for nested array (inner) initial value");
      TCTouch.Assert(Sinister(N).My_Id < Sinister(N).Nested.My_Id,
                     "Initialize for enclosure should be after enclosed");
      TCTouch.Assert(Overlap(N).Visit_Tag = 'A',"Adjust at declaration");
      TCTouch.Assert(Underlap(N).Nested.Visit_Tag = 'A',
                     "Adjust at declaration, nested object");
    end loop;

    -- set visit tags
    for O in 1..4 loop
      Overlap(O).Visit_Tag         := 'X';
      Underlap(O).Visit_Tag        := 'Y';
      Underlap(O).Nested.Visit_Tag := 'y';
    end loop;

    -- check that overlapping assignments don't cause odd grief
    Overlap(1..3)  := Overlap(2..4);
    Underlap(2..4) := Underlap(1..3);

    for M in 2..3 loop
      TCTouch.Assert(Overlap(M).Last_Proc_Called = C760002_1.Adj,
                     "Adjust for overlap");
      TCTouch.Assert(Overlap(M).Visit_Tag = 'A',
                     "Adjust for overlap ID");
      TCTouch.Assert(Underlap(M).Last_Proc_Called = C760002_1.Adj,
                     "Adjust for Underlap");
      TCTouch.Assert(Underlap(M).Nested.Visit_Tag = 'A',
                     "Adjust for Underlaps nested ID");
    end loop;

  end Check_Array_Case;

  procedure Check_Access_Case is
    type TC_Ref is access C760002_1.Test_Controlled;
    type NC_Ref is access C760002_1.Nested_Controlled;
    type TL_Ref is access C760002_1.Test_Limited_Controlled;
    type NL_Ref is access C760002_1.Nested_Limited_Controlled;

    A,B : TC_Ref;
    C,D : NC_Ref;
    E   : TL_Ref;
    F   : NL_Ref;

  begin

    A := new C760002_1.Test_Controlled;
    B := new C760002_1.Test_Controlled'( A.all );

    C := new C760002_1.Nested_Controlled;
    D := new C760002_1.Nested_Controlled'( C.all );

    E := new C760002_1.Test_Limited_Controlled;
    F := new C760002_1.Nested_Limited_Controlled;

    TCTouch.Assert(A.Visit_Tag = 'I',"TC Allocation");
    TCTouch.Assert(B.Visit_Tag = 'A',"TC Allocation, with value");

    TCTouch.Assert(C.Visit_Tag = 'I',"NC Allocation");
    TCTouch.Assert(C.Nested.Visit_Tag = 'I',"NC Allocation, Nested");
    TCTouch.Assert(D.Visit_Tag = 'A',"NC Allocation, with value");
    TCTouch.Assert(D.Nested.Visit_Tag = 'A',
                   "NC Allocation, Nested, with value");

    TCTouch.Assert(E.Visit_Tag = 'i',"TL Allocation");
    TCTouch.Assert(F.Visit_Tag = 'i',"NL Allocation");

    A.all := B.all;
    C.all := D.all;

    TCTouch.Assert(A.Visit_Tag = 'A',"TC Assignment");
    TCTouch.Assert(C.Visit_Tag = 'A',"NC Assignment");
    TCTouch.Assert(C.Nested.Visit_Tag = 'A',"NC Assignment, Nested");

  end Check_Access_Case;

  procedure Check_Access_Limited_Array_Case is
    type Array_Simple is array(1..4) of C760002_1.Test_Limited_Controlled;
    type AS_Ref is access Array_Simple;
    type Array_Nested is array(1..4) of C760002_1.Nested_Limited_Controlled;
    type AN_Ref is access Array_Nested;

    Simple_Array_Limited : AS_Ref;

    Nested_Array_Limited : AN_Ref;

  begin

    Simple_Array_Limited := new Array_Simple;

    Nested_Array_Limited := new Array_Nested;
    
    for N in 1..4 loop
      TCTouch.Assert(Simple_Array_Limited(N).Last_Proc_Called
                     = C760002_1.Init,  
                     "Initialize for array initial value");
      TCTouch.Assert(Nested_Array_Limited(N).Last_Proc_Called
                     = C760002_1.Init,
                     "Initialize for nested array (outer) initial value");
      TCTouch.Assert(Nested_Array_Limited(N).Nested.Visit_Tag = 'i',
                     "Initialize for nested array (inner) initial value");
    end loop;
  end Check_Access_Limited_Array_Case;

begin  -- Main test procedure.

  Report.Test ("C760002", "Check that assignment causes the Adjust " &
                          "operation of the type to be called.  Check " &
                          "that Adjust is called after copying the " &
                          "value of the source expression to the target " &
                          "object.  Check that Adjust is called for all " &
                          "controlled components when the containing " &
                          "object is assigned.  Check that Adjust is " &
                          "called for components before the containing " &
                          "object is adjusted.  Check that Adjust is not " &
                          "called for a Limited_Controlled type by the " &
                          "implementation" );

  Check_Simple_Objects;

  Check_Nested_Objects;

  Check_Array_Case;

  Check_Access_Case;

  Check_Access_Limited_Array_Case;

  Report.Result;

end C760002;