[gcc r14-9045] Fortran: deferred length of character variables shall not get lost [PR113911]

[gcc r14-9045] Fortran: deferred length of character variables shall not get lost [PR113911]

[Harald Anlauf]

https://gcc.gnu.org/g:76aac40f5ecbc9cfb3b8734d181599e1b5a24bdf

commit r14-9045-g76aac40f5ecbc9cfb3b8734d181599e1b5a24bdf
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Fri Feb 16 22:33:16 2024 +0100

    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.

Diff:
---
 gcc/fortran/trans-array.cc                         |   2 +-
 gcc/testsuite/gfortran.dg/allocatable_length_2.f90 | 107 +++++++++++++++++++++
 gcc/testsuite/gfortran.dg/bind_c_optional-2.f90    |   3 +-
 3 files changed, 109 insertions(+), 3 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 2181990aa04a..3673fa407208 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 000000000000..2fd64efdc251
--- /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 ceedef7f0064..8bbdc95c6cdb 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 ()