path: root/gcc/testsuite/ada/acats/tests/cc/cc40001.a

-- CC40001.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 adjust is called on the value of a constant object created
--      by the evaluation of a generic association for a formal object of
--      mode in.
--
--      Check that those values are also subsequently finalized.
--
-- TEST DESCRIPTION:
--      Create a backdrop of a controlled type sufficient to check that the
--      correct operations get called at appropriate times.  Create a generic
--      unit that takes a formal parameter of a formal type.  Create instances
--      of this generic using various "levels" of the controlled type.  Check
--      the same case for a generic child unit.
--
--      The cases tested are where the type of the formal object is:
--        a visible classwide type  : CC40001_2
--        a formal private type     : CC40001_3
--        a formal tagged type      : CC40001_4
--
--      To more fully take advantage of the features of the language, and
--      present a test which is "user oriented" this test utilizes multiple
--      aspects of the language in combination.  Using Ada.Strings.Unbounded
--      in combination with Ada.Finalization and Ada.Calendar to build layers
--      of an object oriented system will likely be very common in actual
--      practice.  A common paradigm in the language will also be the use of
--      a parent package defining "basic" tagged types, and child packages
--      will expand on those types via derivation.  The model used in this
--      test is a simple type containing a character identity (used in the
--      identity).  The next level of type add a timestamp.  Further levels
--      might add location information, etc. however for the purposes of this
--      test we stop at the second layer, as it is sufficient to test the
--      stated objective.
--
--
-- CHANGE HISTORY:
--      06 FEB 96   SAIC   Initial version
--      30 APR 96   SAIC   Added finalization checks for 2.1
--      13 FEB 97   PWB.CTA  Moved global objects into bodies, after Initialize
--                         body is elaborated; counted finalizations correctly.
--!

----------------------------------------------------------------- CC40001_0

with Ada.Finalization;
with Ada.Strings.Unbounded;
package CC40001_0 is

  type States is ( Erroneous, Defaulted, Initialized, Reset, Adjusted );

  type Simple_Object(ID: Character) is
    new Ada.Finalization.Controlled with
      record
        TC_Current_State : States := Defaulted;
        Name : Ada.Strings.Unbounded.Unbounded_String;
      end record;

  procedure User_Operation( COB: in out Simple_Object; Name : String );
  procedure Initialize( COB: in out Simple_Object );
  procedure Adjust    ( COB: in out Simple_Object );
  procedure Finalize  ( COB: in out Simple_Object );

  Finalization_Count : Natural;

end CC40001_0;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with Report;
with TCTouch;
package body CC40001_0 is

  procedure User_Operation( COB: in out Simple_Object; Name : String ) is
  begin
    COB.Name := Ada.Strings.Unbounded.To_Unbounded_String(Name);
  end User_Operation;

  procedure Initialize( COB: in out Simple_Object ) is
  begin
    COB.TC_Current_State := Initialized;
  end Initialize;

  procedure Adjust    ( COB: in out Simple_Object ) is
  begin
    COB.TC_Current_State := Adjusted;
    TCTouch.Touch('A');  -------------------------------------------------- A
    TCTouch.Touch(COB.ID); ------------------------------------------------ ID
    -- note that the calls to touch will not be directly validated, it is
    -- expected that some number > 0 of calls will be made to this procedure,
    -- the subtests then clear (Flush) the Touch buffer and perform actions
    -- where an incorrect implementation might call this procedure.  Such a
    -- call will fail on the attempt to "Validate" the null string.
  end Adjust;

  procedure Finalize  ( COB: in out Simple_Object ) is
  begin
    COB.TC_Current_State := Erroneous;
    Finalization_Count := Finalization_Count +1;
  end Finalize;

  TC_Global_Object : Simple_Object('G');

end CC40001_0;

----------------------------------------------------------------- CC40001_1

with Ada.Calendar;
package CC40001_0.CC40001_1 is

  type Object_In_Time(ID: Character) is
    new Simple_Object(ID) with
      record
        Birth : Ada.Calendar.Time;
        Activity : Ada.Calendar.Time;
      end record;

  procedure User_Operation( COB: in out Object_In_Time;
                           Name: String );

  procedure Initialize( COB: in out Object_In_Time );
  procedure Adjust    ( COB: in out Object_In_Time );
  procedure Finalize  ( COB: in out Object_In_Time );

end CC40001_0.CC40001_1;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with Report;
with TCTouch;
package body CC40001_0.CC40001_1 is

  procedure Initialize( COB: in out Object_In_Time ) is
  begin
    COB.TC_Current_State := Initialized;
    COB.Birth := Ada.Calendar.Clock;
  end Initialize;

  procedure Adjust    ( COB: in out Object_In_Time ) is
  begin
    COB.TC_Current_State := Adjusted;
    TCTouch.Touch('a');    ------------------------------------------------ a
    TCTouch.Touch(COB.ID); ------------------------------------------------ ID
  end Adjust;

  procedure Finalize  ( COB: in out Object_In_Time ) is
  begin
    COB.TC_Current_State := Erroneous;
    Finalization_Count := Finalization_Count +1;
  end Finalize;

  procedure User_Operation( COB: in out Object_In_Time;
                           Name: String ) is
  begin
    CC40001_0.User_Operation( Simple_Object(COB), Name );
    COB.Activity := Ada.Calendar.Clock;
    COB.TC_Current_State := Reset;
  end User_Operation;

  TC_Time_Object  : Object_In_Time('g');

end CC40001_0.CC40001_1;

----------------------------------------------------------------- CC40001_2

generic
  TC_Check_Object : in CC40001_0.Simple_Object'Class;
package CC40001_0.CC40001_2 is
  procedure TC_Verify_State;
end CC40001_0.CC40001_2;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with Report;
package body CC40001_0.CC40001_2 is

  procedure TC_Verify_State is
  begin
    if TC_Check_Object.TC_Current_State /= Adjusted then
      Report.Failed( "CC40001_2 : Formal Object not adjusted" );
    end if;
  end TC_Verify_State;

end CC40001_0.CC40001_2;

----------------------------------------------------------------- CC40001_3

generic
  type Formal_Private(<>) is private;
  TC_Check_Object : in Formal_Private;
  with function Bad_Status( O: Formal_Private ) return Boolean;
package CC40001_0.CC40001_3 is
  procedure TC_Verify_State;
end CC40001_0.CC40001_3;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with Report;
package body CC40001_0.CC40001_3 is

  procedure TC_Verify_State is
  begin
    if Bad_Status( TC_Check_Object ) then
      Report.Failed( "CC40001_3 : Formal Object not adjusted" );
    end if;
  end TC_Verify_State;

end CC40001_0.CC40001_3;

----------------------------------------------------------------- CC40001_4

generic
  type Formal_Tagged_Private(<>) is tagged private; 
  TC_Check_Object : in Formal_Tagged_Private;
  with function Bad_Status( O: Formal_Tagged_Private ) return Boolean;
package CC40001_0.CC40001_4 is
  procedure TC_Verify_State;
end CC40001_0.CC40001_4;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with Report;
package body CC40001_0.CC40001_4 is

  procedure TC_Verify_State is
  begin
    if Bad_Status( TC_Check_Object ) then
      Report.Failed( "CC40001_4 : Formal Object not adjusted" );
    end if;
  end TC_Verify_State;

end CC40001_0.CC40001_4;

------------------------------------------------------------------- CC40001

with Report;
with TCTouch;
with CC40001_0.CC40001_1;
with CC40001_0.CC40001_2;
with CC40001_0.CC40001_3;
with CC40001_0.CC40001_4;
procedure CC40001 is

  function Not_Adjusted( CO : CC40001_0.Simple_Object )
    return Boolean is
     use type CC40001_0.States;
  begin
    return CO.TC_Current_State /= CC40001_0.Adjusted;
  end Not_Adjusted;

  function Not_Adjusted( CO : CC40001_0.CC40001_1.Object_In_Time )
    return Boolean is
     use type CC40001_0.States;
  begin
    return CO.TC_Current_State /= CC40001_0.Adjusted;
  end Not_Adjusted;

   -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 1

  procedure Subtest_1 is
    Object_0 : CC40001_0.Simple_Object('T');
    Object_1 : CC40001_0.CC40001_1.Object_In_Time('t');

    package Subtest_1_1 is
      new CC40001_0.CC40001_2( Object_0 ); -- classwide generic formal object

    package Subtest_1_2 is
      new CC40001_0.CC40001_2( Object_1 ); -- classwide generic formal object
  begin
    TCTouch.Flush;  -- clear out all "A" and "T" entries, no further calls
                    -- to Touch should occur before the call to Validate

    -- set the objects TC_Current_State to "Reset"
    CC40001_0.User_Operation( Object_0, "Subtest 1" );
    CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 1" );

    -- check that the objects TC_Current_State is "Adjusted"
    Subtest_1_1.TC_Verify_State;
    Subtest_1_2.TC_Verify_State;

    TCTouch.Validate( "", "No actions should occur here, subtest 1" );

  end Subtest_1;

   -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 2

  procedure Subtest_2 is
    Object_0 : CC40001_0.Simple_Object('T');
    Object_1 : CC40001_0.CC40001_1.Object_In_Time('t');

    package Subtest_2_1 is -- generic formal object is discriminated private
      new CC40001_0.CC40001_3( CC40001_0.Simple_Object,
                               Object_0,
                               Not_Adjusted );

    package Subtest_2_2 is -- generic formal object is discriminated private
      new CC40001_0.CC40001_3( CC40001_0.CC40001_1.Object_In_Time,
                               Object_1,
                               Not_Adjusted );

  begin
    TCTouch.Flush;  -- clear out all "A" and "T" entries

    -- set the objects state to "Reset"
    CC40001_0.User_Operation( Object_0, "Subtest 2" );
    CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 2" );

    Subtest_2_1.TC_Verify_State;
    Subtest_2_2.TC_Verify_State;

    TCTouch.Validate( "", "No actions should occur here, subtest 2" );

  end Subtest_2;

   -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 3

  procedure Subtest_3 is
    Object_0 : CC40001_0.Simple_Object('T');
    Object_1 : CC40001_0.CC40001_1.Object_In_Time('t');

    package Subtest_3_1 is -- generic formal object is discriminated tagged
      new CC40001_0.CC40001_4( CC40001_0.Simple_Object,
                               Object_0,
                               Not_Adjusted );

    package Subtest_3_2 is -- generic formal object is discriminated tagged
      new CC40001_0.CC40001_4( CC40001_0.CC40001_1.Object_In_Time,
                               Object_1,
                               Not_Adjusted );
  begin
    TCTouch.Flush;  -- clear out all "A" and "T" entries

    -- set the objects state to "Reset"
    CC40001_0.User_Operation( Object_0, "Subtest 3" );
    CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 3" );

    Subtest_3_1.TC_Verify_State;
    Subtest_3_2.TC_Verify_State;

    TCTouch.Validate( "", "No actions should occur here, subtest 3" );

  end Subtest_3;

begin  -- Main test procedure.

  Report.Test ("CC40001", "Check that adjust and finalize are called on " &
                          "the constant object created by the " &
                          "evaluation of a generic association for a " &
                          "formal object of mode in" );

  -- check that the created constant objects are properly adjusted
  -- and subsequently finalized

  CC40001_0.Finalization_Count := 0;

  Subtest_1;

  if CC40001_0.Finalization_Count < 4 then
    Report.Failed("Insufficient Finalizations for Subtest 1");
  end if;

  CC40001_0.Finalization_Count := 0;

  Subtest_2;

  if CC40001_0.Finalization_Count < 4 then
    Report.Failed("Insufficient Finalizations for Subtest 2");
  end if;

  CC40001_0.Finalization_Count := 0;

  Subtest_3;

  if CC40001_0.Finalization_Count < 4 then
    Report.Failed("Insufficient Finalizations for Subtest 3");
  end if;

  Report.Result;

end CC40001;