Fortran: fix ALLOCATE with SOURCE of deferred character length [PR114019]

gcc/fortran/ChangeLog:

	PR fortran/114019
	* trans-stmt.cc (gfc_trans_allocate): Fix handling of case of
	scalar character expression being used for SOURCE.

gcc/testsuite/ChangeLog:

	PR fortran/114019
	* gfortran.dg/allocate_with_source_33.f90: New test.

2 files changed, 73 insertions, 1 deletions

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 93b633e..60275e1 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6464,7 +6464,10 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
       else if (se.expr != NULL_TREE && temp_var_needed)
 	{
 	  tree var, desc;
-	  tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) || is_coarray ?
+	  tmp = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
+		 || is_coarray
+		 || (code->expr3->ts.type == BT_CHARACTER
+		     && code->expr3->rank == 0)) ?
 		se.expr
 	      : build_fold_indirect_ref_loc (input_location, se.expr);
 
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_33.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_33.f90
new file mode 100644
index 0000000..43a0362
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_33.f90
@@ -0,0 +1,69 @@
+! { dg-do compile }
+! { dg-options "-O0" }
+!
+! PR fortran/114019 - allocation with source of deferred character length
+
+subroutine s
+  implicit none
+  character(1)              :: w   = "4"
+  character(*), parameter   :: str = "123"
+  character(5), pointer     :: chr_pointer1
+  character(:), pointer     :: chr_pointer2
+  character(:), pointer     :: chr_ptr_arr(:)
+  character(5), allocatable :: chr_alloc1
+  character(:), allocatable :: chr_alloc2
+  character(:), allocatable :: chr_all_arr(:)
+  allocate (chr_pointer1, source=w// str//w)
+  allocate (chr_pointer2, source=w// str//w)
+  allocate (chr_ptr_arr,  source=w//[str//w])
+  allocate (chr_alloc1,   source=w// str//w)
+  allocate (chr_alloc2,   source=w// str//w)
+  allocate (chr_all_arr,  source=w//[str//w])
+  allocate (chr_pointer2, source=str)
+  allocate (chr_pointer2, source=w)
+  allocate (chr_alloc2,   source=str)
+  allocate (chr_alloc2,   source=w)
+  allocate (chr_pointer1, mold  =w// str//w)
+  allocate (chr_pointer2, mold  =w// str//w)
+  allocate (chr_ptr_arr,  mold  =w//[str//w])
+  allocate (chr_alloc1,   mold  =w// str//w)
+  allocate (chr_alloc2,   mold  =w// str//w)
+  allocate (chr_all_arr,  mold  =w//[str//w])
+  allocate (chr_pointer2, mold  =str)
+  allocate (chr_pointer2, mold  =w)
+  allocate (chr_alloc2,   mold  =str)
+  allocate (chr_alloc2,   mold  =w)
+end
+
+subroutine s2
+  implicit none
+  integer, parameter :: ck=4
+  character(kind=ck,len=1)              :: w   = ck_"4"
+  character(kind=ck,len=*), parameter   :: str = ck_"123"
+  character(kind=ck,len=5), pointer     :: chr_pointer1
+  character(kind=ck,len=:), pointer     :: chr_pointer2
+  character(kind=ck,len=:), pointer     :: chr_ptr_arr(:)
+  character(kind=ck,len=5), allocatable :: chr_alloc1
+  character(kind=ck,len=:), allocatable :: chr_alloc2
+  character(kind=ck,len=:), allocatable :: chr_all_arr(:)
+  allocate (chr_pointer1, source=w// str//w)
+  allocate (chr_pointer2, source=w// str//w)
+  allocate (chr_ptr_arr,  source=w//[str//w])
+  allocate (chr_alloc1,   source=w// str//w)
+  allocate (chr_alloc2,   source=w// str//w)
+  allocate (chr_all_arr,  source=w//[str//w])
+  allocate (chr_pointer2, source=str)
+  allocate (chr_pointer2, source=w)
+  allocate (chr_alloc2,   source=str)
+  allocate (chr_alloc2,   source=w)
+  allocate (chr_pointer1, mold  =w// str//w)
+  allocate (chr_pointer2, mold  =w// str//w)
+  allocate (chr_ptr_arr,  mold  =w//[str//w])
+  allocate (chr_alloc1,   mold  =w// str//w)
+  allocate (chr_alloc2,   mold  =w// str//w)
+  allocate (chr_all_arr,  mold  =w//[str//w])
+  allocate (chr_pointer2, mold  =str)
+  allocate (chr_pointer2, mold  =w)
+  allocate (chr_alloc2,   mold  =str)
+  allocate (chr_alloc2,   mold  =w)
+end