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

re PR fortran/78356 ([OOP] segfault allocating polymorphic variable with polymorphic component with allocatable component)

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

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.
+
 2016-11-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	* dump-parse-tree.c (show_code):  Add prototype.

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

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

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/class_allocate_23.f08

+! { 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
+