From 07fcdf7c9f9272d8e4752c23f04795d02d4ad440 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Fri, 16 Feb 2024 22:33:16 +0100 Subject: [PATCH] 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. --- gcc/fortran/trans-array.cc | 2 +- .../gfortran.dg/allocatable_length_2.f90 | 107 ++++++++++++++++++ .../gfortran.dg/bind_c_optional-2.f90 | 3 +- 3 files changed, 109 insertions(+), 3 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/allocatable_length_2.f90 diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 2181990aa04..3673fa40720 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -11531,7 +11531,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) { - if (sym->ts.deferred && !sym->ts.u.cl->length) + if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy) gfc_add_modify (&init, sym->ts.u.cl->backend_decl, build_zero_cst (TREE_TYPE (sym->ts.u.cl->backend_decl))); gfc_conv_string_length (sym->ts.u.cl, NULL, &init); 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 00000000000..2fd64efdc25 --- /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 ceedef7f006..8bbdc95c6cd 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 () -- 2.35.3