-- C980001.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 when a construct is aborted the execution of an Initialize -- procedure as the last step of the default initialization of a -- controlled object is abort-deferred. -- -- Check that when a construct is aborted the execution of a Finalize -- procedure as part of the finalization of a controlled object is -- abort-deferred. -- -- Check that an assignment operation to an object with a controlled -- part is an abort-deferred operation. -- -- TEST DESCRIPTION: -- The controlled operations which are being tested call a subprogram -- which guarantees that the enclosing operation becomes aborted. -- -- Each object is created with a unique value to prevent optimizations -- due to the values being the same. -- -- Two protected objects are utilized to warrant that the operations -- are delayed in their execution until such time that the abort is -- processed. The object Hold_Up is used to hold the targeted -- operation in execution, the object Progress is used to communicate -- to the driver software that progress is indeed being made. -- -- -- CHANGE HISTORY: -- 01 MAY 95 SAIC Initial version -- 01 MAY 96 SAIC Revised for 2.1 -- 11 DEC 96 SAIC Final revision for 2.1 -- 02 DEC 97 EDS Remove 2 calls to C980001_0.Hold_Up.Lock --! ---------------------------------------------------------------- C980001_0 with Impdef; with Ada.Finalization; package C980001_0 is A_Little_While : constant Duration := Impdef.Switch_To_New_Task * 2.0; Enough_Time_For_The_Controlled_Operation_To_Happen : constant Duration := Impdef.Switch_To_New_Task * 4.0; function TC_Unique return Integer; type Sticks_In_Initialize is new Ada.Finalization.Controlled with record Item: Integer := TC_Unique; end record; procedure Initialize( AV: in out Sticks_In_Initialize ); type Sticks_In_Adjust is new Ada.Finalization.Controlled with record Item: Integer := TC_Unique; end record; procedure Adjust ( AV: in out Sticks_In_Adjust ); type Sticks_In_Finalize is new Ada.Finalization.Controlled with record Item: Integer := TC_Unique; end record; procedure Finalize ( AV: in out Sticks_In_Finalize ); Initialize_Called : Boolean := False; Adjust_Called : Boolean := False; Finalize_Called : Boolean := False; protected type Sticker is entry Lock; procedure Unlock; function Is_Locked return Boolean; private Locked : Boolean := False; end Sticker; Hold_Up : Sticker; Progress : Sticker; procedure Fail_And_Clear( Message : String ); end C980001_0; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- with Report; with TCTouch; package body C980001_0 is TC_Master_Value : Integer := 0; function TC_Unique return Integer is -- make all values unique. begin TC_Master_Value := TC_Master_Value +1; return TC_Master_Value; end TC_Unique; protected body Sticker is entry Lock when not Locked is begin Locked := True; end Lock; procedure Unlock is begin Locked := False; end Unlock; function Is_Locked return Boolean is begin return Locked; end Is_Locked; end Sticker; procedure Initialize( AV: in out Sticks_In_Initialize ) is begin TCTouch.Touch('I'); -------------------------------------------------- I Hold_Up.Unlock; -- cause the select to abort Initialize_Called := True; AV.Item := TC_Unique; TCTouch.Touch('i'); -------------------------------------------------- i Progress.Unlock; -- allows Wait_Your_Turn to continue end Initialize; procedure Adjust ( AV: in out Sticks_In_Adjust ) is begin TCTouch.Touch('A'); -------------------------------------------------- A Hold_Up.Unlock; -- cause the select to abort Adjust_Called := True; AV.Item := TC_Unique; TCTouch.Touch('a'); -------------------------------------------------- a Progress.Unlock; end Adjust; procedure Finalize ( AV: in out Sticks_In_Finalize ) is begin TCTouch.Touch('F'); -------------------------------------------------- F Hold_Up.Unlock; -- cause the select to abort Finalize_Called := True; AV.Item := TC_Unique; TCTouch.Touch('f'); -------------------------------------------------- f Progress.Unlock; end Finalize; procedure Fail_And_Clear( Message : String ) is begin Report.Failed(Message); Hold_Up.Unlock; Progress.Unlock; end Fail_And_Clear; end C980001_0; --------------------------------------------------------------------------- with Report; with TCTouch; with Impdef; with C980001_0; procedure C980001 is procedure Check_Initialize_Conditions is begin if not C980001_0.Initialize_Called then C980001_0.Fail_And_Clear("Initialize did not correctly complete"); end if; TCTouch.Validate("Ii", "Initialization Sequence"); end Check_Initialize_Conditions; procedure Check_Adjust_Conditions is begin if not C980001_0.Adjust_Called then C980001_0.Fail_And_Clear("Adjust did not correctly complete"); end if; TCTouch.Validate("Aa", "Adjust Sequence"); end Check_Adjust_Conditions; procedure Check_Finalize_Conditions is begin if not C980001_0.Finalize_Called then C980001_0.Fail_And_Clear("Finalize did not correctly complete"); end if; TCTouch.Validate("FfFfFf", "Finalization Sequence", Order_Meaningful => False); end Check_Finalize_Conditions; procedure Wait_Your_Turn is Overrun : Natural := 0; begin while C980001_0.Progress.Is_Locked loop -- and waits delay C980001_0.A_Little_While; Overrun := Overrun +1; if Overrun > 10 then C980001_0.Fail_And_Clear("Overrun expired lock"); end if; end loop; end Wait_Your_Turn; begin -- Main test procedure. Report.Test ("C980001", "Check the interaction between asynchronous " & "transfer of control and controlled types" ); C980001_0.Progress.Lock; C980001_0.Hold_Up.Lock; select C980001_0.Hold_Up.Lock; -- Init will unlock Wait_Your_Turn; -- abortable part is stuck in Initialize Check_Initialize_Conditions; then abort declare Object : C980001_0.Sticks_In_Initialize; begin delay Impdef.Minimum_Task_Switch; if Report.Ident_Int( Object.Item ) /= Object.Item then Report.Failed("Optimization foil caused failure"); end if; C980001_0.Fail_And_Clear( "Initialize test executed beyond expected region"); end; end select; C980001_0.Progress.Lock; select C980001_0.Hold_Up.Lock; -- Adjust will unlock Wait_Your_Turn; -- abortable part is stuck in Adjust Check_Adjust_Conditions; then abort declare Object1 : C980001_0.Sticks_In_Adjust; Object2 : C980001_0.Sticks_In_Adjust; begin Object1 := Object2; delay Impdef.Minimum_Task_Switch; if Report.Ident_Int( Object2.Item ) /= Report.Ident_Int( Object1.Item ) then Report.Failed("Optimization foil 1 caused failure"); end if; C980001_0.Fail_And_Clear("Adjust test executed beyond expected region"); end; end select; C980001_0.Progress.Lock; select C980001_0.Hold_Up.Lock; -- Finalize will unlock Wait_Your_Turn; -- abortable part is stuck in Finalize Check_Finalize_Conditions; then abort declare Object1 : C980001_0.Sticks_In_Finalize; Object2 : C980001_0.Sticks_In_Finalize; begin Object1 := Object2; -- cause a finalize call delay Impdef.Minimum_Task_Switch; if Report.Ident_Int( Object2.Item ) /= Report.Ident_Int( Object1.Item ) then Report.Failed("Optimization foil 2 caused failure"); end if; C980001_0.Fail_And_Clear( "Finalize test executed beyond expected region"); end; end select; Report.Result; exception when others => C980001_0.Fail_And_Clear("Exception in main"); Report.Result; end C980001;