This patch corrects the expansion of Unchecked_Deallocation calls to operate
with the available view of the designated type. This ensures that if the type
is visible through a limited with clause, the expansion properly detects the
case where the designated type requires finalization actions.
------------
-- Source --
------------
-- lib.ads
package Lib with Pure is
end Lib;
-- lib-holder.ads
limited private with Lib.Holder.Impl;
package Lib.Holder is
type Holder is private;
function Create return Holder;
procedure Destroy (H : in out Holder);
private
type Holder is access all Lib.Holder.Impl.Holder_Type;
end Lib.Holder;
-- lib-holder.adb
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Unchecked_Deallocation;
with Lib.Holder.Impl; use Lib.Holder.Impl;
package body Lib.Holder is
procedure Free is new Ada.Unchecked_Deallocation (Holder_Type, Holder);
function Create return Holder is
begin
return new Holder_Type'(S => To_Unbounded_String ("Hello world"));
end Create;
procedure Destroy (H : in out Holder) is
begin
Free (H);
end Destroy;
end Lib.Holder;
-- lib-holder-impl.ads
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
package Lib.Holder.Impl is
type Holder_Type is record
S : Unbounded_String;
end record;
end Lib.Holder.Impl;
-- main.adb
with Lib.Holder; use Lib.Holder;
procedure Main is
H : Holder := Create;
begin
Destroy (H);
end Main;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q main.adb -largs -lgmem
$ ./main
$ gnatmem main >& main.leaks
$ grep -c "non freed allocations" main.leaks
0
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-11-08 Hristian Kirtchev <kirtc...@adacore.com>
* exp_ch4.adb (Apply_Accessibility_Check): Do not finalize the object
when the associated access type is subject to pragma
No_Heap_Finalization.
* exp_intr.adb (Expand_Unc_Deallocation): Use the available view of the
designated type in case it comes from a limited withed unit.
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 254523)
+++ exp_ch4.adb (working copy)
@@ -630,7 +630,9 @@
-- [Deep_]Finalize (Obj_Ref.all);
- if Needs_Finalization (DesigT) then
+ if Needs_Finalization (DesigT)
+ and then not No_Heap_Finalization (PtrT)
+ then
Fin_Call :=
Make_Final_Call
(Obj_Ref =>
Index: exp_intr.adb
===================================================================
--- exp_intr.adb (revision 254523)
+++ exp_intr.adb (working copy)
@@ -924,7 +924,8 @@
Arg : constant Node_Id := First_Actual (N);
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (Arg);
- Desig_Typ : constant Entity_Id := Designated_Type (Typ);
+ Desig_Typ : constant Entity_Id :=
+ Available_View (Designated_Type (Typ));
Needs_Fin : constant Boolean := Needs_Finalization (Desig_Typ);
Root_Typ : constant Entity_Id := Underlying_Type (Root_Type (Typ));
Pool : constant Entity_Id := Associated_Storage_Pool (Root_Typ);
