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.

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 93b633e212e49dd9a41c5de2928c7fc020f7a3f6..60275e18867692fef755251e6c37fc7b907309b4 100644 (file)
--- 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 (file)
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