The part of this patch in resolve.c had essentially already been
sorted out by Tobias Burnus in comment #2 of the PR. I suspect that he
must have been put off the trail by the segfault that occurred when
this was implemented. In the end, the reason for the segfault is quite
straight forward and comes about because the temporary declarations
representing class actual arguments cause gfc_conv_component_ref to
barf, when porcessing the _data component. However, they are amenable
to gfc_class_data_get and so this is used in the fix.
Bootstrapped and regtested on FC29/x86_64 - OK for trunk?
Paul
2019-04-19 Paul Thomas <pa...@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-19 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/57284
* gfortran.dg/class_70.f03
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 270352)
--- gcc/fortran/resolve.c (working copy)
*************** find_array_spec (gfc_expr *e)
*** 4712,4720 ****
gfc_array_spec *as;
gfc_component *c;
gfc_ref *ref;
if (e->symtree->n.sym->ts.type == BT_CLASS)
! as = CLASS_DATA (e->symtree->n.sym)->as;
else
as = e->symtree->n.sym->as;
--- 4712,4724 ----
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;
! class_as = true;
! }
else
as = e->symtree->n.sym->as;
*************** find_array_spec (gfc_expr *e)
*** 4733,4739 ****
c = ref->u.c.component;
if (c->attr.dimension)
{
! if (as != NULL)
gfc_internal_error ("find_array_spec(): unused as(1)");
as = c->as;
}
--- 4737,4743 ----
c = ref->u.c.component;
if (c->attr.dimension)
{
! if (as != NULL && !(class_as && as == c->as))
gfc_internal_error ("find_array_spec(): unused as(1)");
as = c->as;
}
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c (revision 270352)
--- gcc/fortran/trans-intrinsic.c (working copy)
*************** gfc_conv_intrinsic_size (gfc_se * se, gf
*** 7446,7451 ****
--- 7446,7453 ----
tree fncall0;
tree fncall1;
gfc_se argse;
+ gfc_expr *e;
+ gfc_symbol *sym = NULL;
gfc_init_se (&argse, NULL);
actual = expr->value.function.actual;
*************** gfc_conv_intrinsic_size (gfc_se * se, gf
*** 7453,7464 ****
if (actual->expr->ts.type == BT_CLASS)
gfc_add_class_array_ref (actual->expr);
argse.data_not_needed = 1;
! if (gfc_is_class_array_function (actual->expr))
{
/* 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);
argse.expr = gfc_build_addr_expr (NULL_TREE,
gfc_class_data_get (argse.expr));
}
--- 7455,7485 ----
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 (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, 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));
}
Index: gcc/testsuite/gfortran.dg/class_70.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_70.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/class_70.f03 (working copy)
***************
*** 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 <b...@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
