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, 0 insertions, 390 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760001.a b/gcc/testsuite/ada/acats/tests/c7/c760001.a deleted file mode 100644 index be9ff81946c..00000000000 --- a/gcc/testsuite/ada/acats/tests/c7/c760001.a +++ /dev/null @@ -1,390 +0,0 @@ --- 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; |