diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cc/cc40001.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cc/cc40001.a | 403 |
1 files changed, 0 insertions, 403 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc40001.a b/gcc/testsuite/ada/acats/tests/cc/cc40001.a deleted file mode 100644 index bf42470e65b..00000000000 --- a/gcc/testsuite/ada/acats/tests/cc/cc40001.a +++ /dev/null @@ -1,403 +0,0 @@ --- 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; |