Patchwork [Ada] Interplay between exception handlers and finalization

login
register
mail settings
Submitter Arnaud Charlet
Date June 12, 2012, 12:02 p.m.
Message ID <20120612120209.GA6113@adacore.com>
Download mbox | patch
Permalink /patch/164416/
State New
Headers show

Comments

Arnaud Charlet - June 12, 2012, 12:02 p.m.
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  <kirtchev@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.

Patch

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