re PR fortran/57284 ([OOP] ICE with find_array_spec for polymorphic arrays)

2019-04-22  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/57284
	* resolve.c (find_array_spec): If this is a class expression
	and the symbol and component array specs are the same, this is
	not an error.
	*trans-intrinsic.c (gfc_conv_intrinsic_size): If a class symbol
	argument, has no namespace, it has come from the interface
	mapping and the _data component must be accessed directly.

2019-04-22  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/57284
	* gfortran.dg/class_70.f03

From-SVN: r270489

gcc/fortran/ChangeLog

+2019-04-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/57284
+	* resolve.c (find_array_spec): If this is a class expression
+	and the symbol and component array specs are the same, this is
+	not an error.
+	*trans-intrinsic.c (gfc_conv_intrinsic_size): If a class symbol
+	argument, has no namespace, it has come from the interface
+	mapping and the _data component must be accessed directly.
+
 2019-04-17  Thomas Schwinge  <thomas@codesourcery.com>
 
 	PR fortran/90048

gcc/fortran/resolve.c

@@ -4712,9 +4712,13 @@ find_array_spec (gfc_expr *e)
   gfc_array_spec *as;
   gfc_component *c;
   gfc_ref *ref;
+  bool class_as = false;
 
   if (e->symtree->n.sym->ts.type == BT_CLASS)
-    as = CLASS_DATA (e->symtree->n.sym)->as;
+    {
+      as = CLASS_DATA (e->symtree->n.sym)->as;
+      class_as = true;
+    }
   else
     as = e->symtree->n.sym->as;
 
@@ -4733,7 +4737,7 @@ find_array_spec (gfc_expr *e)
 	c = ref->u.c.component;
 	if (c->attr.dimension)
 	  {
-	    if (as != NULL)
+	    if (as != NULL && !(class_as && as == c->as))
 	      gfc_internal_error ("find_array_spec(): unused as(1)");
 	    as = c->as;
 	  }

gcc/fortran/trans-intrinsic.c

@@ -7446,6 +7446,8 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
   tree fncall0;
   tree fncall1;
   gfc_se argse;
+  gfc_expr *e;
+  gfc_symbol *sym = NULL;
 
   gfc_init_se (&argse, NULL);
   actual = expr->value.function.actual;
@@ -7453,12 +7455,31 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
   if (actual->expr->ts.type == BT_CLASS)
     gfc_add_class_array_ref (actual->expr);
 
+  e = actual->expr;
+
+  /* These are emerging from the interface mapping, when a class valued
+     function appears as the rhs in a realloc on assign statement, where
+     the size of the result is that of one of the actual arguments.  */
+  if (e->expr_type == EXPR_VARIABLE
+      && e->symtree->n.sym->ns == NULL /* This is distinctive!  */
+      && e->symtree->n.sym->ts.type == BT_CLASS
+      && e->ref && e->ref->type == REF_COMPONENT
+      && strcmp (e->ref->u.c.component->name, "_data") == 0)
+    sym = e->symtree->n.sym;
+
   argse.data_not_needed = 1;
-  if (gfc_is_class_array_function (actual->expr))
+  if (gfc_is_class_array_function (e))
     {
       /* For functions that return a class array conv_expr_descriptor is not
 	 able to get the descriptor right.  Therefore this special case.  */
-      gfc_conv_expr_reference (&argse, actual->expr);
+      gfc_conv_expr_reference (&argse, e);
+      argse.expr = gfc_build_addr_expr (NULL_TREE,
+					gfc_class_data_get (argse.expr));
+    }
+  else if (sym && sym->backend_decl)
+    {
+      gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
+      argse.expr = sym->backend_decl;
       argse.expr = gfc_build_addr_expr (NULL_TREE,
 					gfc_class_data_get (argse.expr));
     }

gcc/testsuite/ChangeLog

+2019-04-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/57284
+	* gfortran.dg/class_70.f03
+
 2019-04-21  H.J. Lu  <hongjiu.lu@intel.com>
 
 	PR target/90178

gcc/testsuite/gfortran.dg/class_70.f03

+! { dg-do run }
+!
+! Test the fix for PR57284 - [OOP] ICE with find_array_spec for polymorphic
+! arrays. Once thw ICE was fixed, work was needed to fix a segfault while
+! determining the size of 'z'.
+!
+! Contributed by Lorenz Huedepohl  <bugs@stellardeath.org>
+!
+module testmod
+  type type_t
+    integer :: idx
+  end type type_t
+  type type_u
+     type(type_t), allocatable :: cmp(:)
+  end type
+contains
+  function foo(a, b) result(add)
+    class(type_t), intent(in) :: a(:), b(size(a))
+    type(type_t) :: add(size(a))
+    add%idx = a%idx + b%idx
+  end function
+end module testmod
+program p
+  use testmod
+  class(type_t), allocatable, dimension(:) :: x, y, z
+  class(type_u), allocatable :: w
+  allocate (x, y, source = [type_t (1), type_t(2)])
+  z = foo (x, y)
+  if (any (z%idx .ne. [2, 4])) stop 1
+
+! Try something a bit more complicated than the original.
+
+  allocate (w)
+  allocate (w%cmp, source = [type_t (2), type_t(3)])
+  z = foo (w%cmp, y)
+  if (any (z%idx .ne. [3, 5])) stop 2
+  deallocate (w, x, y, z)
+end program