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