https://gcc.gnu.org/g:5e8f400f12c27a5c8c0bacc6ac5975c94274db1e
commit r17-3954-g5e8f400f12c27a5c8c0bacc6ac5975c94274db1e Author: Jerry DeLisle <[email protected]> Date: Tue Sep 1 10:50:00 2026 -0700 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. Assisted-by: Claude Opus 5 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 | 21 ++++++- 2 files changed, 89 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..d9ffddd8055c 100644 --- a/libgfortran/intrinsics/associated.c +++ b/libgfortran/intrinsics/associated.c @@ -28,6 +28,18 @@ 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); +/* If the stride is not set, use the element length. */ +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,8 +49,12 @@ 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)) + + /* Require that the storage sequences are the same. */ + 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; rank = GFC_DESCRIPTOR_RANK (pointer); @@ -51,7 +67,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;
