CbC/CbC_gcc: gcc/testsuite/ada/acats/tests/c7/c760009.a comparison

comparison gcc/testsuite/ada/acats/tests/c7/c760009.a @ 111:04ced10e8804

gcc 7

author	kono
date	Fri, 27 Oct 2017 22:46:09 +0900
parents
children

comparison

equal deleted inserted replaced

-:561a7518be6b
+:04ced10e8804
+-- 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;

Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c7/c760009.a @ 111:04ced10e8804