| -- 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; |
