https://gcc.gnu.org/g:534e4f3ac0e30b0f38c1b2d485d669f2c8ebf832
commit 534e4f3ac0e30b0f38c1b2d485d669f2c8ebf832 Author: Mikael Morin <[email protected]> Date: Tue Oct 13 17:21:57 2026 +0200 fortran: Use span addressing for polymorphic target dummies [PR128827] 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 -- Address 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 addressing 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 in gfc_build_dummy_array_decl, stored in the GFC_DECL_SPAN of the local array decl, whose presence is sufficient to enable span addressing in the non-polymorphic case. But it is not sufficient for the polymorphic case, because the function gfc_maybe_dereference_var causes a dereference to be generated 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. 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 73f0280645d7..653ad06f28bc 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 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
