Am 21.09.25 um 00:18 schrieb Jerry D:
On 9/20/25 1:34 PM, Harald Anlauf wrote:
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
Yes, OK for mainline and backport as you see.
Thanks for the review!
After submission, I figured that I should also check the case
of a deferred-length pointer dummy, which did not work with
the first patch version. An obvious one-line correction to
the relevant condition fixed that. Testcase extended.
Pushed attached as r16-4006-g749af11149623d.
Harald
Jerry
From 749af11149623dbf9ba026fd98bd7f31409fdaed Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
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 | 13 +
.../gfortran.dg/deferred_character_39.f90 | 239 ++++++++++++++++++
2 files changed, 252 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..0111c9566f4 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8912,6 +8912,19 @@ 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
+ && VAR_P (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..564f94bb9bd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/deferred_character_39.f90
@@ -0,0 +1,239 @@
+! { 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
+ call chk (a)
+ deallocate (a)
+contains
+ subroutine chk (z)
+ character(len=:), pointer :: z(:,:)
+ integer :: y
+ do y = lbound(z,2), ubound (z,2)
+ write(line2,'(4A)') z(xmin:xmax, y)
+ write(line3,'(4A)') z( : , y)
+ if (line2 /= expect(y) .or. &
+ line3 /= expect(y) ) then
+ write(*,*) z(xmin:xmax, y)
+ write(*,*) z( : , y)
+ stop 5 + y
+ end if
+ enddo
+ end subroutine chk
+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
