From: Mikael Morin <[email protected]> This requires the PR128033 patch [1] to prevent a regression with class_array_20.f03. Fortran-tested on aarch64-unknown-linux-gnu. OK for mainline?
[1] https://inbox.sourceware.org/fortran/[email protected]/ -- >8 -- Index polymorphic dummy arrays having the TARGET attribute using the span from the array descriptor instead of the size from the class container. A previous change by Jerry (r17-3342) introduced the infrastructure to suport span indexing for non-polymorphic target dummy arguments. The testcase provided in the PR and added here shows that it has to be extended to support the polymorphic case, as done by this change. The main change amends the existing function gfc_dummy_requires_direct_arg to allow polymorphic entities. It is more complex that just removing the condition excluding BT_CLASS type, because the DIMENSION, ALLOCATABLE and POINTER attributes are stored differently on polymorphic entities than on non-polymorphic ones, and the same goes for the array spec. So a mostly rewritten copy of the existing conditions is added for the CLASS case. Allowing polymorphic entities in gfc_dummy_requires_direct_arg enables the creation of a span variable by gfc_build_dummy_array_decl, stored in the GFC_DECL_SPAN of the local array decl, and whose presence is sufficient to enable span indexing in the non-polymorphic case. But it is not sufficient for polymorphic entities, because the function gfc_maybe_dereference_var generates a dereference for them around the local array decl reference, and GFC_DECL_GET_SPAN of a dereference returns NULL_TREE. So a preliminary step is added in gfc_get_array_span to unwrap the pointer dereference, making the value present in GFC_DECL_SPAN visible, which activates span indexing. PR fortran/127827 gcc/fortran/ChangeLog: * symbol.cc (gfc_dummy_requires_direct_arg): Allow CLASS type. * trans-array.cc (get_main_decl): New function. (gfc_get_array_span): If the array decl is not passed as input directly, get it first before querying the span on it. gcc/testsuite/ChangeLog: * gfortran.dg/target_dummy_span_4.f90: New test. --- gcc/fortran/symbol.cc | 22 +++++--- gcc/fortran/trans-array.cc | 27 +++++++++- .../gfortran.dg/target_dummy_span_4.f90 | 50 +++++++++++++++++++ 3 files changed, 91 insertions(+), 8 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/target_dummy_span_4.f90 diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index 73f0280645d..653ad06f28b 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -5715,16 +5715,24 @@ gfc_dummy_requires_direct_arg (gfc_symbol *sym) { return sym->attr.dummy && sym->attr.target - && sym->attr.dimension && !sym->attr.value && !sym->attr.contiguous - && !sym->attr.pointer - && !sym->attr.allocatable - && sym->ts.type != BT_CLASS + && !IS_POINTER (sym) && sym->ts.type != BT_ASSUMED - && sym->as - && (sym->as->type == AS_ASSUMED_SHAPE - || sym->as->type == AS_ASSUMED_RANK); + && ((sym->ts.type == BT_CLASS + && sym->ts.u.derived->attr.is_class + && CLASS_DATA (sym)->attr.dimension + && !CLASS_DATA (sym)->attr.allocatable + && CLASS_DATA (sym)->as + && (CLASS_DATA (sym)->as->type == AS_ASSUMED_SHAPE + || CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)) + || (!(sym->ts.type == BT_CLASS + && sym->ts.u.derived->attr.is_class) + && sym->attr.dimension + && !sym->attr.allocatable + && sym->as + && (sym->as->type == AS_ASSUMED_SHAPE + || sym->as->type == AS_ASSUMED_RANK))); } diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 97d68caa190..d1045ccfb19 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -668,6 +668,29 @@ class_array_element_size (tree decl, bool unlimited) } +/* Given a data reference EXPR, return the main underlying declaration + (variable, parameter, etc) if there is one, otherwise return NULL_TREE. + Having the declaration gives access to the additional metadata stored in + its lang-specific node. */ + +static tree +get_main_decl (tree expr) +{ + tree decl = expr; + while (decl && !DECL_P (decl)) + { + if (TREE_CODE (decl) == ADDR_EXPR + || INDIRECT_REF_P (decl) + || CONVERT_EXPR_P (decl)) + decl = TREE_OPERAND (decl, 0); + else + decl = NULL_TREE; + } + + return decl; +} + + /* Return the span of an array. */ tree @@ -677,7 +700,9 @@ gfc_get_array_span (tree desc, gfc_expr *expr) gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ? expr->symtree->n.sym : NULL; - if (tree span = GFC_DECL_GET_SPAN (desc)) + tree decl = get_main_decl (desc); + + if (tree span = GFC_DECL_GET_SPAN (decl ? decl : desc)) /* A span addressed dummy loaded its span on entry. */ tmp = span; else if (is_span_addressed_array (desc) diff --git a/gcc/testsuite/gfortran.dg/target_dummy_span_4.f90 b/gcc/testsuite/gfortran.dg/target_dummy_span_4.f90 new file mode 100644 index 00000000000..8537ca4c084 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/target_dummy_span_4.f90 @@ -0,0 +1,50 @@ +! { dg-do run } +! +! PR fortran/127827 +! Check that array access correctly uses the span from the descriptor, +! including for polymorphic dummy arguments. + +program prog + implicit none + integer, parameter :: n = 5 + type :: t1 + integer :: c1, c2 + end type + type, extends(t1) :: t2 + integer :: c3 + end type + type(t2), target :: a(n) + integer :: i + a = [ (t2(3*i*i+2, i*i+1, 5*i+3), i=1,size(a)) ] + call check_all(a%t1, 1) + call type_wrapper(a%t1, 2, 3) + call class_wrapper(a%t1, 4) +contains + subroutine type_wrapper(x, e1, e2) + type(t1), target, intent(in) :: x(:) + integer, intent(in) :: e1, e2 + call check_all(x, e1) + call class_wrapper(x, e2) + end subroutine + subroutine class_wrapper(x, e) + class(t1), target, intent(in) :: x(:) + integer, intent(in) :: e + call check_all(x, e) + end subroutine + subroutine check_all(x, e) + type(t1), target, intent(in) :: x(:) + integer, intent(in) :: e + call check(x%c1, [ 5, 14, 29, 50, 77 ], e*10+1) + call check(x%c2, [ 2, 5, 10, 17, 26 ], e*10+2) + end subroutine + subroutine check(a, v, e) + integer, intent(in), dimension(:) :: a, v + integer, intent(in) :: e + integer :: i + if (size(a) /= size(v)) error stop e*10 + !do i = 1, size(a) + ! print *, e*10+i, (a(i) == v(i) ? "PASS" : "FAIL"), a(i), v(i) + !end do + if (any(a /= v)) error stop e*10+9 + end subroutine +end program base-commit: cada5a5bcdc4ec5e1d8e56fed922330e8b95887c prerequisite-patch-id: 2d4e8d778e9fd6eb88a199e4b9f95f687f957a85 -- 2.53.0
