===================================================================
*************** find_array_spec (gfc_expr *e)
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;
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)
c = ref->u.c.component;
if (c->attr.dimension)
{
! if (as != NULL)
gfc_internal_error ("find_array_spec(): unused as(1)");
as = c->as;
}
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;
}
===================================================================
*************** gfc_conv_intrinsic_size (gfc_se * se, gf
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
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));
}
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));
}
===================================================================
***************
+ ! { 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
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 <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-19 Paul Thomas <pault@gcc.gnu.org> PR fortran/57284 * gfortran.dg/class_70.f03