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