[Ada] Crash on deallocating component with discriminated task

[Pierre-Marie de Rodat]

This patch modifies the generation of task deallocation code to examine
the underlying type for task components.

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

2019-07-05  Hristian Kirtchev  <kirtc...@adacore.com>

gcc/ada/

        * exp_ch7.adb (Cleanup_Record): Use the underlying type when
        checking for components with tasks.

gcc/testsuite/

        * gnat.dg/task3.adb, gnat.dg/task3.ads, gnat.dg/task3_pkg1.ads,
        gnat.dg/task3_pkg2.ads: New testcase.
--- gcc/ada/exp_ch7.adb
+++ gcc/ada/exp_ch7.adb
@@ -3893,11 +3893,12 @@ package body Exp_Ch7 is
       Typ  : Entity_Id) return List_Id
    is
       Loc   : constant Source_Ptr := Sloc (N);
-      Tsk   : Node_Id;
-      Comp  : Entity_Id;
       Stmts : constant List_Id    := New_List;
       U_Typ : constant Entity_Id  := Underlying_Type (Typ);
 
+      Comp : Entity_Id;
+      Tsk  : Node_Id;
+
    begin
       if Has_Discriminants (U_Typ)
         and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
@@ -3918,7 +3919,7 @@ package body Exp_Ch7 is
          return New_List (Make_Null_Statement (Loc));
       end if;
 
-      Comp := First_Component (Typ);
+      Comp := First_Component (U_Typ);
       while Present (Comp) loop
          if Has_Task (Etype (Comp))
            or else Has_Simple_Protected_Object (Etype (Comp))
@@ -3937,8 +3938,8 @@ package body Exp_Ch7 is
 
             elsif Is_Record_Type (Etype (Comp)) then
 
-               --  Recurse, by generating the prefix of the argument to
-               --  the eventual cleanup call.
+               --  Recurse, by generating the prefix of the argument to the
+               --  eventual cleanup call.
 
                Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
 

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/task3.adb
@@ -0,0 +1,11 @@
+--  { dg-do compile }
+
+with Ada.Unchecked_Deallocation;
+
+package body Task3 is
+   procedure Destroy (Obj : in out Child_Wrapper) is
+      procedure Free is new Ada.Unchecked_Deallocation (Child, Child_Ptr);
+   begin
+      Free (Obj.Ptr);
+   end Destroy;
+end Task3;

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/task3.ads
@@ -0,0 +1,12 @@
+with Task3_Pkg2; use Task3_Pkg2;
+
+package Task3 is
+   type Child is new Root with null record;
+   type Child_Ptr is access Child;
+
+   type Child_Wrapper is record
+      Ptr : Child_Ptr := null;
+   end record;
+
+   procedure Destroy (Obj : in out Child_Wrapper);
+end Task3;

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/task3_pkg1.ads
@@ -0,0 +1,11 @@
+package Task3_Pkg1 is
+   type Task_Wrapper (Discr : Integer) is tagged limited private;
+
+private
+   task type Task_Typ (Discr : Integer) is
+   end Task_Typ;
+
+   type Task_Wrapper (Discr : Integer) is tagged limited record
+      Tsk : Task_Typ (Discr);
+   end record;
+end Task3_Pkg1;

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/task3_pkg2.ads
@@ -0,0 +1,7 @@
+with Task3_Pkg1; use Task3_Pkg1;
+
+package Task3_Pkg2 is
+   type Root (Discr : Integer) is tagged limited record
+      Wrap : Task_Wrapper (Discr);
+   end record;
+end Task3_Pkg2;