[Ada] Missing finalization of private protected type

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;

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.

From-SVN: r273383

gcc/ada/ChangeLog

+2019-07-11  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* 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.
+
 2019-07-11  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* alloc.ads (Rep_JSON_Table_Initial): New constant.

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

@@ -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

@@ -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

@@ -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

@@ -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