Subversion Repositories openrisc

-- 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;