[PATCH] Fortran: deferred length of character variables shall not get lost [PR113911]

[Harald Anlauf <anlauf@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 376 bytes --]

Dear all,

this patch fixes a regression which was a side-effect of r14-8947,
losing the length of a deferred-length character variable when
passed as a dummy.

The new testcase provides a workout for deferred length to improve
coverage in the testsuite.  Another temporarily disabled test was
re-enabled.

Regtested on x86_64-pc-linux-gnu.  OK for mainline?

Thanks,
Harald


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr113911.diff --]
[-- Type: text/x-patch, Size: 5692 bytes --]

From 07fcdf7c9f9272d8e4752c23f04795d02d4ad440 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Fri, 16 Feb 2024 22:33:16 +0100
Subject: [PATCH] Fortran: deferred length of character variables shall not get
 lost [PR113911]

	PR fortran/113911

gcc/fortran/ChangeLog:

	* trans-array.cc (gfc_trans_deferred_array): Do not clobber
	deferred length for a character variable passed as dummy argument.

gcc/testsuite/ChangeLog:

	* gfortran.dg/allocatable_length_2.f90: New test.
	* gfortran.dg/bind_c_optional-2.f90: Enable deferred-length test.
---
 gcc/fortran/trans-array.cc                    |   2 +-
 .../gfortran.dg/allocatable_length_2.f90      | 107 ++++++++++++++++++
 .../gfortran.dg/bind_c_optional-2.f90         |   3 +-
 3 files changed, 109 insertions(+), 3 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/allocatable_length_2.f90

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 2181990aa04..3673fa40720 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -11531,7 +11531,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
   if (sym->ts.type == BT_CHARACTER
       && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
     {
-      if (sym->ts.deferred && !sym->ts.u.cl->length)
+      if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy)
 	gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
 			build_zero_cst (TREE_TYPE (sym->ts.u.cl->backend_decl)));
       gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
diff --git a/gcc/testsuite/gfortran.dg/allocatable_length_2.f90 b/gcc/testsuite/gfortran.dg/allocatable_length_2.f90
new file mode 100644
index 00000000000..2fd64efdc25
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocatable_length_2.f90
@@ -0,0 +1,107 @@
+! { dg-do run }
+! PR fortran/113911
+!
+! Test that deferred length is not lost
+
+module m
+  integer, parameter        :: n = 100, l = 10
+  character(l)              :: a = 'a234567890', b(n) = 'bcdefghijk'
+  character(:), allocatable :: c1, c2(:)
+end
+
+program p
+  use m, only : l, n, a, b, x => c1, y => c2
+  implicit none
+  character(:), allocatable :: d, e(:)
+  allocate (d, source=a)
+  allocate (e, source=b)
+  if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 12
+  call plain_deferred (d, e)
+  call optional_deferred (d, e)
+  call optional_deferred_ar (d, e)
+  if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 13
+  deallocate (d, e)
+  call alloc (d, e)
+  if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 14
+  deallocate (d, e)
+  call alloc_host_assoc ()
+  if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 15
+  deallocate (d, e)
+  call alloc_use_assoc ()
+  if (len (x) /= l .or. len (y) /= l .or. size (y) /= n) stop 16
+  call indirect (x, y)
+  if (len (x) /= l .or. len (y) /= l .or. size (y) /= n) stop 17
+  deallocate (x, y)
+contains
+  subroutine plain_deferred (c1, c2)
+    character(:), allocatable :: c1, c2(:)
+    if (.not. allocated (c1) .or. .not. allocated (c2)) stop 1
+    if (len (c1) /= l) stop 2
+    if (len (c2) /= l) stop 3
+    if (c1(1:3)    /= "a23") stop 4
+    if (c2(5)(1:3) /= "bcd") stop 5
+  end
+
+  subroutine optional_deferred (c1, c2)
+    character(:), allocatable, optional :: c1, c2(:)
+    if (.not. present   (c1) .or. .not. present   (c2)) stop 6
+    if (.not. allocated (c1) .or. .not. allocated (c2)) stop 7
+    if (len (c1) /= l) stop 8
+    if (len (c2) /= l) stop 9
+    if (c1(1:3)    /= "a23") stop 10
+    if (c2(5)(1:3) /= "bcd") stop 11
+  end
+
+  ! Assumed rank
+  subroutine optional_deferred_ar (c1, c2)
+    character(:), allocatable, optional :: c1(..)
+    character(:), allocatable, optional :: c2(..)
+    if (.not. present   (c1) .or. &
+        .not. present   (c2)) stop 21
+    if (.not. allocated (c1) .or. &
+        .not. allocated (c2)) stop 22
+
+    select rank (c1)
+    rank (0)
+    if (len (c1) /= l)       stop 23
+      if (c1(1:3)  /= "a23") stop 24
+    rank default
+      stop 25
+    end select
+
+    select rank (c2)
+    rank (1)
+      if (len (c2) /= l)       stop 26
+      if (c2(5)(1:3) /= "bcd") stop 27
+    rank default
+      stop 28
+    end select
+  end
+
+  ! Allocate dummy arguments
+  subroutine alloc (c1, c2)
+    character(:), allocatable :: c1, c2(:)
+    allocate (c1, source=a)
+    allocate (c2, source=b)
+  end
+
+  ! Allocate host-associated variables
+  subroutine alloc_host_assoc ()
+    allocate (d, source=a)
+    allocate (e, source=b)
+  end
+
+  ! Allocate use-associated variables
+  subroutine alloc_use_assoc ()
+    allocate (x, source=a)
+    allocate (y, source=b)
+  end
+
+  ! Pass-through deferred-length
+  subroutine indirect (c1, c2)
+    character(:), allocatable :: c1, c2(:)
+    call plain_deferred (c1, c2)
+    call optional_deferred (c1, c2)
+    call optional_deferred_ar (c1, c2)
+  end
+end
diff --git a/gcc/testsuite/gfortran.dg/bind_c_optional-2.f90 b/gcc/testsuite/gfortran.dg/bind_c_optional-2.f90
index ceedef7f006..8bbdc95c6cd 100644
--- a/gcc/testsuite/gfortran.dg/bind_c_optional-2.f90
+++ b/gcc/testsuite/gfortran.dg/bind_c_optional-2.f90
@@ -97,8 +97,7 @@ program p
   call bindc_optional (d, e)
   call not_bindc_optional2 (d, e)
   call bindc_optional2 (d, e)
-  ! following test disabled due to pr113911
-! call not_bindc_optional_deferred (d, e)
+  call not_bindc_optional_deferred (d, e)
   deallocate (d, e)
   call non_bindc_optional_missing ()
   call bindc_optional_missing ()
--
2.35.3