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