From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 2071) id 56A773858D39; Sat, 17 Feb 2024 14:07:29 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 56A773858D39 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1708178849; bh=Wk6XoAlOXqWDE1NZKuThP03L0w8vG4xyml8YQXMHknI=; h=From:To:Subject:Date:From; b=jS9gT1QQPHiTrRIJj/umSo0KIFEf2B2I/Zp6Z+wzEkZAgiLfokCvpBpd/kbs3YEcB Kxy8nwPN67x3/tMuyOE8O9CWh61OMWwnzzDPc6zB8+adqF1sbvNvaE2Vh0tVZjXBRv ZTId/h5ETrRXfDuWWrIFUM6G3eDRIHuChWpYeIX4= MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Harald Anlauf To: gcc-cvs@gcc.gnu.org Subject: [gcc r14-9045] Fortran: deferred length of character variables shall not get lost [PR113911] X-Act-Checkin: gcc X-Git-Author: Harald Anlauf X-Git-Refname: refs/heads/master X-Git-Oldrev: e16f90be2dc8af6c371fe79044c3e668fa3dda62 X-Git-Newrev: 76aac40f5ecbc9cfb3b8734d181599e1b5a24bdf Message-Id: <20240217140729.56A773858D39@sourceware.org> Date: Sat, 17 Feb 2024 14:07:29 +0000 (GMT) List-Id: https://gcc.gnu.org/g:76aac40f5ecbc9cfb3b8734d181599e1b5a24bdf commit r14-9045-g76aac40f5ecbc9cfb3b8734d181599e1b5a24bdf Author: Harald Anlauf Date: Fri Feb 16 22:33:16 2024 +0100 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. Diff: --- gcc/fortran/trans-array.cc | 2 +- gcc/testsuite/gfortran.dg/allocatable_length_2.f90 | 107 +++++++++++++++++++++ gcc/testsuite/gfortran.dg/bind_c_optional-2.f90 | 3 +- 3 files changed, 109 insertions(+), 3 deletions(-) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 2181990aa04a..3673fa407208 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 000000000000..2fd64efdc251 --- /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 ceedef7f0064..8bbdc95c6cdb 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 ()