This patch modifies the finalization mechanism to recognize a heavily expanded
generalized indexing where the element type requires finalization actions.
------------
-- Source --
------------
-- types.ads
with Ada.Finalization; use Ada.Finalization;
package Types is
type Element is new Controlled with record
Id : Natural := 0;
end record;
procedure Adjust (Obj : in out Element);
procedure Finalize (Obj : in out Element);
procedure Initialize (Obj : In out Element);
subtype Index is Integer range 1 .. 3;
type Collection is array (Index) of Element;
type Vector is new Controlled with record
Id : Natural := 0;
Elements : Collection;
end record
with Constant_Indexing => Element_At;
procedure Adjust (Obj : in out Vector);
procedure Finalize (Obj : in out Vector);
procedure Initialize (Obj : In out Vector);
function Element_At
(Obj : Vector;
Pos : Index) return Element'Class;
function Make_Vector return Vector'Class;
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
Id_Gen : Natural := 10;
procedure Adjust (Obj : in out Element) is
Old_Id : constant Natural := Obj.Id;
New_Id : constant Natural := Old_Id + 1;
begin
if Old_Id = 0 then
Put_Line (" Element adj ERROR");
else
Put_Line (" Element adj" & Old_Id'Img & " ->" & New_Id'Img);
Obj.Id := New_Id;
end if;
end Adjust;
procedure Adjust (Obj : in out Vector) is
Old_Id : constant Natural := Obj.Id;
New_Id : constant Natural := Old_Id + 1;
begin
if Old_Id = 0 then
Put_Line (" Vector adj ERROR");
else
Put_Line (" Vector adj" & Old_Id'Img & " ->" & New_Id'Img);
Obj.Id := New_Id;
end if;
end Adjust;
function Element_At
(Obj : Vector;
Pos : Index) return Element'Class
is
begin
return Obj.Elements (Pos);
end Element_At;
procedure Finalize (Obj : in out Element) is
begin
if Obj.Id = 0 then
Put_Line (" Element fin ERROR");
else
Put_Line (" Element fin" & Obj.Id'Img);
Obj.Id := 0;
end if;
end Finalize;
procedure Finalize (Obj : in out Vector) is
begin
if Obj.Id = 0 then
Put_Line (" Vector fin ERROR");
else
Put_Line (" Vector fin" & Obj.Id'Img);
Obj.Id := 0;
end if;
end Finalize;
procedure Initialize (Obj : In out Element) is
begin
Obj.Id := Id_Gen;
Id_Gen := Id_Gen + 10;
Put_Line (" Element ini" & Obj.Id'Img);
end Initialize;
procedure Initialize (Obj : In out Vector) is
begin
Obj.Id := Id_Gen;
Id_Gen := Id_Gen + 10;
Put_Line (" Vector ini" & Obj.Id'Img);
end Initialize;
function Make_Vector return Vector'Class is
Result : Vector;
begin
return Result;
end Make_Vector;
end Types;
-- main.adb
with Ada.Text_IO; use Ada.Text_IO;
with Types; use Types;
procedure Main is
begin
Put_Line ("Main");
declare
Vec : Vector'Class := Make_Vector;
Elem : Element'Class := Vec (1);
begin
Put_Line ("Main middle");
end;
Put_Line ("Main end");
end Main;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q main.adb
$ ./main.adb
Main
Element ini 10
Element ini 20
Element ini 30
Vector ini 40
Element adj 10 -> 11
Element adj 20 -> 21
Element adj 30 -> 31
Vector adj 40 -> 41
Vector fin 40
Element fin 30
Element fin 20
Element fin 10
Element adj 11 -> 12
Element adj 21 -> 22
Element adj 31 -> 32
Vector adj 41 -> 42
Vector fin 41
Element fin 31
Element fin 21
Element fin 11
Element adj 12 -> 13
Element adj 13 -> 14
Element fin 13
Main middle
Element fin 14
Vector fin 42
Element fin 32
Element fin 22
Element fin 12
Main end
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-06 Hristian Kirtchev <kirtc...@adacore.com>
* exp_util.adb (Is_Controlled_Indexing): New routine.
(Is_Displace_Call): Use routine Strip to remove indirections.
(Is_Displacement_Of_Object_Or_Function_Result): Code clean up. Add a
missing case of controlled generalized indexing.
(Is_Source_Object): Use routine Strip to remove indirections.
(Strip): New routine.
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 251784)
+++ exp_util.adb (working copy)
@@ -7590,22 +7590,28 @@
(Obj_Id : Entity_Id) return Boolean
is
function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
- -- Determine if particular node denotes a controlled function call. The
- -- call may have been heavily expanded.
+ -- Determine whether node N denotes a controlled function call
+ function Is_Controlled_Indexing (N : Node_Id) return Boolean;
+ -- Determine whether node N denotes a generalized indexing form which
+ -- involves a controlled result.
+
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.
+ -- Determine whether node N denotes a call to Ada.Tags.Displace
function Is_Source_Object (N : Node_Id) return Boolean;
-- Determine whether a particular node denotes a source object
+ function Strip (N : Node_Id) return Node_Id;
+ -- Examine arbitrary node N by stripping various indirections and return
+ -- the "real" node.
+
---------------------------------
-- Is_Controlled_Function_Call --
---------------------------------
function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
- Expr : Node_Id := Original_Node (N);
+ Expr : Node_Id;
begin
-- When a function call appears in Object.Operation format, the
@@ -7617,6 +7623,7 @@
-- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
-- N_Selected_Component
+ Expr := Original_Node (N);
loop
if Nkind (Expr) = N_Function_Call then
Expr := Name (Expr);
@@ -7643,31 +7650,28 @@
and then Needs_Finalization (Etype (Entity (Expr)));
end Is_Controlled_Function_Call;
+ ----------------------------
+ -- Is_Controlled_Indexing --
+ ----------------------------
+
+ function Is_Controlled_Indexing (N : Node_Id) return Boolean is
+ Expr : constant Node_Id := Original_Node (N);
+
+ begin
+ return
+ Nkind (Expr) = N_Indexed_Component
+ and then Present (Generalized_Indexing (Expr))
+ and then Needs_Finalization (Etype (Expr));
+ end Is_Controlled_Indexing;
+
----------------------
-- Is_Displace_Call --
----------------------
function Is_Displace_Call (N : Node_Id) return Boolean is
- Call : Node_Id;
+ Call : constant Node_Id := Strip (N);
begin
- -- Strip various actions which may precede a call to Displace
-
- Call := N;
- 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
Present (Call)
and then Nkind (Call) = N_Function_Call
@@ -7679,38 +7683,48 @@
----------------------
function Is_Source_Object (N : Node_Id) return Boolean is
- Obj : Node_Id;
+ Obj : constant Node_Id := Strip (N);
begin
- -- Strip various actions which may be associated with the object
+ return
+ Present (Obj)
+ and then Comes_From_Source (Obj)
+ and then Nkind (Obj) in N_Has_Entity
+ and then Is_Object (Entity (Obj));
+ end Is_Source_Object;
- Obj := N;
+ -----------
+ -- Strip --
+ -----------
+
+ function Strip (N : Node_Id) return Node_Id is
+ Result : Node_Id;
+
+ begin
+ Result := N;
loop
- if Nkind (Obj) = N_Explicit_Dereference then
- Obj := Prefix (Obj);
+ if Nkind (Result) = N_Explicit_Dereference then
+ Result := Prefix (Result);
- elsif Nkind_In (Obj, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ elsif Nkind_In (Result, N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
then
- Obj := Expression (Obj);
+ Result := Expression (Result);
else
exit;
end if;
end loop;
- return
- Present (Obj)
- and then Nkind (Obj) in N_Has_Entity
- and then Is_Object (Entity (Obj))
- and then Comes_From_Source (Obj);
- end Is_Source_Object;
+ return Result;
+ end Strip;
-- Local variables
- Decl : constant Node_Id := Parent (Obj_Id);
+ Obj_Decl : constant Node_Id := Declaration_Node (Obj_Id);
Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
- Orig_Decl : constant Node_Id := Original_Node (Decl);
+ Orig_Decl : constant Node_Id := Original_Node (Obj_Decl);
+ Orig_Expr : Node_Id;
-- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
@@ -7719,34 +7733,52 @@
-- Obj : CW_Type := Function_Call (...);
- -- rewritten into:
+ -- is rewritten into:
- -- Tmp : ... := Function_Call (...)'reference;
- -- Obj : CW_Type renames (... Ada.Tags.Displace (Tmp));
+ -- Temp : ... := Function_Call (...)'reference;
+ -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
-- where the return type of the function and the class-wide type require
-- dispatch table pointer displacement.
-- Case 2:
+ -- Obj : CW_Type := Container (...);
+
+ -- is rewritten into:
+
+ -- Temp : ... := Function_Call (Container, ...)'reference;
+ -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
+
+ -- where the container element type and the class-wide type require
+ -- dispatch table pointer dispacement.
+
+ -- Case 3:
+
-- Obj : CW_Type := Src_Obj;
- -- rewritten into:
+ -- is rewritten into:
-- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
-- where the type of the source object 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 Is_Class_Wide_Type (Obj_Typ)
- and then Is_Displace_Call (Renamed_Object (Obj_Id))
- and then
- (Is_Controlled_Function_Call (Expression (Orig_Decl))
- or else Is_Source_Object (Expression (Orig_Decl)));
+ if Nkind (Obj_Decl) = N_Object_Renaming_Declaration
+ and then Is_Class_Wide_Type (Obj_Typ)
+ and then Is_Displace_Call (Renamed_Object (Obj_Id))
+ and then Nkind (Orig_Decl) = N_Object_Declaration
+ and then Comes_From_Source (Orig_Decl)
+ then
+ Orig_Expr := Expression (Orig_Decl);
+
+ return
+ Is_Controlled_Function_Call (Orig_Expr)
+ or else Is_Controlled_Indexing (Orig_Expr)
+ or else Is_Source_Object (Orig_Expr);
+ end if;
+
+ return False;
end Is_Displacement_Of_Object_Or_Function_Result;
------------------------------
