[gcc r14-10364] Fortran: fix ALLOCATE with SOURCE of deferred character length [PR114019]

[Harald Anlauf]

https://gcc.gnu.org/g:603b344c07aa55f8292446e8fd28f5da9a983a21

commit r14-10364-g603b344c07aa55f8292446e8fd28f5da9a983a21
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Fri Jun 28 21:44:06 2024 +0200

    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.
    
    (cherry picked from commit 7682d115402743090f20aca63a3b5e6c205dedff)

Diff:
---
 gcc/fortran/trans-stmt.cc                          |  5 +-
 .../gfortran.dg/allocate_with_source_33.f90        | 69 ++++++++++++++++++++++
 2 files changed, 73 insertions(+), 1 deletion(-)

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 87dd833872a..1fd75c6a37c 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 00000000000..43a03625950
--- /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