diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c7/c760010.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c7/c760010.a | 418 |
1 files changed, 0 insertions, 418 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760010.a b/gcc/testsuite/ada/acats/tests/c7/c760010.a deleted file mode 100644 index 08fe62b9fa4..00000000000 --- a/gcc/testsuite/ada/acats/tests/c7/c760010.a +++ /dev/null @@ -1,418 +0,0 @@ --- C760010.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 explicit calls to Initialize, Adjust and Finalize --- procedures that raise exceptions propagate the exception raised, --- not Program_Error. Check this for both a user defined exception --- and a language defined exception. Check that implicit calls to --- initialize procedures that raise an exception propagate the --- exception raised, not Program_Error; --- --- Check that the utilization of a controlled type as the actual for --- a generic formal tagged private parameter supports the correct --- behavior in the instantiated software. --- --- TEST DESCRIPTION: --- Declares a generic package instantiated to check that controlled --- types are not impacted by the "generic boundary." --- This instance is then used to perform the tests of various calls to --- the procedures. After each operation in the main program that should --- cause implicit calls where an exception is raised, the program handles --- Program_Error. After each explicit call, the program handles the --- Expected_Error. Handlers for the opposite exception are provided to --- catch the obvious failure modes. The predefined exception --- Tasking_Error is used to be certain that some other reason has not --- raised a predefined exception. --- --- --- DATA STRUCTURES --- --- C760010_1.Simple_Control is derived from --- Ada.Finalization.Controlled --- --- C760010_2.Embedded_Derived is derived from C760010_1.Simple_Control --- by way of generic instantiation --- --- --- CHANGE HISTORY: --- 01 MAY 95 SAIC Initial version --- 23 APR 96 SAIC Fix visibility problem for 2.1 --- 14 NOV 96 SAIC Revisit for 2.1 release --- 26 JUN 98 EDS Added pragma Elaborate_Body to --- package C760010_0.Check_Formal_Tagged --- to avoid possible instantiation error ---! - ----------------------------------------------------------------- C760010_0 - -package C760010_0 is - - User_Defined_Exception : exception; - - type Actions is ( No_Action, - Init_Raise_User_Defined, Init_Raise_Standard, - Adj_Raise_User_Defined, Adj_Raise_Standard, - Fin_Raise_User_Defined, Fin_Raise_Standard ); - - Action : Actions := No_Action; - - function Unique return Natural; - -end C760010_0; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -package body C760010_0 is - - Value : Natural := 101; - - function Unique return Natural is - begin - Value := Value +1; - return Value; - end Unique; - -end C760010_0; - ----------------------------------------------------------------- C760010_0 ------------------------------------------------------- Check_Formal_Tagged - -generic - - type Formal_Tagged is tagged private; - -package C760010_0.Check_Formal_Tagged is - - pragma Elaborate_Body; - - type Embedded_Derived is new Formal_Tagged with record - TC_Meaningless_Value : Natural := Unique; - end record; - - procedure Initialize( ED: in out Embedded_Derived ); - procedure Adjust ( ED: in out Embedded_Derived ); - procedure Finalize ( ED: in out Embedded_Derived ); - -end C760010_0.Check_Formal_Tagged; - - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with Report; -package body C760010_0.Check_Formal_Tagged is - - - procedure Initialize( ED: in out Embedded_Derived ) is - begin - ED.TC_Meaningless_Value := Unique; - case Action is - when Init_Raise_User_Defined => raise User_Defined_Exception; - when Init_Raise_Standard => raise Tasking_Error; - when others => null; - end case; - end Initialize; - - procedure Adjust ( ED: in out Embedded_Derived ) is - begin - ED.TC_Meaningless_Value := Unique; - case Action is - when Adj_Raise_User_Defined => raise User_Defined_Exception; - when Adj_Raise_Standard => raise Tasking_Error; - when others => null; - end case; - end Adjust; - - procedure Finalize ( ED: in out Embedded_Derived ) is - begin - ED.TC_Meaningless_Value := Unique; - case Action is - when Fin_Raise_User_Defined => raise User_Defined_Exception; - when Fin_Raise_Standard => raise Tasking_Error; - when others => null; - end case; - end Finalize; - -end C760010_0.Check_Formal_Tagged; - ----------------------------------------------------------------- C760010_1 - -with Ada.Finalization; -package C760010_1 is - - procedure Check_Counters(Init,Adj,Fin : Natural; Message: String); - procedure Reset_Counters; - - type Simple_Control is new Ada.Finalization.Controlled with record - Item: Integer; - end record; - procedure Initialize( AV: in out Simple_Control ); - procedure Adjust ( AV: in out Simple_Control ); - procedure Finalize ( AV: in out Simple_Control ); - -end C760010_1; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with Report; -package body C760010_1 is - - Initialize_Called : Natural; - Adjust_Called : Natural; - Finalize_Called : Natural; - - procedure Check_Counters(Init,Adj,Fin : Natural; Message: String) is - begin - if Init /= Initialize_Called then - Report.Failed("Initialize mismatch " & Message); - end if; - if Adj /= Adjust_Called then - Report.Failed("Adjust mismatch " & Message); - end if; - if Fin /= Finalize_Called then - Report.Failed("Finalize mismatch " & Message); - end if; - end Check_Counters; - - procedure Reset_Counters is - begin - Initialize_Called := 0; - Adjust_Called := 0; - Finalize_Called := 0; - end Reset_Counters; - - procedure Initialize( AV: in out Simple_Control ) is - begin - Initialize_Called := Initialize_Called +1; - AV.Item := 0; - end Initialize; - - procedure Adjust ( AV: in out Simple_Control ) is - begin - Adjust_Called := Adjust_Called +1; - AV.Item := AV.Item +1; - end Adjust; - - procedure Finalize ( AV: in out Simple_Control ) is - begin - Finalize_Called := Finalize_Called +1; - AV.Item := AV.Item +1; - end Finalize; - -end C760010_1; - ----------------------------------------------------------------- C760010_2 - -with C760010_0.Check_Formal_Tagged; -with C760010_1; -package C760010_2 is - new C760010_0.Check_Formal_Tagged(C760010_1.Simple_Control); - ---------------------------------------------------------------------------- - -with Report; -with C760010_0; -with C760010_1; -with C760010_2; -procedure C760010 is - - use type C760010_0.Actions; - - procedure Case_Failure(Message: String) is - begin - Report.Failed(Message & " for case " - & C760010_0.Actions'Image(C760010_0.Action) ); - end Case_Failure; - - procedure Check_Implicit_Initialize is - Item : C760010_2.Embedded_Derived; -- exception here propagates to - Gadget : C760010_2.Embedded_Derived; -- caller - begin - if C760010_0.Action - in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard - then - Case_Failure("Anticipated exception at implicit init"); - end if; - begin - Item := Gadget; -- exception here handled locally - if C760010_0.Action in C760010_0.Adj_Raise_User_Defined - .. C760010_0.Fin_Raise_Standard then - Case_Failure ("Anticipated exception at assignment"); - end if; - exception - when Program_Error => - if C760010_0.Action not in C760010_0.Adj_Raise_User_Defined - .. C760010_0.Fin_Raise_Standard then - Report.Failed("Program_Error in Check_Implicit_Initialize"); - end if; - when Tasking_Error => - Report.Failed("Tasking_Error in Check_Implicit_Initialize"); - when C760010_0.User_Defined_Exception => - Report.Failed("User_Error in Check_Implicit_Initialize"); - when others => - Report.Failed("Wrong exception Check_Implicit_Initialize"); - end; - end Check_Implicit_Initialize; - ---------------------------------------------------------------------------- - - Global_Item : C760010_2.Embedded_Derived; - ---------------------------------------------------------------------------- - - procedure Check_Explicit_Initialize is - begin - begin - C760010_2.Initialize( Global_Item ); - if C760010_0.Action - in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard - then - Case_Failure("Anticipated exception at explicit init"); - end if; - exception - when Program_Error => - Report.Failed("Program_Error in Check_Explicit_Initialize"); - when Tasking_Error => - if C760010_0.Action /= C760010_0.Init_Raise_Standard then - Report.Failed("Tasking_Error in Check_Explicit_Initialize"); - end if; - when C760010_0.User_Defined_Exception => - if C760010_0.Action /= C760010_0.Init_Raise_User_Defined then - Report.Failed("User_Error in Check_Explicit_Initialize"); - end if; - when others => - Report.Failed("Wrong exception in Check_Explicit_Initialize"); - end; - end Check_Explicit_Initialize; - ---------------------------------------------------------------------------- - - procedure Check_Explicit_Adjust is - begin - begin - C760010_2.Adjust( Global_Item ); - if C760010_0.Action - in C760010_0.Adj_Raise_User_Defined..C760010_0.Adj_Raise_Standard - then - Case_Failure("Anticipated exception at explicit Adjust"); - end if; - exception - when Program_Error => - Report.Failed("Program_Error in Check_Explicit_Adjust"); - when Tasking_Error => - if C760010_0.Action /= C760010_0.Adj_Raise_Standard then - Report.Failed("Tasking_Error in Check_Explicit_Adjust"); - end if; - when C760010_0.User_Defined_Exception => - if C760010_0.Action /= C760010_0.Adj_Raise_User_Defined then - Report.Failed("User_Error in Check_Explicit_Adjust"); - end if; - when others => - Report.Failed("Wrong exception in Check_Explicit_Adjust"); - end; - end Check_Explicit_Adjust; - ---------------------------------------------------------------------------- - - procedure Check_Explicit_Finalize is - begin - begin - C760010_2.Finalize( Global_Item ); - if C760010_0.Action - in C760010_0.Fin_Raise_User_Defined..C760010_0.Fin_Raise_Standard - then - Case_Failure("Anticipated exception at explicit Finalize"); - end if; - exception - when Program_Error => - Report.Failed("Program_Error in Check_Explicit_Finalize"); - when Tasking_Error => - if C760010_0.Action /= C760010_0.Fin_Raise_Standard then - Report.Failed("Tasking_Error in Check_Explicit_Finalize"); - end if; - when C760010_0.User_Defined_Exception => - if C760010_0.Action /= C760010_0.Fin_Raise_User_Defined then - Report.Failed("User_Error in Check_Explicit_Finalize"); - end if; - when others => - Report.Failed("Wrong exception in Check_Explicit_Finalize"); - end; - end Check_Explicit_Finalize; - ---------------------------------------------------------------------------- - -begin -- Main test procedure. - - Report.Test ("C760010", "Check that explicit calls to finalization " & - "procedures that raise exceptions propagate " & - "the exception raised. Check the utilization " & - "of a controlled type as the actual for a " & - "generic formal tagged private parameter" ); - - for Act in C760010_0.Actions loop - C760010_1.Reset_Counters; - C760010_0.Action := Act; - - begin - Check_Implicit_Initialize; - if Act in - C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard then - Case_Failure("No exception at Check_Implicit_Initialize"); - end if; - exception - when Tasking_Error => - if Act /= C760010_0.Init_Raise_Standard then - Case_Failure("Tasking_Error at Check_Implicit_Initialize"); - end if; - when C760010_0.User_Defined_Exception => - if Act /= C760010_0.Init_Raise_User_Defined then - Case_Failure("User_Error at Check_Implicit_Initialize"); - end if; - when Program_Error => - -- If finalize raises an exception, all other object are finalized - -- first and Program_Error is raised upon leaving the master scope. - -- 7.6.1:14 - if Act not in C760010_0.Fin_Raise_User_Defined.. - C760010_0.Fin_Raise_Standard then - Case_Failure("Program_Error at Check_Implicit_Initialize"); - end if; - when others => - Case_Failure("Wrong exception at Check_Implicit_Initialize"); - end; - - Check_Explicit_Initialize; - Check_Explicit_Adjust; - Check_Explicit_Finalize; - - C760010_1.Check_Counters(0,0,0, C760010_0.Actions'Image(Act)); - - end loop; - - -- Set to No_Action to avoid exception in finalizing Global_Item - C760010_0.Action := C760010_0.No_Action; - - Report.Result; - -end C760010; |