URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c7/] [c760009.a] - Rev 149
Go to most recent revision | Compare with Previous | Blame | View Log
-- 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;
Go to most recent revision | Compare with Previous | Blame | View Log