diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c7/c760009.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c7/c760009.a | 533 |
1 files changed, 0 insertions, 533 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760009.a b/gcc/testsuite/ada/acats/tests/c7/c760009.a deleted file mode 100644 index 8c3b80b3625..00000000000 --- a/gcc/testsuite/ada/acats/tests/c7/c760009.a +++ /dev/null @@ -1,533 +0,0 @@ --- C760009.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 for an extension_aggregate whose ancestor_part is a --- subtype_mark (i.e. Typemark'( Subtype with Field => x, etc.) ) --- Initialize is called on all controlled subcomponents of the --- ancestor part; if the type of the ancestor part is itself controlled, --- the Initialize procedure of the ancestor type is called, unless that --- Initialize procedure is abstract. --- --- Check that the utilization of a controlled type for a generic actual --- parameter supports the correct behavior in the instantiated package. --- --- TEST DESCRIPTION: --- Declares a generic package instantiated to check that controlled --- types are not impacted by the "generic boundary." --- This instance is then used to perform the tests of various --- aggregate formations of the controlled type. After each operation --- in the main program that should cause implicit calls, the "state" of --- the software is checked. The "state" of the software is maintained in --- several variables which count the calls to the Initialize, Adjust and --- Finalize procedures in each context. Given the nature of the --- language rules, the test specifies a minimum number of times that --- these subprograms should have been called. The test also checks cases --- where the subprograms should not have been called. --- --- As per the example in AARM 7.6(11a..d);6.0, the distinctions between --- the presence/absence of default values is tested. --- --- DATA STRUCTURES --- --- C760009_3.Master_Control is derived from --- C760009_2.Control is derived from --- Ada.Finalization.Controlled --- --- C760009_1.Simple_Control is derived from --- Ada.Finalization.Controlled --- --- C760009_3.Master_Control contains --- Standard.Integer --- --- C760009_2.Control contains --- C760009_1.Simple_Control (default value) --- C760009_1.Simple_Control (default initialized) --- --- --- CHANGE HISTORY: --- 01 MAY 95 SAIC Initial version --- 19 FEB 96 SAIC Fixed elaboration Initialize count --- 14 NOV 96 SAIC Allowed for 7.6(21) optimizations --- 13 FEB 97 PWB.CTA Initialized counters at lines 127-129 --- 26 JUN 98 EDS Added pragma Elaborate_Body to C760009_0 --- to avoid possible instantiation error ---! - ----------------------------------------------------------------- C760009_0 - -with Ada.Finalization; -generic - - type Private_Formal is private; - - with procedure TC_Validate( APF: in out Private_Formal ); - -package C760009_0 is -- Check_1 - - pragma Elaborate_Body; - procedure TC_Check_1( APF: in Private_Formal ); - procedure TC_Check_2( APF: out Private_Formal ); - procedure TC_Check_3( APF: in out Private_Formal ); - -end C760009_0; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with Report; -package body C760009_0 is -- Check_1 - - procedure TC_Check_1( APF: in Private_Formal ) is - Local : Private_Formal; - begin - Local := APF; - TC_Validate( Local ); - end TC_Check_1; - - procedure TC_Check_2( APF: out Private_Formal ) is - Local : Private_Formal; -- initialized by virtue of actual being - -- Controlled - begin - APF := Local; - TC_Validate( APF ); - end TC_Check_2; - - procedure TC_Check_3( APF: in out Private_Formal ) is - Local : Private_Formal; - begin - Local := APF; - TC_Validate( Local ); - end TC_Check_3; - -end C760009_0; - ----------------------------------------------------------------- C760009_1 - -with Ada.Finalization; -package C760009_1 is - - Initialize_Called : Natural := 0; - Adjust_Called : Natural := 0; - Finalize_Called : Natural := 0; - - procedure Reset_Counters; - - type Simple_Control is new Ada.Finalization.Controlled with private; - - procedure Initialize( AV: in out Simple_Control ); - procedure Adjust ( AV: in out Simple_Control ); - procedure Finalize ( AV: in out Simple_Control ); - procedure Validate ( AV: in out Simple_Control ); - - function Item( AV: Simple_Control'Class ) return String; - - Empty : constant Simple_Control; - - procedure TC_Trace( Message: String ); - -private - type Simple_Control is new Ada.Finalization.Controlled with record - Item: Natural; - end record; - - Empty : constant Simple_Control := ( Ada.Finalization.Controlled with 0 ); - -end C760009_1; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with Report; -package body C760009_1 is - - -- Maintenance_Mode and TC_Trace are for the test writers and compiler - -- developers to get more information from this test as it executes. - -- Maintenance_Mode is always False for validation purposes. - - Maintenance_Mode : constant Boolean := False; - - procedure TC_Trace( Message: String ) is - begin - if Maintenance_Mode then - Report.Comment( Message ); - end if; - end TC_Trace; - - procedure Reset_Counters is - begin - Initialize_Called := 0; - Adjust_Called := 0; - Finalize_Called := 0; - end Reset_Counters; - - Master_Count : Natural := 100; -- Help distinguish values - - procedure Initialize( AV: in out Simple_Control ) is - begin - Initialize_Called := Initialize_Called +1; - AV.Item := Master_Count; - Master_Count := Master_Count +100; - TC_Trace( "Initialize _1.Simple_Control" ); - end Initialize; - - procedure Adjust ( AV: in out Simple_Control ) is - begin - Adjust_Called := Adjust_Called +1; - AV.Item := AV.Item +1; - TC_Trace( "Adjust _1.Simple_Control" ); - end Adjust; - - procedure Finalize ( AV: in out Simple_Control ) is - begin - Finalize_Called := Finalize_Called +1; - AV.Item := AV.Item +1; - TC_Trace( "Finalize _1.Simple_Control" ); - end Finalize; - - procedure Validate ( AV: in out Simple_Control ) is - begin - Report.Failed("Attempt to Validate at Simple_Control level"); - end Validate; - - function Item( AV: Simple_Control'Class ) return String is - begin - return Natural'Image(AV.Item); - end Item; - -end C760009_1; - ----------------------------------------------------------------- C760009_2 - -with C760009_1; -with Ada.Finalization; -package C760009_2 is - - type Control is new Ada.Finalization.Controlled with record - Element_1 : C760009_1.Simple_Control; - Element_2 : C760009_1.Simple_Control := C760009_1.Empty; - end record; - - procedure Initialize( AV: in out Control ); - procedure Finalize ( AV: in out Control ); - - Initialized : Natural := 0; - Finalized : Natural := 0; - -end C760009_2; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -package body C760009_2 is - - procedure Initialize( AV: in out Control ) is - begin - Initialized := Initialized +1; - C760009_1.TC_Trace( "Initialize _2.Control" ); - end Initialize; - - procedure Finalize ( AV: in out Control ) is - begin - Finalized := Finalized +1; - C760009_1.TC_Trace( "Finalize _2.Control" ); - end Finalize; - -end C760009_2; - ----------------------------------------------------------------- C760009_3 - -with C760009_0; -with C760009_2; -package C760009_3 is - - type Master_Control is new C760009_2.Control with record - Data: Integer; - end record; - - procedure Initialize( AC: in out Master_Control ); - -- calls C760009_2.Initialize - -- embedded data causes 1 call to C760009_1.Initialize - - -- Adjusting operation will - -- make 1 call to C760009_2.Adjust - -- make 2 call to C760009_1.Adjust - - -- Finalize operation will - -- make 1 call to C760009_2.Finalize - -- make 2 call to C760009_1.Finalize - - procedure Validate( AC: in out Master_Control ); - - package Check_1 is - new C760009_0(Master_Control, Validate); - -end C760009_3; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with Report; -with C760009_1; -package body C760009_3 is - - procedure Initialize( AC: in out Master_Control ) is - begin - AC.Data := 42; - C760009_2.Initialize(C760009_2.Control(AC)); - C760009_1.TC_Trace( "Initialize Master_Control" ); - end Initialize; - - procedure Validate( AC: in out Master_Control ) is - begin - if AC.Data not in 0..1000 then - Report.Failed("C760009_3.Control did not Initialize" ); - end if; - end Validate; - -end C760009_3; - ---------------------------------------------------------------------- C760009 - -with Report; -with C760009_1; -with C760009_2; -with C760009_3; -procedure C760009 is - - -- Comment following declaration indicates expected calls in the order: - -- Initialize of a C760009_2 value - -- Finalize of a C760009_2 value - -- Initialize of a C760009_1 value - -- Adjust of a C760009_1 value - -- Finalize of a C760009_1 value - - Global_Control : C760009_3.Master_Control; - -- 1, 0, 1, 1, 0 - - Parent_Control : C760009_2.Control; - -- 1, 0, 1, 1, 0 - - -- Global_Control is a derived tagged type, the parent type - -- of Master_Control, Control, is derived from Controlled, and contains - -- two components of a Controlled type, Simple_Control. One of these - -- components has a default value, the other does not. - - procedure Fail( Which: String; Expect, Got: Natural ) is - begin - Report.Failed(Which & " Expected" & Natural'Image(Expect) - & " got" & Natural'Image(Got) ); - end Fail; - - procedure Master_Assertion( Layer_2_Inits : Natural; - Layer_2_Finals : Natural; - Layer_1_Inits : Natural; - Layer_1_Adjs : Natural; - Layer_1_Finals : Natural; - Failing_Message : String ) is - - begin - - - - if C760009_2.Initialized /= Layer_2_Inits then - Fail("C760009_2.Initialize " & Failing_Message, - Layer_2_Inits, C760009_2.Initialized ); - end if; - - if C760009_2.Finalized not in Layer_2_Finals..Layer_2_Finals*2 then - Fail("C760009_2.Finalize " & Failing_Message, - Layer_2_Finals, C760009_2.Finalized ); - end if; - - if C760009_1.Initialize_Called /= Layer_1_Inits then - Fail("C760009_1.Initialize " & Failing_Message, - Layer_1_Inits, - C760009_1.Initialize_Called ); - end if; - - if C760009_1.Adjust_Called not in Layer_1_Adjs..Layer_1_Adjs*2 then - Fail("C760009_1.Adjust " & Failing_Message, - Layer_1_Adjs, C760009_1.Adjust_Called ); - end if; - - if C760009_1.Finalize_Called not in Layer_1_Finals..Layer_1_Finals*2 then - Fail("C760009_1.Finalize " & Failing_Message, - Layer_1_Finals, C760009_1.Finalize_Called ); - end if; - - C760009_1.Reset_Counters; - C760009_2.Initialized := 0; - C760009_2.Finalized := 0; - - end Master_Assertion; - - procedure Lesser_Assertion( Layer_2_Inits : Natural; - Layer_2_Finals : Natural; - Layer_1_Inits : Natural; - Layer_1_Adjs : Natural; - Layer_1_Finals : Natural; - Failing_Message : String ) is - begin - - - if C760009_2.Initialized > Layer_2_Inits then - Fail("C760009_2.Initialize " & Failing_Message, - Layer_2_Inits, C760009_2.Initialized ); - end if; - - if C760009_2.Finalized < Layer_2_Inits - or C760009_2.Finalized > Layer_2_Finals*2 then - Fail("C760009_2.Finalize " & Failing_Message, - Layer_2_Finals, C760009_2.Finalized ); - end if; - - if C760009_1.Initialize_Called > Layer_1_Inits then - Fail("C760009_1.Initialize " & Failing_Message, - Layer_1_Inits, - C760009_1.Initialize_Called ); - end if; - - if C760009_1.Adjust_Called > Layer_1_Adjs*2 then - Fail("C760009_1.Adjust " & Failing_Message, - Layer_1_Adjs, C760009_1.Adjust_Called ); - end if; - - if C760009_1.Finalize_Called < Layer_1_Inits - or C760009_1.Finalize_Called > Layer_1_Finals*2 then - Fail("C760009_1.Finalize " & Failing_Message, - Layer_1_Finals, C760009_1.Finalize_Called ); - end if; - - C760009_1.Reset_Counters; - C760009_2.Initialized := 0; - C760009_2.Finalized := 0; - - end Lesser_Assertion; - -begin -- Main test procedure. - - Report.Test ("C760009", "Check that for an extension_aggregate whose " & - "ancestor_part is a subtype_mark, Initialize " & - "is called on all controlled subcomponents of " & - "the ancestor part. Also check that the " & - "utilization of a controlled type for a generic " & - "actual parameter supports the correct behavior " & - "in the instantiated software" ); - - C760009_1.TC_Trace( "=====> Case 0 <=====" ); - - C760009_1.Reset_Counters; - C760009_2.Initialized := 0; - C760009_2.Finalized := 0; - - C760009_3.Validate( Global_Control ); -- check that it Initialized correctly - - C760009_1.TC_Trace( "=====> Case 1 <=====" ); - - C760009_3.Check_1.TC_Check_1( ( C760009_2.Control with Data => 1 ) ); - Lesser_Assertion( 2, 3, 2, 3, 6, "Check_1.TC_Check_1" ); - -- | | | | + Finalize 2 embedded in aggregate - -- | | | | + Finalize 2 at assignment in TC_Check_1 - -- | | | | + Finalize 2 embedded in local variable - -- | | | + Adjust 2 caused by assignment in TC_Check_1 - -- | | | + Adjust at declaration in TC_Check_1 - -- | | + Initialize at declaration in TC_Check_1 - -- | | + Initialize of aggregate object - -- | + Finalize of assignment target - -- | + Finalize of local variable - -- | + Finalize of aggregate object - -- + Initialize of aggregate object - -- + Initialize of local variable - - - C760009_1.TC_Trace( "=====> Case 2 <=====" ); - - C760009_3.Check_1.TC_Check_2( Global_Control ); - Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_2" ); - -- | | | | + Finalize 2 at assignment in TC_Check_2 - -- | | | | + Finalize 2 embedded in local variable - -- | | | + Adjust 2 caused by assignment in TC_Check_2 - -- | | | + Adjust at declaration in TC_Check_2 - -- | | + Initialize at declaration in TC_Check_2 - -- | + Finalize of assignment target - -- | + Finalize of local variable - -- + Initialize of local variable - - - C760009_1.TC_Trace( "=====> Case 3 <=====" ); - - Global_Control := ( C760009_2.Control with Data => 2 ); - Lesser_Assertion( 1, 1, 1, 3, 2, "Aggregate -> object" ); - -- | | | | + Finalize 2 by assignment - -- | | | + Adjust 2 caused by assignment - -- | | | + Adjust in aggregate creation - -- | | + Initialize of aggregate object - -- | + Finalize of assignment target - -- + Initialize of aggregate object - - - C760009_1.TC_Trace( "=====> Case 4 <=====" ); - - C760009_3.Check_1.TC_Check_3( Global_Control ); - Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3" ); - -- | | | | + Finalize 2 at assignment in TC_Check_3 - -- | | | | + Finalize 2 embedded in local variable - -- | | | + Adjust 2 at assignment in TC_Check_3 - -- | | | + Adjust in local variable creation - -- | | + Initialize of local variable in TC_Check_3 - -- | + Finalize of assignment target - -- | + Finalize of local variable - -- + Initialize of local variable - - - C760009_1.TC_Trace( "=====> Case 5 <=====" ); - - Global_Control := ( Parent_Control with Data => 3 ); - Lesser_Assertion( 1, 1, 1, 3, 2, "Object Aggregate -> object" ); - -- | | | | + Finalize 2 by assignment - -- | | | + Adjust 2 caused by assignment - -- | | | + Adjust in aggregate creation - -- | | + Initialize of aggregate object - -- | + Finalize of assignment target - -- + Initialize of aggregate object - - - - C760009_1.TC_Trace( "=====> Case 6 <=====" ); - - -- perform this check a second time to make sure nothing is "remembered" - - C760009_3.Check_1.TC_Check_3( Global_Control ); - Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3 second time" ); - -- | | | | + Finalize 2 at assignment in TC_Check_3 - -- | | | | + Finalize 2 embedded in local variable - -- | | | + Adjust 2 at assignment in TC_Check_3 - -- | | | + Adjust in local variable creation - -- | | + Initialize of local variable in TC_Check_3 - -- | + Finalize of assignment target - -- | + Finalize of local variable - -- + Initialize of local variable - - - Report.Result; - -end C760009; |