re PR fortran/91726 (ICE in gfc_conv_array_ref, at fortran/trans-array.c:3612)

2019-09-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/91726
	* resolve.c (gfc_expr_to_initialize): Bail out with a copy of
	the original expression if the array ref is a scalar and the
	array_spec has corank.
	* trans-array.c (gfc_conv_array_ref): Such expressions are OK
	even if the array ref codimen is zero.
	* trans-expr.c (gfc_get_class_from_expr): New function taken
	from gfc_get_vptr_from_expr.
	(gfc_get_vptr_from_expr): Call new function.
	* trans-stmt.c (trans_associate_var): If one of these is a
	target expression, extract the class expression from the target
	and copy its fields to a new target variable.
	* trans.h : Add prototype for gfc_get_class_from_expr.

2019-09-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/91726
	* gfortran.dg/coarray_poly_9.f90 : New test.

From-SVN: r276269

8 files changed, 123 insertions, 5 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0b87006..8fc5625 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,19 @@
+2019-09-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/91726
+	* resolve.c (gfc_expr_to_initialize): Bail out with a copy of
+	the original expression if the array ref is a scalar and the
+	array_spec has corank.
+	* trans-array.c (gfc_conv_array_ref): Such expressions are OK
+	even if the array ref codimen is zero.
+	* trans-expr.c (gfc_get_class_from_expr): New function taken
+	from gfc_get_vptr_from_expr.
+	(gfc_get_vptr_from_expr): Call new function.
+	* trans-stmt.c (trans_associate_var): If one of these is a
+	target expression, extract the class expression from the target
+	and copy its fields to a new target variable.
+	* trans.h : Add prototype for gfc_get_class_from_expr.
+
 2019-09-28  Jerry DeLisle  <jvdelisle@gcc.ngu.org>
 
 	PR fortran/91802
@@ -14,7 +30,7 @@
 	PR fortran/91864
 	* gcc/fortran/io.c (match_io_element): An inquiry parameter cannot be
 	read into.
-	* gcc/fortran/match.c (gfc_match_allocate): An inquiry parameter 
+	* gcc/fortran/match.c (gfc_match_allocate): An inquiry parameter
 	can be neither an allocate-object nor stat variable.
 	(gfc_match_deallocate): An inquiry parameter cannot be deallocated.
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f1de7dd..e8d0566 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7433,6 +7433,10 @@ gfc_expr_to_initialize (gfc_expr *e)
   for (ref = result->ref; ref; ref = ref->next)
     if (ref->type == REF_ARRAY && ref->next == NULL)
       {
+	if (ref->u.ar.dimen == 0
+	    && ref->u.ar.as && ref->u.ar.as->corank)
+	  return result;
+
 	ref->u.ar.type = AR_FULL;
 
 	for (i = 0; i < ref->u.ar.dimen; i++)
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 07c4d7e..437892a 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3609,7 +3609,8 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
 
   if (ar->dimen == 0)
     {
-      gcc_assert (ar->codimen || sym->attr.select_rank_temporary);
+      gcc_assert (ar->codimen || sym->attr.select_rank_temporary
+		  || (ar->as && ar->as->corank));
 
       if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
 	se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 2adc112..61db4e3 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -472,11 +472,11 @@ gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
 }
 
 
-/* Obtain the vptr of the last class reference in an expression.
+/* Obtain the last class reference in an expression.
    Return NULL_TREE if no class reference is found.  */
 
 tree
-gfc_get_vptr_from_expr (tree expr)
+gfc_get_class_from_expr (tree expr)
 {
   tree tmp;
   tree type;
@@ -487,7 +487,7 @@ gfc_get_vptr_from_expr (tree expr)
       while (type)
 	{
 	  if (GFC_CLASS_TYPE_P (type))
-	    return gfc_class_vptr_get (tmp);
+	    return tmp;
 	  if (type != TYPE_CANONICAL (type))
 	    type = TYPE_CANONICAL (type);
 	  else
@@ -501,6 +501,23 @@ gfc_get_vptr_from_expr (tree expr)
     tmp = build_fold_indirect_ref_loc (input_location, tmp);
 
   if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+    return tmp;
+
+  return NULL_TREE;
+}
+
+
+/* Obtain the vptr of the last class reference in an expression.
+   Return NULL_TREE if no class reference is found.  */
+
+tree
+gfc_get_vptr_from_expr (tree expr)
+{
+  tree tmp;
+
+  tmp = gfc_get_class_from_expr (expr);
+
+  if (tmp != NULL_TREE)
     return gfc_class_vptr_get (tmp);
 
   return NULL_TREE;
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 856a171..e3ea38a 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -2099,7 +2099,43 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	}
       else
 	{
+	  tree ctree = gfc_get_class_from_expr (se.expr);
 	  tmp = TREE_TYPE (sym->backend_decl);
+
+	  /* Coarray scalar component expressions can emerge from
+	     the front end as array elements of the _data field.  */
+	  if (sym->ts.type == BT_CLASS
+	      && e->ts.type == BT_CLASS && e->rank == 0
+	      && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)) && ctree)
+	    {
+	      tree stmp;
+	      tree dtmp;
+
+	      se.expr = ctree;
+	      dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl));
+	      ctree = gfc_create_var (dtmp, "class");
+
+	      stmp = gfc_class_data_get (se.expr);
+	      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp)));
+
+	      /* Set the fields of the target class variable.  */
+	      stmp = gfc_conv_descriptor_data_get (stmp);
+	      dtmp = gfc_class_data_get (ctree);
+	      stmp = fold_convert (TREE_TYPE (dtmp), stmp);
+	      gfc_add_modify (&se.pre, dtmp, stmp);
+	      stmp = gfc_class_vptr_get (se.expr);
+	      dtmp = gfc_class_vptr_get (ctree);
+	      stmp = fold_convert (TREE_TYPE (dtmp), stmp);
+	      gfc_add_modify (&se.pre, dtmp, stmp);
+	      if (UNLIMITED_POLY (sym))
+		{
+		  stmp = gfc_class_len_get (se.expr);
+		  dtmp = gfc_class_len_get (ctree);
+		  stmp = fold_convert (TREE_TYPE (dtmp), stmp);
+		  gfc_add_modify (&se.pre, dtmp, stmp);
+		}
+	      se.expr = ctree;
+	    }
 	  tmp = gfc_build_addr_expr (tmp, se.expr);
 	}
 
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 84793dc..6ebb71d 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -442,6 +442,7 @@ tree gfc_vptr_final_get (tree);
 tree gfc_vptr_deallocate_get (tree);
 void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
 void gfc_reset_len (stmtblock_t *, gfc_expr *);
+tree gfc_get_class_from_expr (tree);
 tree gfc_get_vptr_from_expr (tree);
 tree gfc_get_class_array_ref (tree, tree, tree, bool);
 tree gfc_copy_class_to_class (tree, tree, tree, bool);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d0d2cb0..a23c728 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2019-09-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/91726
+	* gfortran.dg/coarray_poly_9.f90 : New test.
+
 2019-09-29  Kewen Lin  <linkw@gcc.gnu.org>
 
 	* gcc.target/powerpc/conv-vectorize-1.c: New test.
diff --git a/gcc/testsuite/gfortran.dg/coarray_poly_9.f90 b/gcc/testsuite/gfortran.dg/coarray_poly_9.f90
new file mode 100644
index 0000000..ea2a942
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_poly_9.f90
@@ -0,0 +1,38 @@
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! Test the fix for PR91726.
+!
+! Contributed by Gerhardt Steinmetz  <gscfq@t-online.de>
+!
+module m
+   type s
+      class(*), allocatable :: a[:]    ! This ICEd
+   end type
+   type t
+      class(*), allocatable :: a(:)[:] ! This was OK
+   end type
+end
+
+  use m
+  call foo
+  call bar
+contains
+  subroutine foo
+    type (s) :: a
+    integer(4) :: i = 42_4
+    allocate (a%a[*], source = i)     ! This caused runtime segfaults
+    select type (z => a%a)            ! ditto
+      type is (integer(4))
+      if (z .ne. 42_4) stop 1
+    end select
+  end subroutine
+  subroutine bar                      ! Arrays always worked
+    type (t) :: a
+    allocate (a%a(3)[*], source = [1_4, 2_4, 3_4])
+    select type (z => a%a)
+      type is (integer(4))
+      if (any (z .ne. [1_4, 2_4, 3_4])) stop 2
+    end select
+  end subroutine
+end