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