From patchwork Fri Feb 16 21:40:15 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 85911 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id AA006385782D for ; Fri, 16 Feb 2024 21:41:05 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mout.gmx.net (mout.gmx.net [212.227.15.15]) by sourceware.org (Postfix) with ESMTPS id B1F763857735; Fri, 16 Feb 2024 21:40:16 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org B1F763857735 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=gmx.de Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=gmx.de ARC-Filter: OpenARC Filter v1.0.0 sourceware.org B1F763857735 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=212.227.15.15 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1708119620; cv=none; b=petApkLU17/O/N+XXKo6Mn2k4Xu2Yxn41YPVTI0eAxqWr26Pvyi8a4LaHlAlMizvV5e75o1zkAF80tWzwYXD8+0xyart5N5qupwb/zJ2qe1885f16HDNYETYkQFVX/EGKmzhY6fGKVfF5TNTnSOuG2up4qM0NhmGac/OoyYsgLw= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1708119620; c=relaxed/simple; bh=ekPv15ssWA3dlk89iUcEOProqWYnpz9FiUNW21cJdFY=; h=DKIM-Signature:MIME-Version:Message-ID:From:To:Subject:Date; b=oUw8E9HqziSjqoqln6FmY21azehMU3vq8Hy6xGfhVCiSJxnOmYnDDvg9DqSpG2/D0LHtBXv8w0AfRctVEV+d0l5hJ/gckMx8hErBWEDjMdY//pB4YsqRxx6N/A+XzTEOefsHZbnSNO+kaPpCHGq9wnhoqfp8qwUItukxmzDQvME= ARC-Authentication-Results: i=1; server2.sourceware.org DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=gmx.de; s=s31663417; t=1708119615; x=1708724415; i=anlauf@gmx.de; bh=ekPv15ssWA3dlk89iUcEOProqWYnpz9FiUNW21cJdFY=; h=X-UI-Sender-Class:From:To:Subject:Date; b=RvNf6JCv8VQGDfmXLxmepsNceWU1UEZanwlG9jzJVrK61KNXxN5dQBAd+RyYY8xU KLtu6vnL2laevNreHYmCD+n6qed3S8pi0zw51L4jfujBbA18xtiPah4f3w9zn4Ro5 j4vorDWEisuoJVLsJnpb0N3mowT0cMDi4cYH/9r/7d1Qc30KnTA3TLjPSv6717lqo MTVG4Vv20BAF+SVwYF3rLurcpHeu3JP1IVTYPc+z7SZHOQXVP8gIrP+GCXrx/xYCN mbH5huu4GlrVCXsQQ31sGYvY+CyerD5hWJDIK5Fq/b6ALy6UUb+YWPiLeWfjwVUea tK/j/FN2tJLdMrn72w== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [79.232.154.23] ([79.232.154.23]) by web-mail.gmx.net (3c-app-gmx-bs43.server.lan [172.19.170.95]) (via HTTP); Fri, 16 Feb 2024 22:40:15 +0100 MIME-Version: 1.0 Message-ID: From: Harald Anlauf To: fortran , gcc-patches Subject: [PATCH] Fortran: deferred length of character variables shall not get lost [PR113911] Date: Fri, 16 Feb 2024 22:40:15 +0100 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:sgqfG7cpiEDTFEJpOCG/7DXMR1HsuoDbvwt4q2GS5SiCzzygRvtVV5uXU3XUkDYErUKLd ITxfRsBac7VZDjUik/NQ05xpDZuUfHgz1JPGLQ9YCUEWwddvwh89ozJ/7ZoCK8C8s4cCwa+XOQME 5969GL1uApYjyHGbyb7nAlqM6gZCyZWHW8LQDiOt17a9uL9VFZHjmtfVnjLFyyR2YHYnVvv4ccnJ oWnW2RXdb1/uUz4Mtc/A7G0t8TvoP+yuUxJHSsNJHhk4tWhCUAhjNAdfcdY20OIhfXt/F77mreR5 FQ= UI-OutboundReport: notjunk:1;M01:P0:Jx92r7KW7Z4=;AXEzDIAivIIlD9OwfiphuesIrSe CJ/VzQQsZONPD7B+vvBn+vvcwnN5ZqMa6flEIwc5CVx1gzLWKErOqAp5oAJkg4sqbPcPt2tNk 3BWz98rqF0d9FRSHltim1NL9aAfafkLXFkZP+N9WSISlZ7OwQ4ImHS0zmcAPUKtr5TnQ/J4PR v8qH5mExK75FyrbEOK4GOVaIZcBXp29S9LBvEUbGQPKzaI6MmyEIAAdv5YdWhW10u5AnUv378 nBipa2tZckMLFRSNZqaJLhYYd/9vUWo4CYiCeb408eckSA/l5VvDRrzNam3kqn3BNBOomxXI2 bgxeMVVl3+16rVKBjFeJo6OHHHmct0IrHyrVpPNGErCPiGiqDsxApkZuczu5QGgfkQkzvialr AxhCJVdHypyezn8zqq4+V2Y6fRqGTCO5bc65mSQKvf6iRPqi9MEXGhuJZrPMbrz94a2RRgMqD 2zRS8pJrdglf8f/WUgD18U+iLzBY6MydKqHy7E5jCYf9y8rZJXgU4W+6O6YMUTzFDFioIsO2e u/9CIMUExHc+Gz6H8SKHgHjy+UXcz1sGyEiwe8LilU0+wamIhYhDb2TxqVsw2W0pvG80FARvM kMH8H5ks2ItONTxfau6dL5pRqF6aRh3iHvt/sEJW4upNFY83/GCn4k6HsMqq864V94pI67+AF hVe3j3/Scm+6IHwOZkZH/rdHW0twV4qIbjQ/inyHWYfW2bhqcoLmefGFpfI4ZOs= X-Spam-Status: No, score=-12.5 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H3, RCVD_IN_MSPIKE_WL, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Dear all, this patch fixes a regression which was a side-effect of r14-8947, losing the length of a deferred-length character variable when passed as a dummy. The new testcase provides a workout for deferred length to improve coverage in the testsuite. Another temporarily disabled test was re-enabled. Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald 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