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.

2 files changed, 108 insertions, 2 deletions

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 0000000..2fd64ef
--- /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 ceedef7..8bbdc95 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 ()