This patch updates the funalization mechanism to correctly recognize a
redefined unary operator which returns an interface class-wide type. Such
objects require finalization actions.
------------
-- Source --
------------
-- types.ads
with Ada.Finalization; use Ada.Finalization;
package Types is
type One is interface;
type Int_Access is access Integer;
type Managed is new Controlled with record
X : Int_Access;
end record;
overriding procedure Adjust (M : in out Managed);
overriding procedure Finalize (M : in out Managed);
function Build (I : Integer) return Managed;
type Two is new One with record
M : Managed := Build (1);
end record;
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Deallocation;
package body Types is
procedure Free is new Ada.Unchecked_Deallocation (Integer, Int_Access);
overriding procedure Adjust (M : in out Managed) is
Old_Val : Integer;
New_Val : Integer;
Val_Ptr : Int_Access renames M.X;
begin
if Val_Ptr = null then
Put_Line ("adj: null");
else
Old_Val := Val_Ptr.all;
New_Val := Old_Val + 1;
Put_Line ("adj:" & Old_Val'Img & " ->" & New_Val'Img);
Val_Ptr := new Integer'(New_Val);
end if;
end Adjust;
function Build (I : Integer) return Managed is
begin
return Managed'(Controlled with X => new Integer'(I));
end Build;
overriding procedure Finalize (M : in out Managed) is
Val_Ptr : Int_Access renames M.X;
begin
if Val_Ptr = null then
Put_Line ("fin: null");
else
Put_Line ("fin:" & Val_Ptr.all'Img);
Free (Val_Ptr);
end if;
end Finalize;
end Types;
-- leak.adb
with Ada.Text_IO; use Ada.Text_IO;
with Types; use Types;
procedure Leak is
function Pass (X : Two'Class) return One'Class is (X);
function "not" (X : Two'Class) return One'Class is (X);
Obj_1 : Two;
begin
Obj_1.M := Build (1);
Put_Line ("start");
for I in 1 .. 3 loop
Put_Line ("spart Pass");
declare
Obj_2 : One'Class := Pass (Obj_1);
begin null; end;
Put_Line ("end Pass");
Put_Line ("start not");
declare
Obj_3 : One'Class := not Obj_1;
begin null; end;
Put_Line ("end not");
end loop;
Put_Line ("end");
end Leak;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q leak.adb -largs -lgmem
$ ./leak
$ gnatmem ./leak > leaks.txt
$ grep -c "Number of non freed allocations" leaks.txt
dj: 1 -> 2
fin: 1
adj: 2 -> 3
fin: 2
adj: 1 -> 2
fin: 1
fin: 3
adj: 2 -> 3
fin: 2
start
spart Pass
adj: 3 -> 4
adj: 4 -> 5
fin: 4
fin: 5
end Pass
start not
adj: 3 -> 4
adj: 4 -> 5
fin: 4
fin: 5
end not
spart Pass
adj: 3 -> 4
adj: 4 -> 5
fin: 4
fin: 5
end Pass
start not
adj: 3 -> 4
adj: 4 -> 5
fin: 4
fin: 5
end not
spart Pass
adj: 3 -> 4
adj: 4 -> 5
fin: 4
fin: 5
end Pass
start not
adj: 3 -> 4
adj: 4 -> 5
fin: 4
fin: 5
end not
end
fin: 3
0
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-01-06 Hristian Kirtchev <[email protected]>
* exp_util.adb (Is_Controlled_Function_Call):
Reimplemented. Consider any node which has an entity as the
function call may appear in various ways.
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 244124)
+++ exp_util.adb (working copy)
@@ -4912,35 +4912,28 @@
-- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
-- N_Selected_Component
- case Nkind (Expr) is
- when N_Function_Call =>
+ loop
+ if Nkind (Expr) = N_Function_Call then
Expr := Name (Expr);
- -- Check for "Obj.Func (Formal => Actual)" case
-
- if Nkind (Expr) = N_Selected_Component then
- Expr := Selector_Name (Expr);
- end if;
-
-- "Obj.Func (Actual)" case
- when N_Indexed_Component =>
+ elsif Nkind (Expr) = N_Indexed_Component then
Expr := Prefix (Expr);
- if Nkind (Expr) = N_Selected_Component then
- Expr := Selector_Name (Expr);
- end if;
+ -- "Obj.Func" or "Obj.Func (Formal => Actual) case
- -- "Obj.Func" case
-
- when N_Selected_Component =>
+ elsif Nkind (Expr) = N_Selected_Component then
Expr := Selector_Name (Expr);
- when others => null;
- end case;
+ else
+ exit;
+ end if;
+ end loop;
return
- Nkind_In (Expr, N_Expanded_Name, N_Identifier)
+ Nkind (Expr) in N_Has_Entity
+ and then Present (Entity (Expr))
and then Ekind (Entity (Expr)) = E_Function
and then Needs_Finalization (Etype (Entity (Expr)));
end Is_Controlled_Function_Call;
