ada: Fix containers' Reference_Preserving_Key functions' memory leaks

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.

diff --git a/gcc/ada/libgnat/a-cborse.adb b/gcc/ada/libgnat/a-cborse.adb
index b649c5eb6e7993202bcbd8c7d5ebd89b5a52aa84..9d2a02163426d4ff55518b6979f1550b00f7c867 100644 (file)
--- a/gcc/ada/libgnat/a-cborse.adb
+++ b/gcc/ada/libgnat/a-cborse.adb
@@ -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;
 

diff --git a/gcc/ada/libgnat/a-cborse.ads b/gcc/ada/libgnat/a-cborse.ads
index 2366d1adcc28857cf4700bb9d41aa89c239400a2..650f4a40384b27e3fb150464633cf4c9fc82e4c5 100644 (file)
--- a/gcc/ada/libgnat/a-cborse.ads
+++ b/gcc/ada/libgnat/a-cborse.ads
@@ -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);
 

diff --git a/gcc/ada/libgnat/a-ciorse.adb b/gcc/ada/libgnat/a-ciorse.adb
index d90fb882b4336ed38579ba5cf3dad0c9b53c022d..fe91345cdd4352736f665455cc038cea23afc94b 100644 (file)
--- a/gcc/ada/libgnat/a-ciorse.adb
+++ b/gcc/ada/libgnat/a-ciorse.adb
@@ -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;
 

diff --git a/gcc/ada/libgnat/a-ciorse.ads b/gcc/ada/libgnat/a-ciorse.ads
index a8a87cdab3ee08443167da81bc30560a8b89d4b4..5bc9800b5d14116aeb3d8684b223ff31a5290843 100644 (file)
--- a/gcc/ada/libgnat/a-ciorse.ads
+++ b/gcc/ada/libgnat/a-ciorse.ads
@@ -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);
 

diff --git a/gcc/ada/libgnat/a-coorse.adb b/gcc/ada/libgnat/a-coorse.adb
index ca97fa4e6209f7502aaedbedc0fe2049065e7cc3..a324b54fbef1fa55e3debd65d899ac1b3e608869 100644 (file)
--- a/gcc/ada/libgnat/a-coorse.adb
+++ b/gcc/ada/libgnat/a-coorse.adb
@@ -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;
 

diff --git a/gcc/ada/libgnat/a-coorse.ads b/gcc/ada/libgnat/a-coorse.ads
index 14708752a8316ab7b82df3e5e6bc3390c12fd075..ab83e1abe43b60d151bfa507f263108d17cd8520 100644 (file)
--- a/gcc/ada/libgnat/a-coorse.ads
+++ b/gcc/ada/libgnat/a-coorse.ads
@@ -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);
 

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 01fed4022560b5c7a45bfb517f5449e20b758867..dd9f868b696f6bd29c2b9b1fa43d3a760e81b40b 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -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;