https://gcc.gnu.org/g:e02c2e7c9cbdf2be51c6eedd9b9462cfc73cbe8f
commit e02c2e7c9cbdf2be51c6eedd9b9462cfc73cbe8f Author: Mikael Morin <[email protected]> Date: Tue Oct 13 17:21:57 2026 +0200 Sauvegarde modifs Ajout test Activation erreurs test Correction attribut dimension Inversion dimension allocatable Extraction decl depuis deref var Revert partiel "Sauvegarde modifs" This reverts commit 76c54998b71af0bd913884c0da4806531c77ebbe. Diff: --- gcc/fortran/symbol.cc | 20 +++++---- gcc/fortran/trans-array.cc | 13 +++++- gcc/testsuite/gfortran.dg/target_dummy_span_4.f90 | 50 +++++++++++++++++++++++ 3 files changed, 75 insertions(+), 8 deletions(-) diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index 73f0280645d7..5adaba1e734c 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -5715,16 +5715,22 @@ 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->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..4978b94cac78 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -677,7 +677,18 @@ 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 = desc; + 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; + } + + 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
