From: Hristian Kirtchev <kirtchev@adacore.com>
Date: Fri, 5 Jul 2019 07:03:15 +0000 (+0000)
Subject: [Ada] Crash on deallocating component with discriminated task
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=9880061b346330e7c986016bdec75f38659f8793;p=gcc.git

[Ada] Crash on deallocating component with discriminated task

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

2019-07-05  Hristian Kirtchev  <kirtchev@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.

From-SVN: r273121
---

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index fed5a15c927..6da90f23352 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,8 @@
+2019-07-05  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_ch7.adb (Cleanup_Record): Use the underlying type when
+	checking for components with tasks.
+
 2019-07-05  Arnaud Charlet  <charlet@adacore.com>
 
 	* libgnarl/s-osinte__linux.ads: Link with -lrt before -lpthread.
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 1e17b1947d1..4526af6f1c0 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/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)));
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 08d86957090..cdf0b40de02 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2019-07-05  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* gnat.dg/task3.adb, gnat.dg/task3.ads, gnat.dg/task3_pkg1.ads,
+	gnat.dg/task3_pkg2.ads: New testcase.
+
 2019-07-05  Javier Miranda  <miranda@adacore.com>
 
 	* gnat.dg/access6.adb: New testcase.
diff --git a/gcc/testsuite/gnat.dg/task3.adb b/gcc/testsuite/gnat.dg/task3.adb
new file mode 100644
index 00000000000..a73c2dcb2d6
--- /dev/null
+++ b/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;
diff --git a/gcc/testsuite/gnat.dg/task3.ads b/gcc/testsuite/gnat.dg/task3.ads
new file mode 100644
index 00000000000..324d8949212
--- /dev/null
+++ b/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;
diff --git a/gcc/testsuite/gnat.dg/task3_pkg1.ads b/gcc/testsuite/gnat.dg/task3_pkg1.ads
new file mode 100644
index 00000000000..cc41be07688
--- /dev/null
+++ b/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;
diff --git a/gcc/testsuite/gnat.dg/task3_pkg2.ads b/gcc/testsuite/gnat.dg/task3_pkg2.ads
new file mode 100644
index 00000000000..aee5c734941
--- /dev/null
+++ b/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;