| -- C760001.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 Initialize is called for objects and components of |
| -- a controlled type when the objects and components are not |
| -- assigned explicit initial values. Check this for "simple" controlled |
| -- objects, controlled record components and arrays with controlled |
| -- components. |
| -- |
| -- Check that if an explicit initial value is assigned to an object |
| -- or component of a controlled type then Initialize is not called. |
| -- |
| -- TEST DESCRIPTION: |
| -- This test derives a type for Ada.Finalization.Controlled, and |
| -- overrides the Initialize and Adjust operations for the type. The |
| -- intent of the type is that it should carry incremental values |
| -- indicating the ordering of events with respect to these (and default |
| -- initialization) operations. The body of the test uses these values |
| -- to determine that the implicit calls to these subprograms happen |
| -- (or don't) at the appropriate times. |
| -- |
| -- The test further derives types from this "root" type, which are the |
| -- actual types used in the test. One of the types is "simply" derived |
| -- from the "root" type, the other contains a component of the first |
| -- type, thus nesting a controlled object as a record component in |
| -- controlled objects. |
| -- |
| -- The main program declares objects of these types and checks the |
| -- values of the components to ascertain that they have been touched |
| -- as expected. |
| -- |
| -- Note that Finalization procedures are provided. This test does not |
| -- test that the calls to Finalization are made correctly. The |
| -- Finalization procedures are provided to catch an implementation that |
| -- calls Finalization at an incorrect time. |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 06 Dec 94 SAIC ACVC 2.0 |
| -- 10 Oct 95 SAIC Update and repair for ACVC 2.0.1 |
| -- |
| --! |
| |
| ---------------------------------------------------------------- C760001_0 |
| |
| with Ada.Finalization; |
| package C760001_0 is |
| subtype Unique_ID is Natural; |
| function Unique_Value return Unique_ID; |
| -- increments each time it's called |
| |
| function Most_Recent_Unique_Value return Unique_ID; |
| -- returns the same value as the most recent call to Unique_Value |
| |
| type Root_Controlled is new Ada.Finalization.Controlled with record |
| My_ID : Unique_ID := Unique_Value; |
| My_Init_ID : Unique_ID := Unique_ID'First; |
| My_Adj_ID : Unique_ID := Unique_ID'First; |
| end record; |
| |
| procedure Initialize( R: in out Root_Controlled ); |
| procedure Adjust ( R: in out Root_Controlled ); |
| |
| TC_Initialize_Calls_Is_Failing : Boolean := False; |
| |
| end C760001_0; |
| |
| -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- |
| |
| with Report; |
| package body C760001_0 is |
| |
| Global_Unique_Counter : Unique_ID := 0; |
| |
| function Unique_Value return Unique_ID is |
| begin |
| Global_Unique_Counter := Global_Unique_Counter +1; |
| return Global_Unique_Counter; |
| end Unique_Value; |
| |
| function Most_Recent_Unique_Value return Unique_ID is |
| begin |
| return Global_Unique_Counter; |
| end Most_Recent_Unique_Value; |
| |
| procedure Initialize( R: in out Root_Controlled ) is |
| begin |
| if TC_Initialize_Calls_Is_Failing then |
| Report.Failed("Initialized incorrectly called"); |
| end if; |
| R.My_Init_ID := Unique_Value; |
| end Initialize; |
| |
| procedure Adjust( R: in out Root_Controlled ) is |
| begin |
| R.My_Adj_ID := Unique_Value; |
| end Adjust; |
| |
| end C760001_0; |
| |
| ---------------------------------------------------------------- C760001_1 |
| |
| with Ada.Finalization; |
| with C760001_0; |
| package C760001_1 is |
| |
| type Proc_ID is (None, Init, Adj, Fin); |
| |
| type Test_Controlled is new C760001_0.Root_Controlled with record |
| Last_Proc_Called: Proc_ID := None; |
| end record; |
| |
| procedure Initialize( TC: in out Test_Controlled ); |
| procedure Adjust ( TC: in out Test_Controlled ); |
| procedure Finalize ( TC: in out Test_Controlled ); |
| |
| type Nested_Controlled is new C760001_0.Root_Controlled with record |
| Nested : C760001_0.Root_Controlled; |
| Last_Proc_Called: Proc_ID := None; |
| end record; |
| |
| procedure Initialize( TC: in out Nested_Controlled ); |
| procedure Adjust ( TC: in out Nested_Controlled ); |
| procedure Finalize ( TC: in out Nested_Controlled ); |
| |
| end C760001_1; |
| |
| -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- |
| |
| with Report; |
| package body C760001_1 is |
| |
| procedure Initialize( TC: in out Test_Controlled ) is |
| begin |
| if TC.Last_Proc_Called /= None then |
| Report.Failed("Initialize for Test_Controlled"); |
| end if; |
| TC.Last_Proc_Called := Init; |
| C760001_0.Initialize(C760001_0.Root_Controlled(TC)); |
| end Initialize; |
| |
| procedure Adjust ( TC: in out Test_Controlled ) is |
| begin |
| TC.Last_Proc_Called := Adj; |
| C760001_0.Adjust(C760001_0.Root_Controlled(TC)); |
| end Adjust; |
| |
| procedure Finalize ( TC: in out Test_Controlled ) is |
| begin |
| TC.Last_Proc_Called := Fin; |
| end Finalize; |
| |
| procedure Initialize( TC: in out Nested_Controlled ) is |
| begin |
| if TC.Last_Proc_Called /= None then |
| Report.Failed("Initialize for Nested_Controlled"); |
| end if; |
| TC.Last_Proc_Called := Init; |
| C760001_0.Initialize(C760001_0.Root_Controlled(TC)); |
| end Initialize; |
| |
| procedure Adjust ( TC: in out Nested_Controlled ) is |
| begin |
| TC.Last_Proc_Called := Adj; |
| C760001_0.Adjust(C760001_0.Root_Controlled(TC)); |
| end Adjust; |
| |
| procedure Finalize ( TC: in out Nested_Controlled ) is |
| begin |
| TC.Last_Proc_Called := Fin; |
| end Finalize; |
| |
| end C760001_1; |
| |
| ---------------------------------------------------------------- C760001 |
| |
| with Report; |
| with TCTouch; |
| with C760001_0; |
| with C760001_1; |
| with Ada.Finalization; |
| procedure C760001 is |
| |
| use type C760001_1.Proc_ID; |
| |
| -- in the first test, test the simple case. Check that a controlled object |
| -- causes a call to the procedure Initialize. |
| -- Also check that assignment causes a call to Adjust. |
| |
| procedure Check_Simple_Objects is |
| S,T : C760001_1.Test_Controlled; |
| begin |
| TCTouch.Assert(S.My_ID < S.My_Init_ID,"Default before dispatch"); |
| TCTouch.Assert((S.Last_Proc_Called = C760001_1.Init) and |
| (T.Last_Proc_Called = C760001_1.Init), |
| "Initialize for simple object"); |
| S := T; |
| TCTouch.Assert((S.Last_Proc_Called = C760001_1.Adj), |
| "Adjust for simple object"); |
| TCTouch.Assert((S.My_ID = T.My_ID), |
| "Simple object My_ID's don't match"); |
| TCTouch.Assert((S.My_Init_ID = T.My_Init_ID), |
| "Simple object My_Init_ID's don't match"); |
| TCTouch.Assert((S.My_Adj_ID > T.My_Adj_ID), |
| "Simple object My_Adj_ID's in wrong order"); |
| end Check_Simple_Objects; |
| |
| -- in the second test, test a more complex case, check that a controlled |
| -- component of a controlled object gets processed correctly |
| |
| procedure Check_Nested_Objects is |
| NO1 : C760001_1.Nested_Controlled; |
| begin |
| TCTouch.Assert((NO1.My_ID < NO1.My_Init_Id), |
| "Default value order incorrect"); |
| TCTouch.Assert((NO1.My_Init_Id > NO1.Nested.My_Init_ID), |
| "Initialization call order incorrect"); |
| end Check_Nested_Objects; |
| |
| -- check that objects assigned an initial value at declaration are Adjusted |
| -- and NOT Initialized |
| |
| procedure Check_Objects_With_Initial_Values is |
| |
| TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value; |
| |
| A: C760001_1.Test_Controlled := |
| ( Ada.Finalization.Controlled |
| with TC_Now, |
| TC_Now, |
| TC_Now, |
| C760001_1.None); |
| |
| B: C760001_1.Nested_Controlled := |
| ( Ada.Finalization.Controlled |
| with TC_Now, |
| TC_Now, |
| TC_Now, |
| C760001_0.Root_Controlled(A), |
| C760001_1.None); |
| |
| begin |
| -- the implementation may or may not call Adjust for the values |
| -- assigned into A and B, |
| -- but should NOT call Initialize. |
| -- if the value used in the aggregate is overwritten by Initialize, |
| -- this indicates failure |
| TCTouch.Assert(A.My_Init_Id = TC_Now, |
| "Initialize was called for A with initial value"); |
| TCTouch.Assert(B.My_Init_Id = TC_Now, |
| "Initialize was called for B with initial value"); |
| TCTouch.Assert(B.Nested.My_Init_ID = TC_Now, |
| "Initialize was called for B.Nested initial value"); |
| end Check_Objects_With_Initial_Values; |
| |
| procedure Check_Array_Case is |
| type Array_Simple is array(1..4) of C760001_1.Test_Controlled; |
| type Array_Nested is array(1..4) of C760001_1.Nested_Controlled; |
| |
| Simple_Array_Default : Array_Simple; |
| |
| Nested_Array_Default : Array_Nested; |
| |
| TC_A_Bit_Later : C760001_0.Unique_ID; |
| |
| begin |
| TC_A_Bit_Later := C760001_0.Unique_Value; |
| for N in 1..4 loop |
| TCTouch.Assert(Simple_Array_Default(N).Last_Proc_Called |
| = C760001_1.Init, |
| "Initialize for array initial value"); |
| |
| TCTouch.Assert( (Simple_Array_Default(N).My_Init_ID |
| > C760001_0.Unique_ID'First) |
| and (Simple_Array_Default(N).My_Init_ID |
| < TC_A_Bit_Later), |
| "Initialize timing for simple array"); |
| |
| TCTouch.Assert( (Nested_Array_Default(N).My_Init_ID |
| > C760001_0.Unique_ID'First) |
| and (Nested_Array_Default(N).My_Init_ID |
| < TC_A_Bit_Later), |
| "Initialize timing for container array"); |
| |
| TCTouch.Assert(Nested_Array_Default(N).Last_Proc_Called |
| = C760001_1.Init, |
| "Initialize for nested array (outer) initial value"); |
| |
| TCTouch.Assert( (Nested_Array_Default(N).Nested.My_Init_ID |
| > C760001_0.Unique_ID'First) |
| and (Nested_Array_Default(N).Nested.My_Init_ID |
| < Nested_Array_Default(N).My_Init_ID), |
| "Initialize timing for array content"); |
| end loop; |
| end Check_Array_Case; |
| |
| procedure Check_Array_Case_With_Initial_Values is |
| |
| TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value; |
| |
| type Array_Simple is array(1..4) of C760001_1.Test_Controlled; |
| type Array_Nested is array(1..4) of C760001_1.Nested_Controlled; |
| |
| Simple_Array_Explicit : Array_Simple := ( 1..4 => ( |
| Ada.Finalization.Controlled |
| with TC_Now, |
| TC_Now, |
| TC_Now, |
| C760001_1.None ) ); |
| |
| A : constant C760001_0.Root_Controlled := |
| ( Ada.Finalization.Controlled |
| with others => TC_Now); |
| |
| Nested_Array_Explicit : Array_Nested := ( 1..4 => ( |
| Ada.Finalization.Controlled |
| with TC_Now, |
| TC_Now, |
| TC_Now, |
| A, |
| C760001_1.None ) ); |
| |
| begin |
| -- the implementation may or may not call Adjust for the values |
| -- assigned into Simple_Array_Explicit and Nested_Array_Explicit, |
| -- but should NOT call Initialize. |
| -- if the value used in the aggregate is overwritten by Initialize, |
| -- this indicates failure |
| for N in 1..4 loop |
| TCTouch.Assert(Simple_Array_Explicit(N).My_Init_ID |
| = TC_Now, |
| "Initialize was called for array with initial value"); |
| TCTouch.Assert(Nested_Array_Explicit(N).My_Init_ID |
| = TC_Now, |
| "Initialize was called for nested array (outer) with initial value"); |
| TCTouch.Assert(Nested_Array_Explicit(N).Nested.My_Init_ID = TC_Now, |
| "Initialize was called for nested array (inner) with initial value"); |
| end loop; |
| end Check_Array_Case_With_Initial_Values; |
| |
| -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- |
| |
| begin -- Main test procedure. |
| |
| Report.Test ("C760001", "Check that Initialize is called for objects " & |
| "and components of a controlled type when the " & |
| "objects and components are not assigned " & |
| "explicit initial values. Check that if an " & |
| "explicit initial value is assigned to an " & |
| "object or component of a controlled type " & |
| "then Initialize is not called" ); |
| |
| Check_Simple_Objects; |
| |
| Check_Nested_Objects; |
| |
| Check_Array_Case; |
| |
| C760001_0.TC_Initialize_Calls_Is_Failing := True; |
| |
| Check_Objects_With_Initial_Values; |
| |
| Check_Array_Case_With_Initial_Values; |
| |
| Report.Result; |
| |
| end C760001; |
