Dear All, the attached patch is the result of several long debugging sessions trying to find out why deferred-length character arrays were mistreated. It turned out that when deriving the dataptr offset in the array descriptor, for fixed length the element size takes into account the known string length, while for deferred-length it is taken from the underlying type. We thus need to fix that and multiply the offset by the length.
While developing the testcase, I noticed that not only write statements are affected by this issue as in the original PR, but also pointer association. I thus tried to exercise positive and negative and non-unit strides. Testcase cross-checked with NAG. And it runs clean under valgrind. ;-) Regtested on x86_64-pc-linux-gnu. OK for mainline? And if it survives for some time, backport to 15-branch? Thanks, Harald
From a6ace3a05e41fea7fcbdf4310f24fcfe6412f811 Mon Sep 17 00:00:00 2001 From: Harald Anlauf <[email protected]> Date: Sat, 20 Sep 2025 22:20:25 +0200 Subject: [PATCH] Fortran: fix issues with rank-2 deferred-length character arrays [PR108581] PR fortran/108581 gcc/fortran/ChangeLog: * trans-array.cc (gfc_conv_expr_descriptor): Take the dynamic string length into account when deriving the dataptr offset for a deferred-length character array. gcc/testsuite/ChangeLog: * gfortran.dg/deferred_character_39.f90: New test. --- gcc/fortran/trans-array.cc | 12 + .../gfortran.dg/deferred_character_39.f90 | 223 ++++++++++++++++++ 2 files changed, 235 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/deferred_character_39.f90 diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index abde05f5dde..b9bbf5c4666 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -8912,6 +8912,18 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_rank_cst[dim], stride); } + /* For deferred-length character we need to take the dynamic length + into account for the dataptr offset. */ + if (expr->ts.type == BT_CHARACTER + && expr->ts.deferred + && expr->ts.u.cl->backend_decl) + { + tree base_type = TREE_TYPE (base); + base = fold_build2_loc (input_location, MULT_EXPR, base_type, base, + fold_convert (base_type, + expr->ts.u.cl->backend_decl)); + } + for (n = loop.dimen; n < loop.dimen + codim; n++) { from = loop.from[n]; diff --git a/gcc/testsuite/gfortran.dg/deferred_character_39.f90 b/gcc/testsuite/gfortran.dg/deferred_character_39.f90 new file mode 100644 index 00000000000..315e3b947dc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_39.f90 @@ -0,0 +1,223 @@ +! { dg-do run } +! PR fortran/108581 - issues with rank-2 deferred-length character arrays + +program p + call pr108581 + call test2 +end + +! Derived from original testcase +subroutine pr108581 + integer, parameter :: xmin = 0, xmax = 0 + integer, parameter :: ymin = 0, ymax = 1 + integer, parameter :: l = 2 + integer :: x, y + character(8) :: line1, line2, line3 + character(*), parameter :: expect(ymin:ymax) = ['A.','B*'] + character(len=:), pointer :: a(:,:) => NULL() + + allocate (character(len=l) :: a(xmin:xmax, ymin:ymax)) + a(xmin:xmax, ymin) = expect(ymin) + a(xmin:xmax, ymax) = expect(ymax) + + do y = ymin, ymax + write(line1,'(4A)') (a(x, y), x = xmin, xmax) + write(line2,'(4A)') a(xmin:xmax, y) + write(line3,'(4A)') a( : , y) + if (line1 /= expect(y) .or. & + line2 /= expect(y) .or. & + line3 /= expect(y) ) then + write(*,*) (a(x, y), x = xmin, xmax) + write(*,*) a(xmin:xmax, y) + write(*,*) a( : , y) + stop 1 + y + end if + enddo + deallocate (a) +end + +! Exercise character kinds, strides, ... +subroutine test2 + implicit none + integer, parameter :: l = 3 + integer :: i + + character(len=l,kind=1), parameter :: str1(*) = & + [ "123", "456", "789", "0AB" ] + character(len=l,kind=4), parameter :: str4(*) = & + [ 4_"123", 4_"456", 4_"789", 4_"0AB" ] + + character(len=l,kind=1), parameter :: str2(*,*) = & + reshape ([(str1(i),str1(5-i),i=1,4)], shape=[2,4]) + character(len=l,kind=4), parameter :: str5(*,*) = & + reshape ([(str4(i),str4(5-i),i=1,4)], shape=[2,4]) + + character(len=l,kind=1), pointer :: a(:,:) => NULL(), e(:,:) => NULL() + character(len=:,kind=1), pointer :: b(:,:) => NULL(), f(:,:) => NULL() + character(len=l,kind=4), pointer :: c(:,:) => NULL(), g(:,:) => NULL() + character(len=:,kind=4), pointer :: d(:,:) => NULL(), h(:,:) => NULL() + + character(len=16) :: s0, s1, s2, s3, s4 + + ! Simple case: shape=[1,4] + allocate (a, source = reshape (str1,[1,size(str1)])) + allocate (b, source = reshape (str1,[1,size(str1)])) + allocate (c, source = reshape (str4,[1,size(str4)])) +! allocate (d, source=c) ! ICE, tracked as pr121939 + d => c + ! Positive non-unit stride + s0 = concat (str1(1::2)) + write(s1,'(4A)') a(1,1::2) + write(s2,'(4A)') b(1,1::2) + write(s3,'(4A)') c(1,1::2) + write(s4,'(4A)') d(1,1::2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 11 + if (s2 /= s0) stop 12 + if (s3 /= s0) stop 13 + if (s4 /= s0) stop 14 + s0 = concat (str1(2::2)) + write(s1,'(4A)') a(1,2::2) + write(s2,'(4A)') b(1,2::2) + write(s3,'(4A)') c(1,2::2) + write(s4,'(4A)') d(1,2::2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 15 + if (s2 /= s0) stop 16 + if (s3 /= s0) stop 17 + if (s4 /= s0) stop 18 + + ! Negative non-unit stride + s0 = concat (str1(3:1:-2)) + write(s1,'(4A)') a(1,3:1:-2) + write(s2,'(4A)') b(1,3:1:-2) + write(s3,'(4A)') c(1,3:1:-2) + write(s4,'(4A)') d(1,3:1:-2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 21 + if (s2 /= s0) stop 22 + if (s3 /= s0) stop 23 + if (s4 /= s0) stop 24 + s0 = concat (str1(4:1:-2)) + write(s1,'(4A)') a(1,4:1:-2) + write(s2,'(4A)') b(1,4:1:-2) + write(s3,'(4A)') c(1,4:1:-2) + write(s4,'(4A)') d(1,4:1:-2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 25 + if (s2 /= s0) stop 26 + if (s3 /= s0) stop 27 + if (s4 /= s0) stop 28 + deallocate (a,b,c) + + ! More complex cases with shape=[2,4] + allocate (e, source = reshape (str2,[2,size(str2,2)])) + allocate (f, source = reshape (str2,[2,size(str2,2)])) + allocate (g, source = reshape (str5,[2,size(str5,2)])) + h => g + s0 = concat (str2(1,3:1:-2)) + write(s1,'(4A)') e(1,3:1:-2) + write(s2,'(4A)') f(1,3:1:-2) + write(s3,'(4A)') g(1,3:1:-2) + write(s4,'(4A)') h(1,3:1:-2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 31 + if (s2 /= s0) stop 32 + if (s3 /= s0) stop 33 + if (s4 /= s0) stop 34 + s0 = concat (str2(1,4:1:-2)) + write(s1,'(4A)') e(1,4:1:-2) + write(s2,'(4A)') f(1,4:1:-2) + write(s3,'(4A)') g(1,4:1:-2) + write(s4,'(4A)') h(1,4:1:-2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 35 + if (s2 /= s0) stop 36 + if (s3 /= s0) stop 37 + if (s4 /= s0) stop 38 + + s0 = concat (str2(2,3:1:-2)) + write(s1,'(4A)') e(2,3:1:-2) + write(s2,'(4A)') f(2,3:1:-2) + write(s3,'(4A)') g(2,3:1:-2) + write(s4,'(4A)') h(2,3:1:-2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 41 + if (s2 /= s0) stop 42 + if (s3 /= s0) stop 43 + if (s4 /= s0) stop 44 + s0 = concat (str2(2,4:1:-2)) + write(s1,'(4A)') e(2,4:1:-2) + write(s2,'(4A)') f(2,4:1:-2) + write(s3,'(4A)') g(2,4:1:-2) + write(s4,'(4A)') h(2,4:1:-2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 45 + if (s2 /= s0) stop 46 + if (s3 /= s0) stop 47 + if (s4 /= s0) stop 48 + + ! Check pointer association with negative stride + a => e(2:1:-1,4:1:-1) + b => f(2:1:-1,4:1:-1) + c => g(2:1:-1,4:1:-1) + d => h(2:1:-1,4:1:-1) + + s0 = concat (str2(2,4:1:-2)) + write(s1,'(4A)') a(1,1::2) + write(s2,'(4A)') b(1,1::2) + write(s3,'(4A)') c(1,1::2) + write(s4,'(4A)') d(1,1::2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 51 + if (s2 /= s0) stop 52 + if (s3 /= s0) stop 53 + if (s4 /= s0) stop 54 + s0 = concat (str2(2,3:1:-2)) + write(s1,'(4A)') a(1,2::2) + write(s2,'(4A)') b(1,2::2) + write(s3,'(4A)') c(1,2::2) + write(s4,'(4A)') d(1,2::2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 55 + if (s2 /= s0) stop 56 + if (s3 /= s0) stop 57 + if (s4 /= s0) stop 58 + + s0 = concat (str2(1,4:1:-2)) + write(s1,'(4A)') a(2,1::2) + write(s2,'(4A)') b(2,1::2) + write(s3,'(4A)') c(2,1::2) + write(s4,'(4A)') d(2,1::2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 61 + if (s2 /= s0) stop 62 + if (s3 /= s0) stop 63 + if (s4 /= s0) stop 64 + s0 = concat (str2(1,3:1:-2)) + write(s1,'(4A)') a(2,2::2) + write(s2,'(4A)') b(2,2::2) + write(s3,'(4A)') c(2,2::2) + write(s4,'(4A)') d(2,2::2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 65 + if (s2 /= s0) stop 66 + if (s3 /= s0) stop 67 + if (s4 /= s0) stop 68 + deallocate (e,f,g) + +contains + + ! Helper function to concatenate string array to scalar string + function concat (s) + character(len=:), allocatable :: concat + character(len=*), intent(in) :: s(:) + integer :: i, l, n + n = size (s) + l = len (s) + allocate (character(len=l*n) :: concat) + do i = 1, n + concat(1+(i-1)*l:i*l) = s(i) + end do + end function concat +end -- 2.51.0
