diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c7/c760001.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c7/c760001.a | 390 |
1 files changed, 390 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760001.a b/gcc/testsuite/ada/acats/tests/c7/c760001.a new file mode 100644 index 000000000..be9ff8194 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760001.a @@ -0,0 +1,390 @@ +-- 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; |