From 16a51cf5491b642639b60ea12c0fff12a5403934 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Mon, 22 Apr 2019 06:50:33 +0000 Subject: [PATCH] re PR fortran/57284 ([OOP] ICE with find_array_spec for polymorphic arrays) 2019-04-22 Paul Thomas 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 PR fortran/57284 * gfortran.dg/class_70.f03 From-SVN: r270489 --- gcc/fortran/ChangeLog | 10 +++++++ gcc/fortran/resolve.c | 8 ++++-- gcc/fortran/trans-intrinsic.c | 25 +++++++++++++++-- gcc/testsuite/ChangeLog | 5 ++++ gcc/testsuite/gfortran.dg/class_70.f03 | 38 ++++++++++++++++++++++++++ 5 files changed, 82 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/class_70.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1ff03e1e85b..6a11bf5514b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2019-04-22 Paul Thomas + + 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 PR fortran/90048 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index cb41da08526..8232deb8170 100644 --- 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 2eb5d1ae6f7..e0a4c6709de 100644 --- 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 983382492f0..4d10bfd0b08 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-04-22 Paul Thomas + + PR fortran/57284 + * gfortran.dg/class_70.f03 + 2019-04-21 H.J. Lu 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 index 00000000000..b689563916d --- /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 +! +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 -- 2.30.2