This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[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.

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

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.
--- 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;


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]