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