diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c7/c761007.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c7/c761007.a | 419 |
1 files changed, 0 insertions, 419 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761007.a b/gcc/testsuite/ada/acats/tests/c7/c761007.a deleted file mode 100644 index 7b3dbfb9b6e..00000000000 --- a/gcc/testsuite/ada/acats/tests/c7/c761007.a +++ /dev/null @@ -1,419 +0,0 @@ --- C761007.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 if a finalize procedure invoked by a transfer of control --- due to selection of a terminate alternative attempts to propagate an --- exception, the exception is ignored, but any other finalizations due --- to be performed are performed. --- --- --- TEST DESCRIPTION: --- This test declares a nested controlled data type, and embeds an object --- of that type within a protected type. Objects of the protected type --- are created and destroyed, and the actions of the embedded controlled --- object are checked. The container controlled type causes an exception --- as the last part of it's finalization operation. --- --- This test utilizes several tasks to accomplish the objective. The --- tasks contain delays to ensure that the expected order of processing --- is indeed accomplished. --- --- Subtest 1: --- local task object runs to normal completion --- --- Subtest 2: --- local task aborts a nested task to cause finalization --- --- Subtest 3: --- local task sleeps long enough to allow procedure started --- asynchronously to go into infinite loop. Procedure is then aborted --- via ATC, causing finalization of objects. --- --- Subtest 4: --- local task object takes terminate alternative, causing finalization --- --- --- CHANGE HISTORY: --- 06 JUN 95 SAIC Initial version --- 05 APR 96 SAIC Documentation changes --- 03 MAR 97 PWB.CTA Allowed two finalization orders for ATC test --- 02 DEC 97 EDS Remove duplicate characters from check string. ---! - ----------------------------------------------------------------- C761007_0 - -with Ada.Finalization; -package C761007_0 is - - type Internal is new Ada.Finalization.Controlled - with record - Effect : Character; - end record; - - procedure Finalize( I: in out Internal ); - - Side_Effect : String(1..80); -- way bigger than needed - Side_Effect_Finger : Natural := 0; - -end C761007_0; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with TCTouch; -package body C761007_0 is - - procedure Finalize( I : in out Internal ) is - Previous_Side_Effect : Boolean := False; - begin - -- look to see if this character has been finalized yet - for SEI in 1..Side_Effect_Finger loop - Previous_Side_Effect := Previous_Side_Effect - or Side_Effect(Side_Effect_Finger) = I.Effect; - end loop; - - -- if not, then tack it on to the string, and touch the character - if not Previous_Side_Effect then - Side_Effect_Finger := Side_Effect_Finger +1; - Side_Effect(Side_Effect_Finger) := I.Effect; - TCTouch.Touch(I.Effect); - end if; - - end Finalize; - -end C761007_0; - ----------------------------------------------------------------- C761007_1 - -with C761007_0; -with Ada.Finalization; -package C761007_1 is - - type Container is new Ada.Finalization.Controlled - with record - Effect : Character; - Content : C761007_0.Internal; - end record; - - procedure Finalize( C: in out Container ); - - Side_Effect : String(1..80); -- way bigger than needed - Side_Effect_Finger : Natural := 0; - - This_Exception_Is_Supposed_To_Be_Ignored : exception; - -end C761007_1; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with TCTouch; -package body C761007_1 is - - procedure Finalize( C: in out Container ) is - Previous_Side_Effect : Boolean := False; - begin - -- look to see if this character has been finalized yet - for SEI in 1..Side_Effect_Finger loop - Previous_Side_Effect := Previous_Side_Effect - or Side_Effect(Side_Effect_Finger) = C.Effect; - end loop; - - -- if not, then tack it on to the string, and touch the character - if not Previous_Side_Effect then - Side_Effect_Finger := Side_Effect_Finger +1; - Side_Effect(Side_Effect_Finger) := C.Effect; - TCTouch.Touch(C.Effect); - end if; - - raise This_Exception_Is_Supposed_To_Be_Ignored; - - end Finalize; - -end C761007_1; - ----------------------------------------------------------------- C761007_2 -with C761007_1; -package C761007_2 is - - protected type Prot_W_Fin_Obj is - procedure Set_Effects( Container, Filling: Character ); - private - The_Data_Under_Test : C761007_1.Container; - -- finalization for this will occur when the Prot_W_Fin_Obj object - -- "goes out of existence" for whatever reason. - end Prot_W_Fin_Obj; - -end C761007_2; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -package body C761007_2 is - - protected body Prot_W_Fin_Obj is - procedure Set_Effects( Container, Filling: Character ) is - begin - The_Data_Under_Test.Effect := Container; -- A, etc. - The_Data_Under_Test.Content.Effect := Filling; -- B, etc. - end Set_Effects; - end Prot_W_Fin_Obj; - -end C761007_2; - ------------------------------------------------------------------- C761007 - -with Report; -with Impdef; -with TCTouch; -with C761007_0; -with C761007_1; -with C761007_2; -procedure C761007 is - - task type Subtests( Outer, Inner : Character) is - entry Ready; - entry Complete; - end Subtests; - - task body Subtests is - Local_Prot_W_Fin_Obj : C761007_2.Prot_W_Fin_Obj; - begin - Local_Prot_W_Fin_Obj.Set_Effects( Outer, Inner ); - - accept Ready; - - select - accept Complete; - or terminate; -- used in Subtest 4 - end select; - exception - -- the exception caused by the finalization of Local_Prot_W_Fin_Obj - -- should never be visible to this scope. - when others => Report.Failed("Exception in a Subtest object " - & Outer & Inner); - end Subtests; - - procedure Subtest_1 is - -- check the case where "nothing special" happens. - - This_Subtest : Subtests( 'A', 'B' ); - begin - - This_Subtest.Ready; - This_Subtest.Complete; - - while not This_Subtest'Terminated loop -- wait for finalization - delay Impdef.Clear_Ready_Queue; - end loop; - - -- in the finalization of This_Subtest, the controlled object embedded in - -- the Prot_W_Fin_Obj will finalize. An exception is raised in the - -- container object, after "touching" it's tag character. - -- The finalization of the contained controlled object must be performed. - - - TCTouch.Validate( "AB", "Item embedded in task" ); - - - exception - when others => Report.Failed("Undesirable exception in Subtest_1"); - - end Subtest_1; - - procedure Subtest_2 is - -- check for explicit abort - - task Subtest_Task is - entry Complete; - end Subtest_Task; - - task body Subtest_Task is - - task Nesting; - task body Nesting is - Deep_Nesting : Subtests( 'E', 'F' ); - begin - if Report.Ident_Bool( True ) then - -- controlled objects have been created in the elaboration of - -- Deep_Nesting. Deep_Nesting must call the Set_Effects operation - -- in the Prot_W_Fin_Obj, and then hang waiting for the Complete - -- entry call. - Deep_Nesting.Ready; - abort Deep_Nesting; - else - Report.Failed("Dead code in Nesting"); - end if; - exception - when others => Report.Failed("Exception in Subtest_Task.Nesting"); - end Nesting; - - Local_2 : C761007_2.Prot_W_Fin_Obj; - - begin - -- Nesting has activated at this point, which implies the activation - -- of Deep_Nesting as well. - - Local_2.Set_Effects( 'C', 'D' ); - - -- wait for Nesting to terminate - - while not Nesting'Terminated loop - delay Impdef.Clear_Ready_Queue; - end loop; - - accept Complete; - - exception - when others => Report.Failed("Exception in Subtest_Task"); - end Subtest_Task; - - begin - - -- wait for everything in Subtest_Task to happen - Subtest_Task.Complete; - - while not Subtest_Task'Terminated loop -- wait for finalization - delay Impdef.Clear_Ready_Queue; - end loop; - - TCTouch.Validate( "EFCD", "Aborted nested task" ); - - exception - when others => Report.Failed("Undesirable exception in Subtest_2"); - end Subtest_2; - - procedure Subtest_3 is - -- check abort caused by asynchronous transfer of control - - task Subtest_3_Task is - entry Complete; - end Subtest_3_Task; - - procedure Check_Atc_Operation is - Check_Atc : C761007_2.Prot_W_Fin_Obj; - begin - - Check_Atc.Set_Effects( 'G', 'H' ); - - - while Report.Ident_Bool( True ) loop -- wait to be aborted - if Report.Ident_Bool( True ) then - Impdef.Exceed_Time_Slice; - delay Impdef.Switch_To_New_Task; - else - Report.Failed("Optimization prevention"); - end if; - end loop; - - Report.Failed("Check_Atc_Operation loop completed"); - - end Check_Atc_Operation; - - task body Subtest_3_Task is - task Nesting is - entry Complete; - end Nesting; - - task body Nesting is - Nesting_3 : C761007_2.Prot_W_Fin_Obj; - begin - Nesting_3.Set_Effects( 'G', 'H' ); - - -- give Check_Atc_Operation sufficient time to perform it's - -- Set_Effects on it's local Prot_W_Fin_Obj object - delay Impdef.Clear_Ready_Queue; - - accept Complete; - exception - when others => Report.Failed("Exception in Subtest_3_Task.Nesting"); - end Nesting; - - Local_3 : C761007_2.Prot_W_Fin_Obj; - - begin -- Subtest_3_Task - - Local_3.Set_Effects( 'I', 'J' ); - - select - Nesting.Complete; - then abort ---------------------------------------------------- cause KL - Check_ATC_Operation; - end select; - - accept Complete; - - exception - when others => Report.Failed("Exception in Subtest_3_Task"); - end Subtest_3_Task; - - begin -- Subtest_3 - Subtest_3_Task.Complete; - - while not Subtest_3_Task'Terminated loop -- wait for finalization - delay Impdef.Clear_Ready_Queue; - end loop; - - TCTouch.Validate( "GHIJ", "Asynchronously aborted operation" ); - - exception - when others => Report.Failed("Undesirable exception in Subtest_3"); - end Subtest_3; - - procedure Subtest_4 is - -- check the case where transfer is caused by terminate alternative - -- highly similar to Subtest_1 - - This_Subtest : Subtests( 'M', 'N' ); - begin - - This_Subtest.Ready; - -- don't call This_Subtest.Complete; - - exception - when others => Report.Failed("Undesirable exception in Subtest_4"); - - end Subtest_4; - -begin -- Main test procedure. - - Report.Test ("C761007", "Check that if a finalize procedure invoked by " & - "a transfer of control or selection of a " & - "terminate alternative attempts to propagate " & - "an exception, the exception is ignored, but " & - "any other finalizations due to be performed " & - "are performed" ); - - Subtest_1; -- checks internal - - Subtest_2; -- checks internal - - Subtest_3; -- checks internal - - Subtest_4; - TCTouch.Validate( "MN", "transfer due to terminate alternative" ); - - Report.Result; - -end C761007; |