https://gcc.gnu.org/g:1892effc2f4b99665a3aa5d1d27aa093475a158d
commit r17-5783-g1892effc2f4b99665a3aa5d1d27aa093475a158d Author: Mikael Morin <[email protected]> Date: Sun Nov 1 14:30:49 2026 +0100 fortran: Use span indexing for polymorphic target dummies [PR127827] 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. Diff: --- gcc/fortran/symbol.cc | 22 ++++++---- gcc/fortran/trans-array.cc | 27 +++++++++++- gcc/testsuite/gfortran.dg/target_dummy_span_4.f90 | 50 +++++++++++++++++++++++ 3 files changed, 91 insertions(+), 8 deletions(-) diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index 00c86041550d..440b78288e16 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -5716,16 +5716,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 97d68caa1909..d1045ccfb19a 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 000000000000..8537ca4c0840 --- /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
