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 <kirtc...@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.
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.
