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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1ff03e1e85b5fadae857bd3d9ed2c8f87a80fdd3..6a11bf5514bc79ae0523e7db1fe98d6599373b50 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+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

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index cb41da08526fcfd76fa0068e7b966456dd39e4ca..8232deb81704b8cea92e1a6064870b7cbc801046 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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;
          }

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 2eb5d1ae6f7ea9e1ba6dbc31565965ea5c3e19c4..e0a4c6709de541c331a815f9dcae9a74fdf1ab6e 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/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));
     }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 983382492f0837a39cd47dec7a77d9188990fc65..4d10bfd0b0838704a18a5d52619c9078e358c11c 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/class_70.f03 b/gcc/testsuite/gfortran.dg/class_70.f03
new file mode 100644 (file)
index 0000000..b689563
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_70.f03
@@ -0,0 +1,38 @@
+! { 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