===================================================================
@@ -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;
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 <kirtchev@adacore.com> * exp_util.adb (Is_Controlled_Function_Call): Reimplemented. Consider any node which has an entity as the function call may appear in various ways.