https://gcc.gnu.org/g:603b344c07aa55f8292446e8fd28f5da9a983a21
commit r14-10364-g603b344c07aa55f8292446e8fd28f5da9a983a21 Author: Harald Anlauf <anl...@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