This patch corrects the machinery which detects controlled objects inside a block created for the purposes of avoiding interference of exception handlers and At_End handlers.
------------ -- Source -- ------------ -- types.ads with Ada.Finalization; use Ada.Finalization; package Types is type Ctrl is new Controlled with null record; procedure Finalize (Obj : in out Ctrl); function Make_Ctrl return Ctrl; type Rec is record Data : Ctrl; end record; function Make_Rec return Rec; end Types; -- types.adb: with Ada.Text_IO; use Ada.Text_IO; package body Types is procedure Finalize (Obj : in out Ctrl) is begin Put_Line ("Finalize"); end Finalize; function Make_Ctrl return Ctrl is Result : Ctrl; begin return Result; end Make_Ctrl; function Make_Rec return Rec is begin return Rec'(Data => Make_Ctrl); exception when others => Put_Line ("BOMB"); raise Program_Error; end Make_Rec; end Types; -- main.adb: with Ada.Text_IO; use Ada.Text_IO; with Types; use Types; procedure Main is begin Put_Line ("Main"); declare Obj : Rec := Make_Rec; begin null; end; Put_Line ("End"); end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q main.adb $ ./main $ Main $ Finalize $ Finalize $ Finalize $ Finalize $ Finalize $ End Tested on x86_64-pc-linux-gnu, committed on trunk 2012-06-12 Hristian Kirtchev <kirtc...@adacore.com> * exp_ch7.adb (Process_Declarations): Handle the case where the original context has been wrapped in a block to avoid interference between exception handlers and At_End handlers. (Wrap_HSS_In_Block): Mark the block which contains the original statements of the context as being a finalization wrapper. * sinfo.adb (Is_Finalization_Wrapper): New routine. (Set_Is_Finalization_Wrapper): New routine. * sinfo.ads: Add new attribute Is_Finalization_Wrapper applicable to block statemnts. (Is_Finalization_Wrapper): New routine with corresponding pragma Inline. (Set_Is_Finalization_Wrapper): New routine with corresponding pragma Inline.
Index: exp_ch7.adb =================================================================== --- exp_ch7.adb (revision 188445) +++ exp_ch7.adb (working copy) @@ -2094,6 +2094,22 @@ then Last_Top_Level_Ctrl_Construct := Decl; end if; + + -- Handle the case where the original context has been wrapped in + -- a block to avoid interference between exception handlers and + -- At_End handlers. Treat the block as transparent and process its + -- contents. + + elsif Nkind (Decl) = N_Block_Statement + and then Is_Finalization_Wrapper (Decl) + then + if Present (Handled_Statement_Sequence (Decl)) then + Process_Declarations + (Statements (Handled_Statement_Sequence (Decl)), + Preprocess); + end if; + + Process_Declarations (Declarations (Decl), Preprocess); end if; Prev_Non_Pragma (Decl); @@ -3696,6 +3712,11 @@ Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS); + -- Signal the finalization machinery that this particular block + -- contains the original context. + + Set_Is_Finalization_Wrapper (Block); + Set_Handled_Statement_Sequence (N, Make_Handled_Sequence_Of_Statements (Loc, New_List (Block))); HSS := Handled_Statement_Sequence (N); Index: sinfo.adb =================================================================== --- sinfo.adb (revision 188428) +++ sinfo.adb (working copy) @@ -1806,6 +1806,14 @@ return Flag11 (N); end Is_Expanded_Build_In_Place_Call; + function Is_Finalization_Wrapper + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement); + return Flag9 (N); + end Is_Finalization_Wrapper; + function Is_Folded_In_Parser (N : Node_Id) return Boolean is begin @@ -4902,6 +4910,14 @@ Set_Flag11 (N, Val); end Set_Is_Expanded_Build_In_Place_Call; + procedure Set_Is_Finalization_Wrapper + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement); + Set_Flag9 (N, Val); + end Set_Is_Finalization_Wrapper; + procedure Set_Is_Folded_In_Parser (N : Node_Id; Val : Boolean := True) is begin Index: sinfo.ads =================================================================== --- sinfo.ads (revision 188445) +++ sinfo.ads (working copy) @@ -1310,6 +1310,12 @@ -- actuals to support a build-in-place style of call have been added to -- the call. + -- Is_Finalization_Wrapper (Flag9-Sem); + -- This flag is present in N_Block_Statement nodes. It is set when the + -- block acts as a wrapper of a handled construct which has controlled + -- objects. The wrapper prevents interference between exception handlers + -- and At_End handlers. + -- Is_In_Discriminant_Check (Flag11-Sem) -- This flag is present in a selected component, and is used to indicate -- that the reference occurs within a discriminant check. The @@ -4331,6 +4337,7 @@ -- Is_Task_Allocation_Block (Flag6) -- Is_Asynchronous_Call_Block (Flag7) -- Exception_Junk (Flag8-Sem) + -- Is_Finalization_Wrapper (Flag9-Sem) ------------------------- -- 5.7 Exit Statement -- @@ -8670,6 +8677,9 @@ function Is_Expanded_Build_In_Place_Call (N : Node_Id) return Boolean; -- Flag11 + function Is_Finalization_Wrapper + (N : Node_Id) return Boolean; -- Flag9 + function Is_Folded_In_Parser (N : Node_Id) return Boolean; -- Flag4 @@ -9657,6 +9667,9 @@ procedure Set_Is_Expanded_Build_In_Place_Call (N : Node_Id; Val : Boolean := True); -- Flag11 + procedure Set_Is_Finalization_Wrapper + (N : Node_Id; Val : Boolean := True); -- Flag9 + procedure Set_Is_Folded_In_Parser (N : Node_Id; Val : Boolean := True); -- Flag4 @@ -12014,6 +12027,7 @@ pragma Inline (Is_Elsif); pragma Inline (Is_Entry_Barrier_Function); pragma Inline (Is_Expanded_Build_In_Place_Call); + pragma Inline (Is_Finalization_Wrapper); pragma Inline (Is_Folded_In_Parser); pragma Inline (Is_In_Discriminant_Check); pragma Inline (Is_Machine_Number); @@ -12338,6 +12352,7 @@ pragma Inline (Set_Is_Elsif); pragma Inline (Set_Is_Entry_Barrier_Function); pragma Inline (Set_Is_Expanded_Build_In_Place_Call); + pragma Inline (Set_Is_Finalization_Wrapper); pragma Inline (Set_Is_Folded_In_Parser); pragma Inline (Set_Is_In_Discriminant_Check); pragma Inline (Set_Is_Machine_Number);