-- C760012.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 record components that have per-object access discriminant -- constraints are initialized in the order of their component -- declarations, and after any components that are not so constrained. -- -- Check that record components that have per-object access discriminant -- constraints are finalized in the reverse order of their component -- declarations, and before any components that are not so constrained. -- -- TEST DESCRIPTION: -- The type List_Item is the "container" type. It holds two fields that -- have per-object access discriminant constraints, and two fields that -- are not discriminated. These four fields are all controlled types. -- A fifth field is a pointer used to maintain a linked list of these -- data objects. Each component is of a unique type which allows for -- the test to simply track the order of initialization and finalization. -- -- The types and their purpose are: -- Constrained_First - a controlled discriminated type -- Constrained_Second - a controlled discriminated type -- Simple_First - a controlled type with no discriminant -- Simple_Second - a controlled type with no discriminant -- -- The required order of operations: -- Initialize -- ( Simple_First | Simple_Second ) -- no "internal order" required -- Constrained_First -- Constrained_Second -- Finalize -- Constrained_Second -- Constrained_First -- ( Simple_First | Simple_Second ) -- must be inverse of init. -- -- -- CHANGE HISTORY: -- 23 MAY 95 SAIC Initial version -- 02 MAY 96 SAIC Reorganized for 2.1 -- 05 DEC 96 SAIC Simplified for 2.1; added init/fin ordering check -- 31 DEC 97 EDS Remove references to and uses of -- Initialization_Sequence --! ---------------------------------------------------------------- C760012_0 with Ada.Finalization; with Ada.Unchecked_Deallocation; package C760012_0 is type List_Item; type List is access all List_Item; package Firsts is -- distinguish first from second type Constrained_First(Container : access List_Item) is new Ada.Finalization.Limited_Controlled with null record; procedure Initialize( T : in out Constrained_First ); procedure Finalize ( T : in out Constrained_First ); type Simple_First is new Ada.Finalization.Controlled with record My_Init_Seq_Number : Natural; end record; procedure Initialize( T : in out Simple_First ); procedure Finalize ( T : in out Simple_First ); end Firsts; type Constrained_Second(Container : access List_Item) is new Ada.Finalization.Limited_Controlled with null record; procedure Initialize( T : in out Constrained_Second ); procedure Finalize ( T : in out Constrained_Second ); type Simple_Second is new Ada.Finalization.Controlled with record My_Init_Seq_Number : Natural; end record; procedure Initialize( T : in out Simple_Second ); procedure Finalize ( T : in out Simple_Second ); -- by 3.8(18);6.0 the following type contains components constrained -- by per-object expressions type List_Item is new Ada.Finalization.Limited_Controlled with record ContentA : Firsts.Constrained_First( List_Item'Access ); -- C S SimpleA : Firsts.Simple_First; -- A T SimpleB : Simple_Second; -- A T ContentB : Constrained_Second( List_Item'Access ); -- D R Next : List; -- | | end record; -- | | procedure Initialize( L : in out List_Item ); ------------------+ | procedure Finalize ( L : in out List_Item ); --------------------+ -- the tags are the same for SimpleA and SimpleB due to the fact that -- the language does not specify an ordering with respect to this -- component pair. 7.6(12) does specify the rest of the ordering. procedure Deallocate is new Ada.Unchecked_Deallocation(List_Item,List); end C760012_0; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- with TCTouch; package body C760012_0 is package body Firsts is procedure Initialize( T : in out Constrained_First ) is begin TCTouch.Touch('C'); ----------------------------------------------- C end Initialize; procedure Finalize ( T : in out Constrained_First ) is begin TCTouch.Touch('S'); ----------------------------------------------- S end Finalize; procedure Initialize( T : in out Simple_First ) is begin T.My_Init_Seq_Number := 0; TCTouch.Touch('A'); ----------------------------------------------- A end Initialize; procedure Finalize ( T : in out Simple_First ) is begin TCTouch.Touch('T'); ----------------------------------------------- T end Finalize; end Firsts; procedure Initialize( T : in out Constrained_Second ) is begin TCTouch.Touch('D'); ------------------------------------------------- D end Initialize; procedure Finalize ( T : in out Constrained_Second ) is begin TCTouch.Touch('R'); ------------------------------------------------- R end Finalize; procedure Initialize( T : in out Simple_Second ) is begin T.My_Init_Seq_Number := 0; TCTouch.Touch('A'); ------------------------------------------------- A end Initialize; procedure Finalize ( T : in out Simple_Second ) is begin TCTouch.Touch('T'); ------------------------------------------------- T end Finalize; procedure Initialize( L : in out List_Item ) is begin TCTouch.Touch('F'); ------------------------------------------------- F end Initialize; procedure Finalize ( L : in out List_Item ) is begin TCTouch.Touch('Q'); ------------------------------------------------- Q end Finalize; end C760012_0; --------------------------------------------------------------------- C760012 with Report; with TCTouch; with C760012_0; procedure C760012 is use type C760012_0.List; procedure Subtest_1 is -- by 3.8(18);6.0 One_Of_Them is constrained by per-object constraints -- 7.6.1(9);6.0 dictates the order of finalization of the components One_Of_Them : C760012_0.List_Item; begin if One_Of_Them.Next /= null then -- just to hold the subtest in place Report.Failed("No default value for Next"); end if; end Subtest_1; List : C760012_0.List; procedure Subtest_2 is begin List := new C760012_0.List_Item; List.Next := new C760012_0.List_Item; end Subtest_2; procedure Subtest_3 is begin C760012_0.Deallocate( List.Next ); C760012_0.Deallocate( List ); end Subtest_3; begin -- Main test procedure. Report.Test ("C760012", "Check that record components that have " & "per-object access discriminant constraints " & "are initialized in the order of their " & "component declarations, and after any " & "components that are not so constrained. " & "Check that record components that have " & "per-object access discriminant constraints " & "are finalized in the reverse order of their " & "component declarations, and before any " & "components that are not so constrained" ); Subtest_1; TCTouch.Validate("AACDFQRSTT", "One object"); Subtest_2; TCTouch.Validate("AACDFAACDF", "Two objects dynamically allocated"); Subtest_3; TCTouch.Validate("QRSTTQRSTT", "Two objects deallocated"); Report.Result; end C760012;