re PR fortran/78356 ([OOP] segfault allocating polymorphic variable with polymorphic...

gcc/fortran/ChangeLog:

2016-11-16  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/78356
	* class.c (gfc_is_class_scalar_expr): Prevent taking an array ref for
	a component ref.
	* trans-expr.c (gfc_trans_assignment_1): Ensure a reference to the
	object to copy is generated, when assigning class objects.

gcc/testsuite/ChangeLog:

2016-11-16  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/78356
	* gfortran.dg/class_allocate_23.f08: New test.

From-SVN: r242490

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index cf16e1a87546b046580606c2593c0927c92e5c30..4dad588c3d2e84266ceb1d0f3b8416d8260623c4 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2016-11-16  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+       PR fortran/78356
+       * class.c (gfc_is_class_scalar_expr): Prevent taking an array ref for
+       a component ref.
+       * trans-expr.c (gfc_trans_assignment_1): Ensure a reference to the
+       object to copy is generated, when assigning class objects.
+
 2016-11-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
        * dump-parse-tree.c (show_code):  Add prototype.

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index b42ec40578f065868e8a61477b6622a01b7ca722..9db86b409b5709fa18cadebee45c7848e6f4ad26 100644 (file)
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -378,7 +378,8 @@ gfc_is_class_scalar_expr (gfc_expr *e)
        && CLASS_DATA (e->symtree->n.sym)
        && !CLASS_DATA (e->symtree->n.sym)->attr.dimension
        && (e->ref == NULL
-           || (strcmp (e->ref->u.c.component->name, "_data") == 0
+           || (e->ref->type == REF_COMPONENT
+               && strcmp (e->ref->u.c.component->name, "_data") == 0
                && e->ref->next == NULL)))
     return true;
 
@@ -390,7 +391,8 @@ gfc_is_class_scalar_expr (gfc_expr *e)
            && CLASS_DATA (ref->u.c.component)
            && !CLASS_DATA (ref->u.c.component)->attr.dimension
            && (ref->next == NULL
-               || (strcmp (ref->next->u.c.component->name, "_data") == 0
+               || (ref->next->type == REF_COMPONENT
+                   && strcmp (ref->next->u.c.component->name, "_data") == 0
                    && ref->next->next == NULL)))
        return true;
     }

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 48296b8dbdb36efef36dbf4e1e1dfe95b7950474..1331b07a2380f4fa354158d3295ce3d05a3d575a 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -9628,6 +9628,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   int n;
   bool maybe_workshare = false;
   symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
+  bool is_poly_assign;
 
   /* Assignment of the form lhs = rhs.  */
   gfc_start_block (&block);
@@ -9648,6 +9649,19 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
          || gfc_is_alloc_class_scalar_function (expr2)))
     expr2->must_finalize = 1;
 
+  /* Checking whether a class assignment is desired is quite complicated and
+     needed at two locations, so do it once only before the information is
+     needed.  */
+  lhs_attr = gfc_expr_attr (expr1);
+  is_poly_assign = (use_vptr_copy || lhs_attr.pointer
+                   || (lhs_attr.allocatable && !lhs_attr.dimension))
+                  && (expr1->ts.type == BT_CLASS
+                      || gfc_is_class_array_ref (expr1, NULL)
+                      || gfc_is_class_scalar_expr (expr1)
+                      || gfc_is_class_array_ref (expr2, NULL)
+                      || gfc_is_class_scalar_expr (expr2));
+
+
   /* Only analyze the expressions for coarray properties, when in coarray-lib
      mode.  */
   if (flag_coarray == GFC_FCOARRAY_LIB)
@@ -9676,6 +9690,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
       if (rss == gfc_ss_terminator)
        /* The rhs is scalar.  Add a ss for the expression.  */
        rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+      /* When doing a class assign, then the handle to the rhs needs to be a
+        pointer to allow for polymorphism.  */
+      if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
+       rss->info->type = GFC_SS_REFERENCE;
 
       /* Associate the SS with the loop.  */
       gfc_add_ss_to_loop (&loop, lss);
@@ -9835,14 +9853,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
        gfc_add_block_to_block (&loop.post, &rse.post);
     }
 
-  lhs_attr = gfc_expr_attr (expr1);
-  if ((use_vptr_copy || lhs_attr.pointer
-       || (lhs_attr.allocatable && !lhs_attr.dimension))
-      && (expr1->ts.type == BT_CLASS
-         || (gfc_is_class_array_ref (expr1, NULL)
-             || gfc_is_class_scalar_expr (expr1))
-         || (gfc_is_class_array_ref (expr2, NULL)
-             || gfc_is_class_scalar_expr (expr2))))
+  if (is_poly_assign)
     {
       tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
                                    use_vptr_copy || (lhs_attr.allocatable

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 59a707f0dbcd236ffe94c6a6f2d52f929ee348c3..4f6d853c468c6ae879537e6785042f38e7ba84c5 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2016-11-16  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+       PR fortran/78356
+       * gfortran.dg/class_allocate_23.f08: New test.
+
 2016-11-16  Richard Biener  <rguenther@suse.de>
 
        PR middle-end/78333

diff --git a/gcc/testsuite/gfortran.dg/class_allocate_23.f08 b/gcc/testsuite/gfortran.dg/class_allocate_23.f08
new file mode 100644 (file)
index 0000000..5c83fbe
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_allocate_23.f08
@@ -0,0 +1,31 @@
+! { dg-do run }
+!
+! Test that pr78356 is fixed.
+! Contributed by Janus Weil and Andrew Benson
+
+program p
+  implicit none
+  type ac
+  end type
+  type, extends(ac) :: a
+     integer, allocatable :: b
+  end type
+  type n
+     class(ac), allocatable :: acr(:)
+  end type
+  type(n) :: s,t
+  allocate(a :: s%acr(1))
+  call nncp(s,t)
+  select type (cl => t%acr(1))
+    class is (a)
+      if (allocated(cl%b)) error stop
+    class default
+      error stop
+  end select
+contains
+  subroutine nncp(self,tg)
+    type(n) :: self, tg
+    allocate(tg%acr(1),source=self%acr(1))
+  end
+end
+