Subversion Repositories openrisc_me

-- C760009.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 for an extension_aggregate whose ancestor_part is a

--      subtype_mark (i.e. Typemark'( Subtype with Field => x, etc.) )

--      Initialize is called on all controlled subcomponents of the

--      ancestor part; if the type of the ancestor part is itself controlled,

--      the Initialize procedure of the ancestor type is called, unless that

--      Initialize procedure is abstract.

--

--      Check that the utilization of a controlled type for a generic actual

--      parameter supports the correct behavior in the instantiated package.

--

-- TEST DESCRIPTION:

--      Declares a generic package instantiated to check that controlled

--      types are not impacted by the "generic boundary."

--      This instance is then used to perform the tests of various

--      aggregate formations of the controlled type.  After each operation

--      in the main program that should cause implicit calls, the "state" of

--      the software is checked.  The "state" of the software is maintained in

--      several variables which count the calls to the Initialize, Adjust and

--      Finalize procedures in each context.  Given the nature of the

--      language rules, the test specifies a minimum number of times that

--      these subprograms should have been called.  The test also checks cases

--      where the subprograms should not have been called.

--

--      As per the example in AARM 7.6(11a..d);6.0, the distinctions between

--      the presence/absence of default values is tested.

--

-- DATA STRUCTURES

--

--      C760009_3.Master_Control is derived from

--        C760009_2.Control is derived from

--          Ada.Finalization.Controlled

--

--      C760009_1.Simple_Control is derived from

--        Ada.Finalization.Controlled

--

--      C760009_3.Master_Control contains

--        Standard.Integer

--

--      C760009_2.Control contains

--        C760009_1.Simple_Control (default value)

--        C760009_1.Simple_Control (default initialized)

--

--

-- CHANGE HISTORY:

--      01 MAY 95   SAIC    Initial version

--      19 FEB 96   SAIC    Fixed elaboration Initialize count

--      14 NOV 96   SAIC    Allowed for 7.6(21) optimizations

--      13 FEB 97   PWB.CTA Initialized counters at lines 127-129

--      26 JUN 98   EDS     Added pragma Elaborate_Body to C760009_0

--                          to avoid possible instantiation error

--!

---------------------------------------------------------------- C760009_0

with Ada.Finalization;

generic

  type Private_Formal is private;

  with procedure TC_Validate( APF: in out Private_Formal );

package C760009_0 is -- Check_1

  pragma Elaborate_Body;

  procedure TC_Check_1( APF: in     Private_Formal );

  procedure TC_Check_2( APF:    out Private_Formal );

  procedure TC_Check_3( APF: in out Private_Formal );

end C760009_0;

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

with Report;

package body C760009_0 is -- Check_1

    procedure TC_Check_1( APF: in     Private_Formal ) is

      Local : Private_Formal;

    begin

      Local := APF;

      TC_Validate( Local );

    end TC_Check_1;

    procedure TC_Check_2( APF:    out Private_Formal ) is

      Local : Private_Formal;  -- initialized by virtue of actual being

                               -- Controlled

    begin

      APF := Local;

      TC_Validate( APF );

    end TC_Check_2;

    procedure TC_Check_3( APF: in out Private_Formal ) is

      Local : Private_Formal;

    begin

      Local := APF;

      TC_Validate( Local );

    end TC_Check_3;

end C760009_0;

---------------------------------------------------------------- C760009_1

with Ada.Finalization;

package C760009_1 is

  Initialize_Called : Natural := 0;

  Adjust_Called     : Natural := 0;

  Finalize_Called   : Natural := 0;

  procedure Reset_Counters;

  type Simple_Control is new Ada.Finalization.Controlled with private;

  procedure Initialize( AV: in out Simple_Control );

  procedure Adjust    ( AV: in out Simple_Control );

  procedure Finalize  ( AV: in out Simple_Control );

  procedure Validate  ( AV: in out Simple_Control );

  function Item( AV: Simple_Control'Class ) return String;

  Empty : constant Simple_Control;

  procedure TC_Trace( Message: String );

private

  type Simple_Control is new Ada.Finalization.Controlled with record

    Item: Natural;

  end record;

  Empty : constant Simple_Control := ( Ada.Finalization.Controlled with 0 );

end C760009_1;

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

with Report;

package body C760009_1 is

  -- Maintenance_Mode and TC_Trace are for the test writers and compiler

  -- developers to get more information from this test as it executes.

  -- Maintenance_Mode is always False for validation purposes.

  Maintenance_Mode : constant Boolean := False;

  procedure TC_Trace( Message: String ) is

  begin

    if Maintenance_Mode then

      Report.Comment( Message );

    end if;

  end TC_Trace;

  procedure Reset_Counters is

  begin

    Initialize_Called := 0;

    Adjust_Called     := 0;

    Finalize_Called   := 0;

  end Reset_Counters;

  Master_Count : Natural := 100;  -- Help distinguish values

  procedure Initialize( AV: in out Simple_Control ) is

  begin

    Initialize_Called := Initialize_Called +1;

    AV.Item := Master_Count;

    Master_Count := Master_Count +100;

    TC_Trace( "Initialize _1.Simple_Control" );

  end Initialize;

  procedure Adjust    ( AV: in out Simple_Control ) is

  begin

    Adjust_Called := Adjust_Called +1;

    AV.Item := AV.Item +1;

    TC_Trace( "Adjust _1.Simple_Control" );

  end Adjust;

  procedure Finalize  ( AV: in out Simple_Control ) is

  begin

    Finalize_Called := Finalize_Called +1;

    AV.Item := AV.Item +1;

    TC_Trace( "Finalize _1.Simple_Control" );

  end Finalize;

  procedure Validate  ( AV: in out Simple_Control ) is

  begin

    Report.Failed("Attempt to Validate at Simple_Control level");

  end Validate;

  function Item( AV: Simple_Control'Class ) return String is

  begin

    return Natural'Image(AV.Item);

  end Item;

end C760009_1;

---------------------------------------------------------------- C760009_2

with C760009_1;

with Ada.Finalization;

package C760009_2 is

  type Control is new Ada.Finalization.Controlled with record

    Element_1 : C760009_1.Simple_Control;

    Element_2 : C760009_1.Simple_Control := C760009_1.Empty;

  end record;

  procedure Initialize( AV: in out Control );

  procedure Finalize  ( AV: in out Control );

  Initialized : Natural := 0;

  Finalized   : Natural := 0;

end C760009_2;

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

package body C760009_2 is

  procedure Initialize( AV: in out Control ) is

  begin

    Initialized := Initialized +1;

    C760009_1.TC_Trace( "Initialize _2.Control" );

  end Initialize;

  procedure Finalize  ( AV: in out Control ) is

  begin

    Finalized := Finalized +1;

    C760009_1.TC_Trace( "Finalize _2.Control" );

  end Finalize;

end C760009_2;

---------------------------------------------------------------- C760009_3

with C760009_0;

with C760009_2;

package C760009_3 is

  type Master_Control is new C760009_2.Control with record

    Data: Integer;

  end record;

  procedure Initialize( AC: in out Master_Control );

  -- calls C760009_2.Initialize

  -- embedded data causes 1 call to C760009_1.Initialize

  -- Adjusting operation will

  -- make 1 call to C760009_2.Adjust

  -- make 2 call to C760009_1.Adjust

  -- Finalize operation will

  -- make 1 call to C760009_2.Finalize

  -- make 2 call to C760009_1.Finalize

  procedure Validate( AC: in out Master_Control );

  package Check_1 is

    new C760009_0(Master_Control, Validate);

end C760009_3;

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

with Report;

with C760009_1;

package body C760009_3 is

  procedure Initialize( AC: in out Master_Control ) is

  begin

    AC.Data := 42;

    C760009_2.Initialize(C760009_2.Control(AC));

    C760009_1.TC_Trace( "Initialize Master_Control" );

  end Initialize;

  procedure Validate( AC: in out Master_Control ) is

  begin

    if AC.Data not in 0..1000 then

      Report.Failed("C760009_3.Control did not Initialize" );

    end if;

  end Validate;

end C760009_3;

--------------------------------------------------------------------- C760009

with Report;

with C760009_1;

with C760009_2;

with C760009_3;

procedure C760009 is

  -- Comment following declaration indicates expected calls in the order:

  -- Initialize of a C760009_2 value

  -- Finalize   of a C760009_2 value

  -- Initialize of a C760009_1 value

  -- Adjust     of a C760009_1 value

  -- Finalize   of a C760009_1 value

  Global_Control : C760009_3.Master_Control;

  -- 1, 0, 1, 1, 0

  Parent_Control : C760009_2.Control;

  -- 1, 0, 1, 1, 0

  -- Global_Control is a derived tagged type, the parent type

  --   of Master_Control, Control, is derived from Controlled, and contains

  --   two components of a Controlled type, Simple_Control.  One of these

  --   components has a default value, the other does not.

  procedure Fail( Which: String; Expect, Got: Natural ) is

  begin

    Report.Failed(Which & " Expected" & Natural'Image(Expect)

                        & " got" & Natural'Image(Got) );

  end Fail;

  procedure Master_Assertion( Layer_2_Inits   : Natural;

                              Layer_2_Finals  : Natural;

                              Layer_1_Inits   : Natural;

                              Layer_1_Adjs    : Natural;

                              Layer_1_Finals  : Natural;

                              Failing_Message : String ) is

  begin

   if C760009_2.Initialized /= Layer_2_Inits then

     Fail("C760009_2.Initialize " & Failing_Message,

          Layer_2_Inits, C760009_2.Initialized );

   end if;

   if C760009_2.Finalized not in Layer_2_Finals..Layer_2_Finals*2 then

     Fail("C760009_2.Finalize " & Failing_Message,

           Layer_2_Finals, C760009_2.Finalized );

   end if;

   if C760009_1.Initialize_Called /= Layer_1_Inits then

     Fail("C760009_1.Initialize " & Failing_Message,

           Layer_1_Inits,

          C760009_1.Initialize_Called );

   end if;

   if C760009_1.Adjust_Called not in Layer_1_Adjs..Layer_1_Adjs*2 then

     Fail("C760009_1.Adjust " & Failing_Message,

           Layer_1_Adjs, C760009_1.Adjust_Called );

   end if;

   if C760009_1.Finalize_Called not in Layer_1_Finals..Layer_1_Finals*2 then

     Fail("C760009_1.Finalize " & Failing_Message,

           Layer_1_Finals, C760009_1.Finalize_Called );

   end if;

   C760009_1.Reset_Counters;

   C760009_2.Initialized := 0;

   C760009_2.Finalized   := 0;

  end Master_Assertion;

  procedure Lesser_Assertion( Layer_2_Inits   : Natural;

                              Layer_2_Finals  : Natural;

                              Layer_1_Inits   : Natural;

                              Layer_1_Adjs    : Natural;

                              Layer_1_Finals  : Natural;

                              Failing_Message : String ) is

  begin

   if C760009_2.Initialized > Layer_2_Inits then

     Fail("C760009_2.Initialize " & Failing_Message,

           Layer_2_Inits, C760009_2.Initialized );

   end if;

   if C760009_2.Finalized < Layer_2_Inits

      or C760009_2.Finalized > Layer_2_Finals*2 then

     Fail("C760009_2.Finalize " & Failing_Message,

           Layer_2_Finals, C760009_2.Finalized );

   end if;

   if C760009_1.Initialize_Called > Layer_1_Inits then

     Fail("C760009_1.Initialize " & Failing_Message,

           Layer_1_Inits,

          C760009_1.Initialize_Called );

   end if;

   if C760009_1.Adjust_Called > Layer_1_Adjs*2 then

     Fail("C760009_1.Adjust " & Failing_Message,

           Layer_1_Adjs, C760009_1.Adjust_Called );

   end if;

   if C760009_1.Finalize_Called < Layer_1_Inits

      or C760009_1.Finalize_Called > Layer_1_Finals*2 then

     Fail("C760009_1.Finalize " & Failing_Message,

           Layer_1_Finals, C760009_1.Finalize_Called );

   end if;

   C760009_1.Reset_Counters;

   C760009_2.Initialized := 0;

   C760009_2.Finalized   := 0;

  end Lesser_Assertion;

begin  -- Main test procedure.

  Report.Test ("C760009", "Check that for an extension_aggregate whose " &

                          "ancestor_part is a subtype_mark, Initialize " &

                          "is called on all controlled subcomponents of " &

                          "the ancestor part.  Also check that the " &

                          "utilization of a controlled type for a generic " &

                          "actual parameter supports the correct behavior " &

                          "in the instantiated software" );

  C760009_1.TC_Trace( "=====> Case 0 <=====" );

  C760009_1.Reset_Counters;

  C760009_2.Initialized := 0;

  C760009_2.Finalized   := 0;

  C760009_3.Validate( Global_Control ); -- check that it Initialized correctly

  C760009_1.TC_Trace( "=====> Case 1 <=====" );

  C760009_3.Check_1.TC_Check_1( ( C760009_2.Control with Data => 1 ) );

  Lesser_Assertion( 2, 3, 2, 3, 6, "Check_1.TC_Check_1" );

  --                |  |  |  |  + Finalize 2 embedded in aggregate

  --                |  |  |  |  + Finalize 2 at assignment in TC_Check_1

  --                |  |  |  |  + Finalize 2 embedded in local variable

  --                |  |  |  + Adjust 2 caused by assignment in TC_Check_1

  --                |  |  |  + Adjust at declaration in TC_Check_1

  --                |  |  + Initialize at declaration in TC_Check_1

  --                |  |  + Initialize of aggregate object

  --                |  + Finalize of assignment target

  --                |  + Finalize of local variable

  --                |  + Finalize of aggregate object

  --               + Initialize of aggregate object

  --               + Initialize of local variable

  C760009_1.TC_Trace( "=====> Case 2 <=====" );

  C760009_3.Check_1.TC_Check_2( Global_Control );

  Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_2" );

  --                |  |  |  |  + Finalize 2 at assignment in TC_Check_2

  --                |  |  |  |  + Finalize 2 embedded in local variable

  --                |  |  |  + Adjust 2 caused by assignment in TC_Check_2

  --                |  |  |  + Adjust at declaration in TC_Check_2

  --                |  |  + Initialize at declaration in TC_Check_2

  --                |  + Finalize of assignment target

  --                |  + Finalize of local variable

  --               + Initialize of local variable

  C760009_1.TC_Trace( "=====> Case 3 <=====" );

  Global_Control := ( C760009_2.Control with Data => 2 );

  Lesser_Assertion( 1, 1, 1, 3, 2, "Aggregate -> object" );

  --                |  |  |  |  + Finalize 2 by assignment

  --                |  |  |  + Adjust 2 caused by assignment

  --                |  |  |  + Adjust in aggregate creation

  --                |  |  + Initialize of aggregate object

  --                |  + Finalize of assignment target

  --               + Initialize of aggregate object

  C760009_1.TC_Trace( "=====> Case 4 <=====" );

  C760009_3.Check_1.TC_Check_3( Global_Control );

  Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3" );

  --                |  |  |  |  + Finalize 2 at assignment in TC_Check_3

  --                |  |  |  |  + Finalize 2 embedded in local variable

  --                |  |  |  + Adjust 2 at assignment in TC_Check_3

  --                |  |  |  + Adjust in local variable creation

  --                |  |  + Initialize of local variable in TC_Check_3

  --                |  + Finalize of assignment target

  --                |  + Finalize of local variable

  --               + Initialize of local variable

  C760009_1.TC_Trace( "=====> Case 5 <=====" );

  Global_Control := ( Parent_Control with Data => 3 );

  Lesser_Assertion( 1, 1, 1, 3, 2, "Object Aggregate -> object" );

  --                |  |  |  |  + Finalize 2 by assignment

  --                |  |  |  + Adjust 2 caused by assignment

  --                |  |  |  + Adjust in aggregate creation

  --                |  |  + Initialize of aggregate object

  --                |  + Finalize of assignment target

  --               + Initialize of aggregate object

  C760009_1.TC_Trace( "=====> Case 6 <=====" );

  -- perform this check a second time to make sure nothing is "remembered"

  C760009_3.Check_1.TC_Check_3( Global_Control );

  Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3 second time" );

  --                |  |  |  |  + Finalize 2 at assignment in TC_Check_3

  --                |  |  |  |  + Finalize 2 embedded in local variable

  --                |  |  |  + Adjust 2 at assignment in TC_Check_3

  --                |  |  |  + Adjust in local variable creation

  --                |  |  + Initialize of local variable in TC_Check_3

  --                |  + Finalize of assignment target

  --                |  + Finalize of local variable

  --               + Initialize of local variable

  Report.Result;

end C760009;