@@ -40,6 +40,8 @@ with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations;
pragma Elaborate_All
(Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations);
+with Ada.Unchecked_Deallocation;
+
with System; use type System.Address;
with System.Put_Images;
@@ -775,6 +777,18 @@ is
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Control : in out Reference_Control_Type) is
+ begin
+ Impl.Reference_Control_Type (Control).Adjust;
+ if Control.Old_Key /= null then
+ Control.Old_Key := new Key_Type'(Control.Old_Key.all);
+ end if;
+ end Adjust;
+
-------------
-- Ceiling --
-------------
@@ -872,6 +886,8 @@ is
--------------
procedure Finalize (Control : in out Reference_Control_Type) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
begin
if Control.Container /= null then
Impl.Reference_Control_Type (Control).Finalize;
@@ -883,6 +899,7 @@ is
end if;
Control.Container := null;
+ Deallocate (Control.Old_Key);
end if;
end Finalize;
@@ -324,6 +324,9 @@ is
Old_Key : Key_Access;
end record;
+ overriding procedure Adjust (Control : in out Reference_Control_Type);
+ pragma Inline (Adjust);
+
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
@@ -807,6 +807,18 @@ is
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Control : in out Reference_Control_Type) is
+ begin
+ Impl.Reference_Control_Type (Control).Adjust;
+ if Control.Old_Key /= null then
+ Control.Old_Key := new Key_Type'(Control.Old_Key.all);
+ end if;
+ end Adjust;
+
-------------
-- Ceiling --
-------------
@@ -906,6 +918,8 @@ is
--------------
procedure Finalize (Control : in out Reference_Control_Type) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
begin
if Control.Container /= null then
Impl.Reference_Control_Type (Control).Finalize;
@@ -917,7 +931,7 @@ is
end if;
Control.Container := null;
- Control.Old_Key := null;
+ Deallocate (Control.Old_Key);
end if;
end Finalize;
@@ -338,6 +338,9 @@ is
Old_Key : Key_Access;
end record;
+ overriding procedure Adjust (Control : in out Reference_Control_Type);
+ pragma Inline (Adjust);
+
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
@@ -729,6 +729,18 @@ is
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Control : in out Reference_Control_Type) is
+ begin
+ Impl.Reference_Control_Type (Control).Adjust;
+ if Control.Old_Key /= null then
+ Control.Old_Key := new Key_Type'(Control.Old_Key.all);
+ end if;
+ end Adjust;
+
-------------
-- Ceiling --
-------------
@@ -825,6 +837,8 @@ is
--------------
procedure Finalize (Control : in out Reference_Control_Type) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
begin
if Control.Container /= null then
Impl.Reference_Control_Type (Control).Finalize;
@@ -836,7 +850,7 @@ is
end if;
Control.Container := null;
- Control.Old_Key := null;
+ Deallocate (Control.Old_Key);
end if;
end Finalize;
@@ -323,6 +323,9 @@ is
Old_Key : Key_Access;
end record;
+ overriding procedure Adjust (Control : in out Reference_Control_Type);
+ pragma Inline (Adjust);
+
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
@@ -22220,7 +22220,11 @@ package body Sem_Util is
elsif Is_Record_Type (Input_Typ) then
Comp := First_Component (Input_Typ);
while Present (Comp) loop
- if Needs_Finalization (Etype (Comp)) then
+ -- Skip _Parent component like Expand_Freeze_Record_Type
+
+ if Chars (Comp) /= Name_uParent
+ and then Needs_Finalization (Etype (Comp))
+ then
return True;
end if;
From: Steve Baird <baird@adacore.com> Fix memory leaks in containers' Reference_Preserving_Key functions Make the same change in each of 3 Ada.Containers child units: Ordered_Sets, Indefinite_Ordered_Sets, and Bounded_Ordered_Sets. The function Reference_Preserving_Key evaluates an allocator of type Key_Access whose storage was not being reclaimed. Update the Finalize procedure for type Reference_Control_Type to free that storage. But this change introduces a possible erroneous double-free situation if an object is copied (because the original and the copy will each be finalized at some point). So also introduce an Adjust procedure which allocates a copy of the allocated object. Another possible solution to this problem (which is not being implemented yet) is based on implementing AI22-0082. Also include a fix for a bug in Sem_Util.Has_Some_Controlled_Component that was discovered while working on this. gcc/ada/ * sem_util.adb (Has_Some_Controlled_Component): Fix a bug which causes (in some cases involving a Disable_Controlled aspect specification) Needs_Finalization to return different answers for one type depending on whether the function is called before or after the type is frozen. * libgnat/a-coorse.ads: Type Control_Reference_Type gets an Adjust procedure. * libgnat/a-cborse.ads: Likewise. * libgnat/a-ciorse.ads: Likewise * libgnat/a-coorse.adb: (Finalize): Reclaim allocated Key_Type object. (Adjust): New procedure; prevent sharing of non-null Key_Access values by allocating a copy. * libgnat/a-cborse.adb: Likewise. * libgnat/a-ciorse.adb: Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/a-cborse.adb | 17 +++++++++++++++++ gcc/ada/libgnat/a-cborse.ads | 3 +++ gcc/ada/libgnat/a-ciorse.adb | 16 +++++++++++++++- gcc/ada/libgnat/a-ciorse.ads | 3 +++ gcc/ada/libgnat/a-coorse.adb | 16 +++++++++++++++- gcc/ada/libgnat/a-coorse.ads | 3 +++ gcc/ada/sem_util.adb | 6 +++++- 7 files changed, 61 insertions(+), 3 deletions(-)