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: 202375 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a05:693c:2685:b0:108:e6aa:91d0 with SMTP id mn5csp6759dyc; Fri, 16 Feb 2024 13:41:19 -0800 (PST) X-Forwarded-Encrypted: i=3; AJvYcCVS0afptF7wlTC2c5L+mDEGraAaMB5nPetoeOcZ8ekhHjyBDAAHeFXd8KUgO1mC7Ri/6XuoJ+w0rd5eH9jancx6CQa2nA== X-Google-Smtp-Source: AGHT+IHm7ykwJ7uWvVd9EmK2NuRzAeuNS+arApSEUHIsy3F61Dbod4EB71jvPdlIj7yRWHiELGQ2 X-Received: by 2002:a05:6808:1a06:b0:3c1:3bdb:f165 with SMTP id bk6-20020a0568081a0600b003c13bdbf165mr5229777oib.11.1708119678972; Fri, 16 Feb 2024 13:41:18 -0800 (PST) ARC-Seal: i=2; a=rsa-sha256; t=1708119678; cv=pass; d=google.com; s=arc-20160816; b=dKfRQ0M7Q9q5yQlvA0LGJ3mHm/i2iJ4LXumklKLET4syOZzuHa4eoXFeUuoaT0OeuR d8etRMFsA2VjmuqBPzM26RfH1EA7DhQiMJXih+1vfoaHjyg9KosHjO+7MgAoAx2J3hJ9 0f4xY/wjkqYGqkTuBEAsr/AujNb1f/teodXbMFdvVDqflkx4fZ/1nEe9fPpYvT/M9p5u QTkpqiBQcpQ1gblnoLRQP7E95uAJ2o2imPOW2DjfI4gQsZifliRDi0/48TxHfYvqkU76 q48wsL/RSKRPyxunM7S75mrBIXQgCmwXqY3jHs5Alz6FvoL0y86nYCXEwqekOG/BY/Wg bTHg== ARC-Message-Signature: i=2; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=errors-to:list-subscribe:list-help:list-post:list-archive :list-unsubscribe:list-id:precedence:ui-outboundreport:sensitivity :importance:date:subject:to:from:message-id:mime-version :dkim-signature:arc-filter:dmarc-filter:delivered-to; bh=wJZG7l+WtNOtdvUctMLgRiRhRXEmzfbh9mNT3FN45lE=; fh=+IEfvAe+9BRgPHWhQEl2uIBTtAiiGDh1ExRZeB5JJoc=; b=U0arwFzQ/eFYTrHEoSaVg9oOUKn78byKiZyt5tzZEiPot19WQWEsE/BfNfrc8mULy7 XUtR6nQrJa8/g6oLv9RhZha9GiGTyvYqVanCg9vr9TDkmsC3um/R9bjHGSr7y6DJUuEZ Kvg1yLeHCnfScmglJ/cf/cyBZBP+FyjMZ/keL7T3/9Q42SZJJMWenJGbaJDa1bss+RkA +fsoI29yEv5bNH6jKgQM7lZWkcLprQjO+27yCg3Q9a7rQWpEEJALu22xC8dlHNy/WaPT oYe0ve4oqTWq7M1EKBDjJjCzuKYxLFOq0Hre//KV3EvMoKcYer3gnyE9AykRiopZGLC6 x/Ig==; dara=google.com ARC-Authentication-Results: i=2; mx.google.com; dkim=pass header.i=@gmx.de header.s=s31663417 header.b=RvNf6JCv; arc=pass (i=1); spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=QUARANTINE sp=QUARANTINE dis=NONE) header.from=gmx.de Received: from server2.sourceware.org (server2.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id if14-20020a0562141c4e00b0068f031a6c3bsi700870qvb.231.2024.02.16.13.41.18 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Fri, 16 Feb 2024 13:41:18 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) client-ip=8.43.85.97; Authentication-Results: mx.google.com; dkim=pass header.i=@gmx.de header.s=s31663417 header.b=RvNf6JCv; arc=pass (i=1); spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=QUARANTINE sp=QUARANTINE dis=NONE) header.from=gmx.de Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id A399F385782D for ; Fri, 16 Feb 2024 21:41:18 +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+ouuuleilei=gmail.com@gcc.gnu.org X-getmail-retrieved-from-mailbox: INBOX X-GMAIL-THRID: 1791093300032041062 X-GMAIL-MSGID: 1791093300032041062 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