https://gcc.gnu.org/g:20f5218c4b6bb279b5fba927520bfe5dff013c1c
commit 20f5218c4b6bb279b5fba927520bfe5dff013c1c Author: Mikael Morin <[email protected]> Date: Sun Sep 6 10:06:28 2026 +0200 libgfortran: [PR126964] Compare the elements a descriptor denotes in ASSOCIATED The stride of a descriptor counts spans rather than elements, so two descriptors can denote the same storage sequence while holding different combinations of the two. Elements that are subobjects of larger ones are described either by the spacing of the larger objects as the span, with the stride counting them, or by that spacing folded into the stride, with the element length as the span. ASSOCIATED compared the span and the strides field by field, so a pointer to a dummy whose spacing is folded into its strides on entry was not associated with its own actual argument. Compare the stride in bytes, which is what the two encodings have in common. The element length is normally held by the dtype, but the descriptor built for a polymorphic pointer to a character section holds the spacing there instead and carries the length separately, so require the two to agree on the element length or on the span rather than on the element length alone. PR fortran/126964 libgfortran/ChangeLog: * intrinsics/associated.c (stride_in_bytes): New function. (associated): Require the element length or the span to agree rather than the span alone, and compare the stride in bytes rather than the stride. gcc/testsuite/ChangeLog: * gfortran.dg/associated_target_9.f90: New test. Diff: --- gcc/testsuite/gfortran.dg/associated_target_9.f90 | 70 +++++++++++++++++++++++ libgfortran/intrinsics/associated.c | 30 +++++++++- 2 files changed, 98 insertions(+), 2 deletions(-) diff --git a/gcc/testsuite/gfortran.dg/associated_target_9.f90 b/gcc/testsuite/gfortran.dg/associated_target_9.f90 new file mode 100644 index 000000000000..7b9815440168 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associated_target_9.f90 @@ -0,0 +1,70 @@ +! { dg-do run } +! PR126964 +! Elements that are subobjects of larger ones are described either by the +! spacing of the larger objects as the span of the descriptor, or by that +! spacing folded into its strides with the element length as the span. +! ASSOCIATED compared the two encodings field by field, so a pointer to a +! TARGET assumed-shape dummy was not associated with the actual argument. +! +module m + implicit none + type :: tr + real :: a, b, c + end type + type :: tc + complex :: z + real :: r + end type + real, pointer :: pr(:) => null() + real, pointer :: ps(:) => null() + complex, pointer :: pc(:) => null() +contains + subroutine taker (x) + real, target, intent(inout) :: x(:) + pr => x + ps => x(1:size (x):2) + end subroutine + subroutine takec (x) + complex, target, intent(inout) :: x(:) + pc => x + end subroutine +end module + +program p + use m + implicit none + type(tr), target :: v(4) + type(tc), target :: w(4) + real, target :: flat(4) + integer :: i + + v%a = 0.0 + v%b = [(real (i), i = 1, 4)] + v%c = 0.0 + w%z = [(cmplx (i, 0), i = 1, 4)] + w%r = 0.0 + flat = [(real (i), i = 1, 4)] + + ! Elements that are subobjects of larger ones. + call taker (v%b) + if (.not. associated (pr, v%b)) stop 1 + if (.not. associated (ps, v(1:3:2)%b)) stop 2 + + ! Contiguous actual argument. + call taker (flat) + if (.not. associated (pr, flat)) stop 3 + if (.not. associated (ps, flat(1:3:2))) stop 4 + + ! A type whose element length need not divide the spacing. + call takec (w%z) + if (.not. associated (pc, w%z)) stop 5 + + ! Storage sequences that differ are still not associated. + call taker (v%b) + if (associated (pr, v(1:2)%b)) stop 6 + if (associated (pr, v(2:4)%b)) stop 7 + if (associated (pr, v%a)) stop 8 + if (associated (ps, v%b)) stop 9 + if (associated (ps, v(2:4:2)%b)) stop 10 + if (associated (pr, flat)) stop 11 +end program diff --git a/libgfortran/intrinsics/associated.c b/libgfortran/intrinsics/associated.c index fecc1b3a2832..5787d1c57e40 100644 --- a/libgfortran/intrinsics/associated.c +++ b/libgfortran/intrinsics/associated.c @@ -28,6 +28,25 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see extern int associated (const gfc_array_void *, const gfc_array_void *); export_proto(associated); +/* Return the spacing in bytes of the elements of DESC in dimension N. The + stride counts spans rather than elements, so descriptors that denote the + same storage sequence can hold different combinations of the two: elements + that are subobjects of larger ones are described either by the spacing of + the larger objects as the span, or by that spacing folded into the stride + with the element length as the span. The product is what the two have in + common. */ + +static inline index_type +stride_in_bytes (const gfc_array_void *desc, int n) +{ + index_type span = GFC_DESCRIPTOR_SPAN (desc); + + if (span == 0) + span = GFC_DESCRIPTOR_SIZE (desc); + + return GFC_DESCRIPTOR_STRIDE (desc, n) * span; +} + int associated (const gfc_array_void *pointer, const gfc_array_void *target) { @@ -37,7 +56,13 @@ associated (const gfc_array_void *pointer, const gfc_array_void *target) return 0; if (GFC_DESCRIPTOR_DATA (pointer) != GFC_DESCRIPTOR_DATA (target)) return 0; - if (GFC_DESCRIPTOR_SPAN (pointer) != GFC_DESCRIPTOR_SPAN (target)) + /* The element length is normally held by the dtype, but the descriptor + built for a polymorphic pointer to a character section holds the + spacing of the elements there instead, and carries the length + separately. Require the two to agree on one or the other: if they + agree on neither, the storage sequences differ. */ + if (GFC_DESCRIPTOR_SIZE (pointer) != GFC_DESCRIPTOR_SIZE (target) + && GFC_DESCRIPTOR_SPAN (pointer) != GFC_DESCRIPTOR_SPAN (target)) return 0; if (GFC_DESCRIPTOR_DTYPE (pointer).type != GFC_DESCRIPTOR_DTYPE (target).type) return 0; @@ -51,7 +76,8 @@ associated (const gfc_array_void *pointer, const gfc_array_void *target) if (extent != GFC_DESCRIPTOR_EXTENT(target,n)) return 0; - if (GFC_DESCRIPTOR_STRIDE(pointer,n) != GFC_DESCRIPTOR_STRIDE(target,n) && extent != 1) + if (stride_in_bytes (pointer, n) != stride_in_bytes (target, n) + && extent != 1) return 0; if (extent <= 0) return 0;
