https://gcc.gnu.org/g:cb40016196c48b7a05d5fe517332900131938fb5
commit cb40016196c48b7a05d5fe517332900131938fb5 Author: Mikael Morin <[email protected]> Date: Thu Sep 17 14:43:02 2026 +0200 fortran: Copy the span from the target descriptor in pointer assignments [PR127448] This fixes the span set by array pointer assignments, which is part of PR127448. The testcase is a variant of the original testcase from the PR, with the dummy argument of the checking function having the target attribute, so that arguments are passed to the function without any temporary array. This avoids problems relating to array copy that remain unfixed despite this patch in the original testcase. Fortran-tested on aarch64-unknown-linux-gnu. OK for mainline? -- >8 -- Mark the _data field of array pointer class containers with the GFC_DECL_PTR_ARRAY_P flag, so that in pointer assignments, the span assigned to the array descriptor is copied from the target descriptor span instead of the class container size. Before this change, it was assumed that the size taken from the class container was the correct span value. This was supposing all polymorphic arrays to be contiguous, which is not the case for a polymorphic pointer whose target is a parent object of an extended derived type object. The change tries to keep the current behaviour if possible, that is use the size from the class container if the array is known to be contiguous. I doubt the information is properly propagated everywhere, but it should be conservatively correct. The is_pointer_array hunk removes a condition that is redundant: the type of the operand 1 of a component ref is the type of the field, which is also the type of the component ref itself, which has already been checked before. I suspect the condition to be a typo and should check operand 0 of the component ref. If that was the case, this patch would remove it anyway. PR fortran/127448 gcc/fortran/ChangeLog: * trans-array.cc (is_pointer_array): Remove redundant condition. (is_span_addressed_array): For polymorphic arrays, return false if the array is known to be contiguous. * trans-types.cc (gfc_get_derived_type): Also set the GFC_DECL_PTR_ARRAY_P flag for _data fields of class containers corresponding to polymorphic array pointers. gcc/testsuite/ChangeLog: * gfortran.dg/pointer_assign_17.f90: New test. Diff: --- gcc/fortran/trans-array.cc | 28 +++++++++-- gcc/fortran/trans-types.cc | 5 +- gcc/testsuite/gfortran.dg/pointer_assign_17.f90 | 65 +++++++++++++++++++++++++ 3 files changed, 93 insertions(+), 5 deletions(-) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index abf6f907f05e..abc606dc627f 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -484,8 +484,7 @@ is_pointer_array (tree expr) /* The field declaration is marked as a pointer array. */ if (TREE_CODE (expr) == COMPONENT_REF - && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1)) - && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1)))) + && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))) return true; return false; @@ -501,7 +500,30 @@ static bool is_span_addressed_array (tree expr) { if (is_pointer_array (expr)) - return true; + { + /* For classes, index arrays using the size from the virtual pointer if + the array is contiguous. Otherwise use the span. */ + if (TREE_CODE (expr) == COMPONENT_REF + && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 0))) + && TYPE_LANG_SPECIFIC (TREE_TYPE (expr))) + { + switch (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (expr))) + { + case GFC_ARRAY_ASSUMED_SHAPE_CONT: + case GFC_ARRAY_ASSUMED_RANK_CONT: + case GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE: + case GFC_ARRAY_ASSUMED_RANK_POINTER_CONT: + case GFC_ARRAY_ALLOCATABLE: + case GFC_ARRAY_POINTER_CONT: + return false; + + default: + break; + } + } + + return true; + } if (VAR_P (expr) && GFC_DECL_PTR_ARRAY_P (expr) diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index ef80cd8feabb..3675f0932535 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -3167,8 +3167,9 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen) if (class_coarray_flag || !c->backend_decl || c->attr.caf_token) c->backend_decl = field; - if (c->attr.pointer && (c->attr.dimension || c->attr.codimension) - && !(c->ts.type == BT_DERIVED && strcmp (c->name, "_data") == 0)) + if ((c->attr.dimension || c->attr.codimension) + && ((derived->attr.is_class && c->attr.class_pointer) + || (!derived->attr.is_class && c->attr.pointer))) GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1; } diff --git a/gcc/testsuite/gfortran.dg/pointer_assign_17.f90 b/gcc/testsuite/gfortran.dg/pointer_assign_17.f90 new file mode 100644 index 000000000000..a3fc3e2ff47e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_assign_17.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! PR fortran/127448 +! Check the span set in array pointer assignments. +! For class pointers, the size from the class container was always +! used as span, which caused problems when the pointer was pointing +! to a parent subobject of an extended derived type entity. + +program prog + implicit none + integer, parameter :: k = 2 + integer, parameter :: n = 5 + type :: t1 + integer(kind=k) :: c1, c2 + end type + type, extends(t1) :: t2 + integer(kind=k) :: c3 + end type + type(t2), target :: x(n) + class(t1), pointer :: y1(:), z1(:) + class(t2), pointer :: y2(:) + type(t1), pointer :: p1(:), q1(:) + integer :: i + x = [ (t2(i*i, 2*i*i+1, i), i=1,n) ] + y2 => x + y1 => x + call check_t1(y1, 12) + z1 => y2 + call check_t1(z1, 13) + z1 => y1 + call check_t1(z1, 14) + call check_t1(x%t1, 21) + call check_t1(y2%t1, 22) + y1 => x%t1 + call check_t1(y1, 23) + z1 => y2%t1 + call check_t1(z1, 24) + z1 => y1 + call check_t1(z1, 25) + p1 => x%t1 + call check_t1(p1, 41) + p1 => y2%t1 + call check_t1(p1, 42) + p1 => y1 + call check_t1(p1, 43) + q1 => p1 + call check_t1(q1, 44) +contains + subroutine check_t1(arg, f) + type(t1), target, intent(in) :: arg(:) + integer, intent(in) :: f + call check_int(arg%c1, [1, 4, 9, 16, 25], f*10+1) + call check_int(arg%c2, [3, 9, 19, 33, 51], f*10+2) + end subroutine + subroutine check_int(arg, e, f) + integer(kind=k), intent(in) :: arg(:) + integer, intent(in) :: e(:), f + integer :: i + if (size(arg, 1) /= size(e, 1)) error stop f*10+1 + !do i=1,size(arg) + ! print *, f*10+i, (arg(i) == e(i) ? "PASS" : "FAIL"), arg(i), e(i) + !end do + if (any(arg /= e)) error stop f*10+2 + end subroutine +end program
