aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc40001.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc40001.a')
-rw-r--r--gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc40001.a403
1 files changed, 403 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc40001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc40001.a
new file mode 100644
index 000000000..bf42470e6
--- /dev/null
+++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc40001.a
@@ -0,0 +1,403 @@
+-- CC40001.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 adjust is called on the value of a constant object created
+-- by the evaluation of a generic association for a formal object of
+-- mode in.
+--
+-- Check that those values are also subsequently finalized.
+--
+-- TEST DESCRIPTION:
+-- Create a backdrop of a controlled type sufficient to check that the
+-- correct operations get called at appropriate times. Create a generic
+-- unit that takes a formal parameter of a formal type. Create instances
+-- of this generic using various "levels" of the controlled type. Check
+-- the same case for a generic child unit.
+--
+-- The cases tested are where the type of the formal object is:
+-- a visible classwide type : CC40001_2
+-- a formal private type : CC40001_3
+-- a formal tagged type : CC40001_4
+--
+-- To more fully take advantage of the features of the language, and
+-- present a test which is "user oriented" this test utilizes multiple
+-- aspects of the language in combination. Using Ada.Strings.Unbounded
+-- in combination with Ada.Finalization and Ada.Calendar to build layers
+-- of an object oriented system will likely be very common in actual
+-- practice. A common paradigm in the language will also be the use of
+-- a parent package defining "basic" tagged types, and child packages
+-- will expand on those types via derivation. The model used in this
+-- test is a simple type containing a character identity (used in the
+-- identity). The next level of type add a timestamp. Further levels
+-- might add location information, etc. however for the purposes of this
+-- test we stop at the second layer, as it is sufficient to test the
+-- stated objective.
+--
+--
+-- CHANGE HISTORY:
+-- 06 FEB 96 SAIC Initial version
+-- 30 APR 96 SAIC Added finalization checks for 2.1
+-- 13 FEB 97 PWB.CTA Moved global objects into bodies, after Initialize
+-- body is elaborated; counted finalizations correctly.
+--!
+
+----------------------------------------------------------------- CC40001_0
+
+with Ada.Finalization;
+with Ada.Strings.Unbounded;
+package CC40001_0 is
+
+ type States is ( Erroneous, Defaulted, Initialized, Reset, Adjusted );
+
+ type Simple_Object(ID: Character) is
+ new Ada.Finalization.Controlled with
+ record
+ TC_Current_State : States := Defaulted;
+ Name : Ada.Strings.Unbounded.Unbounded_String;
+ end record;
+
+ procedure User_Operation( COB: in out Simple_Object; Name : String );
+ procedure Initialize( COB: in out Simple_Object );
+ procedure Adjust ( COB: in out Simple_Object );
+ procedure Finalize ( COB: in out Simple_Object );
+
+ Finalization_Count : Natural;
+
+end CC40001_0;
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+with Report;
+with TCTouch;
+package body CC40001_0 is
+
+ procedure User_Operation( COB: in out Simple_Object; Name : String ) is
+ begin
+ COB.Name := Ada.Strings.Unbounded.To_Unbounded_String(Name);
+ end User_Operation;
+
+ procedure Initialize( COB: in out Simple_Object ) is
+ begin
+ COB.TC_Current_State := Initialized;
+ end Initialize;
+
+ procedure Adjust ( COB: in out Simple_Object ) is
+ begin
+ COB.TC_Current_State := Adjusted;
+ TCTouch.Touch('A'); -------------------------------------------------- A
+ TCTouch.Touch(COB.ID); ------------------------------------------------ ID
+ -- note that the calls to touch will not be directly validated, it is
+ -- expected that some number > 0 of calls will be made to this procedure,
+ -- the subtests then clear (Flush) the Touch buffer and perform actions
+ -- where an incorrect implementation might call this procedure. Such a
+ -- call will fail on the attempt to "Validate" the null string.
+ end Adjust;
+
+ procedure Finalize ( COB: in out Simple_Object ) is
+ begin
+ COB.TC_Current_State := Erroneous;
+ Finalization_Count := Finalization_Count +1;
+ end Finalize;
+
+ TC_Global_Object : Simple_Object('G');
+
+end CC40001_0;
+
+----------------------------------------------------------------- CC40001_1
+
+with Ada.Calendar;
+package CC40001_0.CC40001_1 is
+
+ type Object_In_Time(ID: Character) is
+ new Simple_Object(ID) with
+ record
+ Birth : Ada.Calendar.Time;
+ Activity : Ada.Calendar.Time;
+ end record;
+
+ procedure User_Operation( COB: in out Object_In_Time;
+ Name: String );
+
+ procedure Initialize( COB: in out Object_In_Time );
+ procedure Adjust ( COB: in out Object_In_Time );
+ procedure Finalize ( COB: in out Object_In_Time );
+
+end CC40001_0.CC40001_1;
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+with Report;
+with TCTouch;
+package body CC40001_0.CC40001_1 is
+
+ procedure Initialize( COB: in out Object_In_Time ) is
+ begin
+ COB.TC_Current_State := Initialized;
+ COB.Birth := Ada.Calendar.Clock;
+ end Initialize;
+
+ procedure Adjust ( COB: in out Object_In_Time ) is
+ begin
+ COB.TC_Current_State := Adjusted;
+ TCTouch.Touch('a'); ------------------------------------------------ a
+ TCTouch.Touch(COB.ID); ------------------------------------------------ ID
+ end Adjust;
+
+ procedure Finalize ( COB: in out Object_In_Time ) is
+ begin
+ COB.TC_Current_State := Erroneous;
+ Finalization_Count := Finalization_Count +1;
+ end Finalize;
+
+ procedure User_Operation( COB: in out Object_In_Time;
+ Name: String ) is
+ begin
+ CC40001_0.User_Operation( Simple_Object(COB), Name );
+ COB.Activity := Ada.Calendar.Clock;
+ COB.TC_Current_State := Reset;
+ end User_Operation;
+
+ TC_Time_Object : Object_In_Time('g');
+
+end CC40001_0.CC40001_1;
+
+----------------------------------------------------------------- CC40001_2
+
+generic
+ TC_Check_Object : in CC40001_0.Simple_Object'Class;
+package CC40001_0.CC40001_2 is
+ procedure TC_Verify_State;
+end CC40001_0.CC40001_2;
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+with Report;
+package body CC40001_0.CC40001_2 is
+
+ procedure TC_Verify_State is
+ begin
+ if TC_Check_Object.TC_Current_State /= Adjusted then
+ Report.Failed( "CC40001_2 : Formal Object not adjusted" );
+ end if;
+ end TC_Verify_State;
+
+end CC40001_0.CC40001_2;
+
+----------------------------------------------------------------- CC40001_3
+
+generic
+ type Formal_Private(<>) is private;
+ TC_Check_Object : in Formal_Private;
+ with function Bad_Status( O: Formal_Private ) return Boolean;
+package CC40001_0.CC40001_3 is
+ procedure TC_Verify_State;
+end CC40001_0.CC40001_3;
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+with Report;
+package body CC40001_0.CC40001_3 is
+
+ procedure TC_Verify_State is
+ begin
+ if Bad_Status( TC_Check_Object ) then
+ Report.Failed( "CC40001_3 : Formal Object not adjusted" );
+ end if;
+ end TC_Verify_State;
+
+end CC40001_0.CC40001_3;
+
+----------------------------------------------------------------- CC40001_4
+
+generic
+ type Formal_Tagged_Private(<>) is tagged private;
+ TC_Check_Object : in Formal_Tagged_Private;
+ with function Bad_Status( O: Formal_Tagged_Private ) return Boolean;
+package CC40001_0.CC40001_4 is
+ procedure TC_Verify_State;
+end CC40001_0.CC40001_4;
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+with Report;
+package body CC40001_0.CC40001_4 is
+
+ procedure TC_Verify_State is
+ begin
+ if Bad_Status( TC_Check_Object ) then
+ Report.Failed( "CC40001_4 : Formal Object not adjusted" );
+ end if;
+ end TC_Verify_State;
+
+end CC40001_0.CC40001_4;
+
+------------------------------------------------------------------- CC40001
+
+with Report;
+with TCTouch;
+with CC40001_0.CC40001_1;
+with CC40001_0.CC40001_2;
+with CC40001_0.CC40001_3;
+with CC40001_0.CC40001_4;
+procedure CC40001 is
+
+ function Not_Adjusted( CO : CC40001_0.Simple_Object )
+ return Boolean is
+ use type CC40001_0.States;
+ begin
+ return CO.TC_Current_State /= CC40001_0.Adjusted;
+ end Not_Adjusted;
+
+ function Not_Adjusted( CO : CC40001_0.CC40001_1.Object_In_Time )
+ return Boolean is
+ use type CC40001_0.States;
+ begin
+ return CO.TC_Current_State /= CC40001_0.Adjusted;
+ end Not_Adjusted;
+
+ -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 1
+
+ procedure Subtest_1 is
+ Object_0 : CC40001_0.Simple_Object('T');
+ Object_1 : CC40001_0.CC40001_1.Object_In_Time('t');
+
+ package Subtest_1_1 is
+ new CC40001_0.CC40001_2( Object_0 ); -- classwide generic formal object
+
+ package Subtest_1_2 is
+ new CC40001_0.CC40001_2( Object_1 ); -- classwide generic formal object
+ begin
+ TCTouch.Flush; -- clear out all "A" and "T" entries, no further calls
+ -- to Touch should occur before the call to Validate
+
+ -- set the objects TC_Current_State to "Reset"
+ CC40001_0.User_Operation( Object_0, "Subtest 1" );
+ CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 1" );
+
+ -- check that the objects TC_Current_State is "Adjusted"
+ Subtest_1_1.TC_Verify_State;
+ Subtest_1_2.TC_Verify_State;
+
+ TCTouch.Validate( "", "No actions should occur here, subtest 1" );
+
+ end Subtest_1;
+
+ -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 2
+
+ procedure Subtest_2 is
+ Object_0 : CC40001_0.Simple_Object('T');
+ Object_1 : CC40001_0.CC40001_1.Object_In_Time('t');
+
+ package Subtest_2_1 is -- generic formal object is discriminated private
+ new CC40001_0.CC40001_3( CC40001_0.Simple_Object,
+ Object_0,
+ Not_Adjusted );
+
+ package Subtest_2_2 is -- generic formal object is discriminated private
+ new CC40001_0.CC40001_3( CC40001_0.CC40001_1.Object_In_Time,
+ Object_1,
+ Not_Adjusted );
+
+ begin
+ TCTouch.Flush; -- clear out all "A" and "T" entries
+
+ -- set the objects state to "Reset"
+ CC40001_0.User_Operation( Object_0, "Subtest 2" );
+ CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 2" );
+
+ Subtest_2_1.TC_Verify_State;
+ Subtest_2_2.TC_Verify_State;
+
+ TCTouch.Validate( "", "No actions should occur here, subtest 2" );
+
+ end Subtest_2;
+
+ -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 3
+
+ procedure Subtest_3 is
+ Object_0 : CC40001_0.Simple_Object('T');
+ Object_1 : CC40001_0.CC40001_1.Object_In_Time('t');
+
+ package Subtest_3_1 is -- generic formal object is discriminated tagged
+ new CC40001_0.CC40001_4( CC40001_0.Simple_Object,
+ Object_0,
+ Not_Adjusted );
+
+ package Subtest_3_2 is -- generic formal object is discriminated tagged
+ new CC40001_0.CC40001_4( CC40001_0.CC40001_1.Object_In_Time,
+ Object_1,
+ Not_Adjusted );
+ begin
+ TCTouch.Flush; -- clear out all "A" and "T" entries
+
+ -- set the objects state to "Reset"
+ CC40001_0.User_Operation( Object_0, "Subtest 3" );
+ CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 3" );
+
+ Subtest_3_1.TC_Verify_State;
+ Subtest_3_2.TC_Verify_State;
+
+ TCTouch.Validate( "", "No actions should occur here, subtest 3" );
+
+ end Subtest_3;
+
+begin -- Main test procedure.
+
+ Report.Test ("CC40001", "Check that adjust and finalize are called on " &
+ "the constant object created by the " &
+ "evaluation of a generic association for a " &
+ "formal object of mode in" );
+
+ -- check that the created constant objects are properly adjusted
+ -- and subsequently finalized
+
+ CC40001_0.Finalization_Count := 0;
+
+ Subtest_1;
+
+ if CC40001_0.Finalization_Count < 4 then
+ Report.Failed("Insufficient Finalizations for Subtest 1");
+ end if;
+
+ CC40001_0.Finalization_Count := 0;
+
+ Subtest_2;
+
+ if CC40001_0.Finalization_Count < 4 then
+ Report.Failed("Insufficient Finalizations for Subtest 2");
+ end if;
+
+ CC40001_0.Finalization_Count := 0;
+
+ Subtest_3;
+
+ if CC40001_0.Finalization_Count < 4 then
+ Report.Failed("Insufficient Finalizations for Subtest 3");
+ end if;
+
+ Report.Result;
+
+end CC40001;