diff mbox

[Ada] Missing finalization of class-wide object

Message ID 20120222140701.GA15323@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Feb. 22, 2012, 2:07 p.m. UTC 
This patch allows the finalization machinery to recognize a case where a source
object initialized by a controlled function call has been transformed into a
class-wide renaming of routine Ada.Tags.Displace. This case arises when the
return type of the function and the result requires dispatch table pointer
manipulation.

------------
-- Source --
------------

--  types.ads

with Ada.Finalization; use Ada.Finalization;

package Types is
   type Iface is interface;
   function Get (Name : String) return Iface'Class;

   type Ctrl_Typ is new Controlled and Iface with record
      Data : Integer;
   end record;
   procedure Finalize (Obj : in out Ctrl_Typ);
end Types;

--  types.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Types is
   function Get (Name : String) return Iface'Class is
      Obj : Ctrl_Typ;
   begin
      Obj.Data := Name'Length;
      return Obj;
   end Get;

   procedure Finalize (Obj : in out Ctrl_Typ) is
   begin
      Put_Line ("  Finalize");
   end Finalize;
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 : Iface'Class := Get ("Hello");
      --  Finalize temp in Get
      --  Finalize temp result of Get
   begin
      Put_Line ("Hello");
      --  Finalize Obj
   end;
   Put_Line ("End");
end Main;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q -gnat05 main.adb
$ ./main
$ Main
$   Finalize
$   Finalize
$ Hello
$   Finalize
$ End

Tested on x86_64-pc-linux-gnu, committed on trunk

2012-02-22  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Process_Declarations): Minor reformatting. Simplify the
	entry point for renamings. Detect a case where a source object has
	been transformed into a class-wide renaming of a call to
	Ada.Tags.Displace.
	* exp_util.adb (Is_Displacement_Of_Ctrl_Function_Result): New routine.
	(Is_Finalizable_Transient): Minor reformatting.
	(Is_Tag_To_Class_Wide_Conversion): Minor reformatting.
	(Requires_Cleanup_Actions): Minor reformatting. Simplify the
	entry point for renamings. Detect a case where a source object
	has been transformed into a class-wide renaming of a call to
	Ada.Tags.Displace.
	* exp_util.ads (Is_Displacement_Of_Ctrl_Function_Result): New routine.
	(Is_Tag_To_Class_Wide_Conversion): Minor reformatting.
diff mbox

Patch

Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb	(revision 184477)
+++ exp_ch7.adb	(working copy)
@@ -1816,7 +1816,7 @@ 
                  and then Needs_Finalization (Obj_Typ)
                  and then not (Ekind (Obj_Id) = E_Constant
                                 and then not Has_Completion (Obj_Id))
-                 and then not Is_Tag_To_CW_Conversion (Obj_Id)
+                 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
                then
                   Processing_Actions;
 
@@ -1894,10 +1894,7 @@ 
 
             --  Specific cases of object renamings
 
-            elsif Nkind (Decl) = N_Object_Renaming_Declaration
-              and then Nkind (Name (Decl)) = N_Explicit_Dereference
-              and then Nkind (Prefix (Name (Decl))) = N_Identifier
-            then
+            elsif Nkind (Decl) = N_Object_Renaming_Declaration then
                Obj_Id  := Defining_Identifier (Decl);
                Obj_Typ := Base_Type (Etype (Obj_Id));
 
@@ -1919,6 +1916,19 @@ 
                  and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
                then
                   Processing_Actions (Has_No_Init => True);
+
+               --  Detect a case where a source object has been initialized by
+               --  a controlled function call which was later rewritten as a
+               --  class-wide conversion of Ada.Tags.Displace.
+
+               --     Obj : Class_Wide_Type := Function_Call (...);
+
+               --     Temp : ... := Function_Call (...)'reference;
+               --     Obj  : Class_Wide_Type renames
+               --              (... Ada.Tags.Displace (Temp));
+
+               elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then
+                  Processing_Actions (Has_No_Init => True);
                end if;
 
             --  Inspect the freeze node of an access-to-controlled type and
Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 184470)
+++ exp_util.adb	(working copy)
@@ -3940,6 +3940,92 @@ 
       return True;
    end Is_All_Null_Statements;
 
+   ---------------------------------------------
+   -- Is_Displacement_Of_Ctrl_Function_Result --
+   ---------------------------------------------
+
+   function Is_Displacement_Of_Ctrl_Function_Result
+     (Obj_Id : Entity_Id) return Boolean
+   is
+      function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean;
+      --  Determine whether object declaration N is initialized by a controlled
+      --  function call.
+
+      function Is_Displace_Call (N : Node_Id) return Boolean;
+      --  Determine whether a particular node is a call to Ada.Tags.Displace.
+      --  The call might be nested within other actions such as conversions.
+
+      ----------------------------------
+      -- Initialized_By_Ctrl_Function --
+      ----------------------------------
+
+      function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean is
+         Expr : constant Node_Id := Original_Node (Expression (N));
+
+      begin
+         return
+            Nkind (Expr) = N_Function_Call
+              and then Needs_Finalization (Etype (Expr));
+      end Initialized_By_Ctrl_Function;
+
+      ----------------------
+      -- Is_Displace_Call --
+      ----------------------
+
+      function Is_Displace_Call (N : Node_Id) return Boolean is
+         Call : Node_Id := N;
+
+      begin
+         --  Strip various actions which may precede a call to Displace
+
+         loop
+            if Nkind (Call) = N_Explicit_Dereference then
+               Call := Prefix (Call);
+
+            elsif Nkind_In (Call, N_Type_Conversion,
+                                  N_Unchecked_Type_Conversion)
+            then
+               Call := Expression (Call);
+            else
+               exit;
+            end if;
+         end loop;
+
+         return
+           Nkind (Call) = N_Function_Call
+             and then Is_RTE (Entity (Name (Call)), RE_Displace);
+      end Is_Displace_Call;
+
+      --  Local variables
+
+      Decl      : constant Node_Id   := Parent (Obj_Id);
+      Obj_Typ   : constant Entity_Id := Base_Type (Etype (Obj_Id));
+      Orig_Decl : constant Node_Id   := Original_Node (Decl);
+
+   --  Start of processing for Is_Displacement_Of_Ctrl_Function_Result
+
+   begin
+      --  Detect the following case:
+
+      --     Obj : Class_Wide_Type := Function_Call (...);
+
+      --  which is rewritten into:
+
+      --     Temp : ... := Function_Call (...)'reference;
+      --     Obj  : Class_Wide_Type renames (... Ada.Tags.Displace (Temp));
+
+      --  when the return type of the function and the class-wide type require
+      --  dispatch table pointer displacement.
+
+      return
+        Nkind (Decl) = N_Object_Renaming_Declaration
+          and then Nkind (Orig_Decl) = N_Object_Declaration
+          and then Comes_From_Source (Orig_Decl)
+          and then Initialized_By_Ctrl_Function (Orig_Decl)
+          and then Is_Class_Wide_Type (Obj_Typ)
+          and then Is_Displace_Call (Renamed_Object (Obj_Id));
+   end Is_Displacement_Of_Ctrl_Function_Result;
+
    ------------------------------
    -- Is_Finalizable_Transient --
    ------------------------------
@@ -4321,7 +4407,7 @@ 
 
           --  Do not consider conversions of tags to class-wide types
 
-          and then not Is_Tag_To_CW_Conversion (Obj_Id)
+          and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
 
           --  Do not consider containers in the context of iterator loops. Such
           --  transient objects must exist for as long as the loop is around,
@@ -4851,11 +4937,13 @@ 
       end if;
    end Is_Renamed_Object;
 
-   -----------------------------
-   -- Is_Tag_To_CW_Conversion --
-   -----------------------------
+   -------------------------------------
+   -- Is_Tag_To_Class_Wide_Conversion --
+   -------------------------------------
 
-   function Is_Tag_To_CW_Conversion (Obj_Id : Entity_Id) return Boolean is
+   function Is_Tag_To_Class_Wide_Conversion
+     (Obj_Id : Entity_Id) return Boolean
+   is
       Expr : constant Node_Id := Expression (Parent (Obj_Id));
 
    begin
@@ -4864,7 +4952,7 @@ 
           and then Present (Expr)
           and then Nkind (Expr) = N_Unchecked_Type_Conversion
           and then Etype (Expression (Expr)) = RTE (RE_Tag);
-   end Is_Tag_To_CW_Conversion;
+   end Is_Tag_To_Class_Wide_Conversion;
 
    ----------------------------
    -- Is_Untagged_Derivation --
@@ -7015,7 +7103,7 @@ 
               and then Needs_Finalization (Obj_Typ)
               and then not (Ekind (Obj_Id) = E_Constant
                               and then not Has_Completion (Obj_Id))
-              and then not Is_Tag_To_CW_Conversion (Obj_Id)
+              and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
             then
                return True;
 
@@ -7064,10 +7152,7 @@ 
 
          --  Specific cases of object renamings
 
-         elsif Nkind (Decl) = N_Object_Renaming_Declaration
-           and then Nkind (Name (Decl)) = N_Explicit_Dereference
-           and then Nkind (Prefix (Name (Decl))) = N_Identifier
-         then
+         elsif Nkind (Decl) = N_Object_Renaming_Declaration then
             Obj_Id  := Defining_Identifier (Decl);
             Obj_Typ := Base_Type (Etype (Obj_Id));
 
@@ -7089,6 +7174,19 @@ 
               and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
             then
                return True;
+
+            --  Detect a case where a source object has been initialized by a
+            --  controlled function call which was later rewritten as a class-
+            --  wide conversion of Ada.Tags.Displace.
+
+            --     Obj : Class_Wide_Type := Function_Call (...);
+
+            --     Temp : ... := Function_Call (...)'reference;
+            --     Obj  : Class_Wide_Type renames
+            --              (... Ada.Tags.Displace (Temp));
+
+            elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then
+               return True;
             end if;
 
          --  Inspect the freeze node of an access-to-controlled type and look
Index: exp_util.ads
===================================================================
--- exp_util.ads	(revision 184470)
+++ exp_util.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -521,6 +521,12 @@ 
    --  False otherwise. True for an empty list. It is an error to call this
    --  routine with No_List as the argument.
 
+   function Is_Displacement_Of_Ctrl_Function_Result
+     (Obj_Id : Entity_Id) return Boolean;
+   --  Determine whether Obj_Id is a source object that has been initialized by
+   --  a controlled function call later rewritten as a class-wide conversion of
+   --  Ada.Tags.Displace.
+
    function Is_Finalizable_Transient
      (Decl     : Node_Id;
       Rel_Node : Node_Id) return Boolean;
@@ -587,7 +593,8 @@ 
    --  We consider that a (1 .. 2) is a renamed object since it is the prefix
    --  of the name in the renaming declaration.
 
-   function Is_Tag_To_CW_Conversion (Obj_Id : Entity_Id) return Boolean;
+   function Is_Tag_To_Class_Wide_Conversion
+     (Obj_Id : Entity_Id) return Boolean;
    --  Determine whether object Obj_Id is the result of a tag-to-class-wide
    --  type conversion.