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