[Ada] Missing finalization of private protected type

Message ID 20190711080342.GA95108@adacore.com
State New
Headers show
Series
  • [Ada] Missing finalization of private protected type
Related show

Commit Message

Pierre-Marie de Rodat July 11, 2019, 8:03 a.m.
This patch updates the analysis of protected types to properly mark the
type as having controlled components when it contains at least one such
component. This in turn marks a potential partial view as requiring
finalization actions.

------------
-- Source --
------------

--  types.ads

with Ada.Finalization; use Ada.Finalization;

package Types is
   type Ctrl_Typ is new Controlled with null record;
   procedure Finalize (Obj : in out Ctrl_Typ);

   type Prot_Typ is limited private;

private
   protected type Prot_Typ is
   private
      Comp : Ctrl_Typ;
   end Prot_Typ;
end Types;

--  types.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Types is
   procedure Finalize (Obj : in out Ctrl_Typ) is
   begin
      Put_Line ("finalize");
   end Finalize;

   protected body Prot_Typ is
   end Prot_Typ;
end Types;

--  main.adb

with Types; use Types;

procedure Main is
   Obj : Prot_Typ;
begin
   null;
end Main;

Tested on x86_64-pc-linux-gnu, committed on trunk

2019-07-11  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* exp_util.ads, exp_util.adb (Needs_Finalization): Move to
	Sem_Util.
	* sem_ch9.adb (Analyze_Protected_Definition): Code cleanup. Mark
	the protected type as having controlled components when it
	contains at least one such component.
	* sem_util.ads, sem_util.adb (Needs_Finalization): New
	function.

Patch

--- gcc/ada/exp_util.adb
+++ gcc/ada/exp_util.adb
@@ -10554,94 +10554,6 @@  package body Exp_Util is
       end if;
    end Needs_Constant_Address;
 
-   ------------------------
-   -- Needs_Finalization --
-   ------------------------
-
-   function Needs_Finalization (Typ : Entity_Id) return Boolean is
-      function Has_Some_Controlled_Component
-        (Input_Typ : Entity_Id) return Boolean;
-      --  Determine whether type Input_Typ has at least one controlled
-      --  component.
-
-      -----------------------------------
-      -- Has_Some_Controlled_Component --
-      -----------------------------------
-
-      function Has_Some_Controlled_Component
-        (Input_Typ : Entity_Id) return Boolean
-      is
-         Comp : Entity_Id;
-
-      begin
-         --  When a type is already frozen and has at least one controlled
-         --  component, or is manually decorated, it is sufficient to inspect
-         --  flag Has_Controlled_Component.
-
-         if Has_Controlled_Component (Input_Typ) then
-            return True;
-
-         --  Otherwise inspect the internals of the type
-
-         elsif not Is_Frozen (Input_Typ) then
-            if Is_Array_Type (Input_Typ) then
-               return Needs_Finalization (Component_Type (Input_Typ));
-
-            elsif Is_Record_Type (Input_Typ) then
-               Comp := First_Component (Input_Typ);
-               while Present (Comp) loop
-                  if Needs_Finalization (Etype (Comp)) then
-                     return True;
-                  end if;
-
-                  Next_Component (Comp);
-               end loop;
-            end if;
-         end if;
-
-         return False;
-      end Has_Some_Controlled_Component;
-
-   --  Start of processing for Needs_Finalization
-
-   begin
-      --  Certain run-time configurations and targets do not provide support
-      --  for controlled types.
-
-      if Restriction_Active (No_Finalization) then
-         return False;
-
-      --  C++ types are not considered controlled. It is assumed that the non-
-      --  Ada side will handle their clean up.
-
-      elsif Convention (Typ) = Convention_CPP then
-         return False;
-
-      --  Class-wide types are treated as controlled because derivations from
-      --  the root type may introduce controlled components.
-
-      elsif Is_Class_Wide_Type (Typ) then
-         return True;
-
-      --  Concurrent types are controlled as long as their corresponding record
-      --  is controlled.
-
-      elsif Is_Concurrent_Type (Typ)
-        and then Present (Corresponding_Record_Type (Typ))
-        and then Needs_Finalization (Corresponding_Record_Type (Typ))
-      then
-         return True;
-
-      --  Otherwise the type is controlled when it is either derived from type
-      --  [Limited_]Controlled and not subject to aspect Disable_Controlled, or
-      --  contains at least one controlled component.
-
-      else
-         return
-           Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ);
-      end if;
-   end Needs_Finalization;
-
    ----------------------------
    -- New_Class_Wide_Subtype --
    ----------------------------
@@ -12170,9 +12082,7 @@  package body Exp_Util is
       Typ     : Entity_Id;
 
    begin
-      if No (L)
-        or else Is_Empty_List (L)
-      then
+      if No (L) or else Is_Empty_List (L) then
          return False;
       end if;
 

--- gcc/ada/exp_util.ads
+++ gcc/ada/exp_util.ads
@@ -944,10 +944,6 @@  package Exp_Util is
    --  consist of constants, when the object has a nontrivial initialization
    --  or is controlled.
 
-   function Needs_Finalization (Typ : Entity_Id) return Boolean;
-   --  Determine whether type Typ is controlled and this requires finalization
-   --  actions.
-
    function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id;
    --  An anonymous access type may designate a limited view. Check whether
    --  non-limited view is available during expansion, to examine components

--- gcc/ada/sem_ch9.adb
+++ gcc/ada/sem_ch9.adb
@@ -1897,9 +1897,6 @@  package body Sem_Ch9 is
    ----------------------------------
 
    procedure Analyze_Protected_Definition (N : Node_Id) is
-      E : Entity_Id;
-      L : Entity_Id;
-
       procedure Undelay_Itypes (T : Entity_Id);
       --  Itypes created for the private components of a protected type
       --  do not receive freeze nodes, because there is no scope in which
@@ -1932,9 +1929,7 @@  package body Sem_Ch9 is
          end if;
 
          while Present (Comp) loop
-            if Is_Type (Comp)
-              and then Is_Itype (Comp)
-            then
+            if Is_Type (Comp) and then Is_Itype (Comp) then
                Set_Has_Delayed_Freeze (Comp, False);
                Set_Is_Frozen (Comp);
 
@@ -1942,9 +1937,7 @@  package body Sem_Ch9 is
                   Layout_Type (Comp);
                end if;
 
-               if Is_Record_Type (Comp)
-                 or else Is_Protected_Type (Comp)
-               then
+               if Is_Record_Type (Comp) or else Is_Protected_Type (Comp) then
                   Undelay_Itypes (Comp);
                end if;
             end if;
@@ -1953,6 +1946,12 @@  package body Sem_Ch9 is
          end loop;
       end Undelay_Itypes;
 
+      --  Local variables
+
+      Prot_Typ : constant Entity_Id := Current_Scope;
+      Item_Id  : Entity_Id;
+      Last_Id  : Entity_Id;
+
    --  Start of processing for Analyze_Protected_Definition
 
    begin
@@ -1963,32 +1962,37 @@  package body Sem_Ch9 is
       if Present (Private_Declarations (N))
         and then not Is_Empty_List (Private_Declarations (N))
       then
-         L := Last_Entity (Current_Scope);
+         Last_Id := Last_Entity (Prot_Typ);
          Analyze_Declarations (Private_Declarations (N));
 
-         if Present (L) then
-            Set_First_Private_Entity (Current_Scope, Next_Entity (L));
+         if Present (Last_Id) then
+            Set_First_Private_Entity (Prot_Typ, Next_Entity (Last_Id));
          else
-            Set_First_Private_Entity (Current_Scope,
-              First_Entity (Current_Scope));
+            Set_First_Private_Entity (Prot_Typ, First_Entity (Prot_Typ));
          end if;
       end if;
 
-      E := First_Entity (Current_Scope);
-      while Present (E) loop
-         if Ekind_In (E, E_Function, E_Procedure) then
-            Set_Convention (E, Convention_Protected);
+      Item_Id := First_Entity (Prot_Typ);
+      while Present (Item_Id) loop
+         if Ekind_In (Item_Id, E_Function, E_Procedure) then
+            Set_Convention (Item_Id, Convention_Protected);
          else
-            Propagate_Concurrent_Flags (Current_Scope, Etype (E));
+            Propagate_Concurrent_Flags (Prot_Typ, Etype (Item_Id));
+
+            if Chars (Item_Id) /= Name_uParent
+              and then Needs_Finalization (Etype (Item_Id))
+            then
+               Set_Has_Controlled_Component (Prot_Typ);
+            end if;
          end if;
 
-         Next_Entity (E);
+         Next_Entity (Item_Id);
       end loop;
 
-      Undelay_Itypes (Current_Scope);
+      Undelay_Itypes (Prot_Typ);
 
       Check_Max_Entries (N, Max_Protected_Entries);
-      Process_End_Label (N, 'e', Current_Scope);
+      Process_End_Label (N, 'e', Prot_Typ);
    end Analyze_Protected_Definition;
 
    ----------------------------------------

--- gcc/ada/sem_util.adb
+++ gcc/ada/sem_util.adb
@@ -19418,6 +19418,94 @@  package body Sem_Util is
       return Empty;
    end Nearest_Enclosing_Instance;
 
+   ------------------------
+   -- Needs_Finalization --
+   ------------------------
+
+   function Needs_Finalization (Typ : Entity_Id) return Boolean is
+      function Has_Some_Controlled_Component
+        (Input_Typ : Entity_Id) return Boolean;
+      --  Determine whether type Input_Typ has at least one controlled
+      --  component.
+
+      -----------------------------------
+      -- Has_Some_Controlled_Component --
+      -----------------------------------
+
+      function Has_Some_Controlled_Component
+        (Input_Typ : Entity_Id) return Boolean
+      is
+         Comp : Entity_Id;
+
+      begin
+         --  When a type is already frozen and has at least one controlled
+         --  component, or is manually decorated, it is sufficient to inspect
+         --  flag Has_Controlled_Component.
+
+         if Has_Controlled_Component (Input_Typ) then
+            return True;
+
+         --  Otherwise inspect the internals of the type
+
+         elsif not Is_Frozen (Input_Typ) then
+            if Is_Array_Type (Input_Typ) then
+               return Needs_Finalization (Component_Type (Input_Typ));
+
+            elsif Is_Record_Type (Input_Typ) then
+               Comp := First_Component (Input_Typ);
+               while Present (Comp) loop
+                  if Needs_Finalization (Etype (Comp)) then
+                     return True;
+                  end if;
+
+                  Next_Component (Comp);
+               end loop;
+            end if;
+         end if;
+
+         return False;
+      end Has_Some_Controlled_Component;
+
+   --  Start of processing for Needs_Finalization
+
+   begin
+      --  Certain run-time configurations and targets do not provide support
+      --  for controlled types.
+
+      if Restriction_Active (No_Finalization) then
+         return False;
+
+      --  C++ types are not considered controlled. It is assumed that the non-
+      --  Ada side will handle their clean up.
+
+      elsif Convention (Typ) = Convention_CPP then
+         return False;
+
+      --  Class-wide types are treated as controlled because derivations from
+      --  the root type may introduce controlled components.
+
+      elsif Is_Class_Wide_Type (Typ) then
+         return True;
+
+      --  Concurrent types are controlled as long as their corresponding record
+      --  is controlled.
+
+      elsif Is_Concurrent_Type (Typ)
+        and then Present (Corresponding_Record_Type (Typ))
+        and then Needs_Finalization (Corresponding_Record_Type (Typ))
+      then
+         return True;
+
+      --  Otherwise the type is controlled when it is either derived from type
+      --  [Limited_]Controlled and not subject to aspect Disable_Controlled, or
+      --  contains at least one controlled component.
+
+      else
+         return
+           Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ);
+      end if;
+   end Needs_Finalization;
+
    ----------------------
    -- Needs_One_Actual --
    ----------------------

--- gcc/ada/sem_util.ads
+++ gcc/ada/sem_util.ads
@@ -2220,6 +2220,10 @@  package Sem_Util is
    --  Return the entity of the nearest enclosing instance which encapsulates
    --  entity E. If no such instance exits, return Empty.
 
+   function Needs_Finalization (Typ : Entity_Id) return Boolean;
+   --  Determine whether type Typ is controlled and this requires finalization
+   --  actions.
+
    function Needs_One_Actual (E : Entity_Id) return Boolean;
    --  Returns True if a function has defaults for all but its first formal,
    --  which is a controlling formal. Used in Ada 2005 mode to solve the