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