From patchwork Thu Jan 25 21:26:45 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 1891032 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=gmx.de header.i=anlauf@gmx.de header.a=rsa-sha256 header.s=s31663417 header.b=fFnGOG1d; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4TLYnL1F61z23dy for ; Fri, 26 Jan 2024 08:27:16 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id E96653858D38 for ; Thu, 25 Jan 2024 21:27:12 +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.19]) by sourceware.org (Postfix) with ESMTPS id 2669B3858D28; Thu, 25 Jan 2024 21:26:47 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 2669B3858D28 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 2669B3858D28 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=212.227.15.19 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1706218009; cv=none; b=fIIuDEl+4ODbKQ4RNUimFPYdPsgTIzSINyh8wTY/tv7lT+hGsd8emrYTUHqzw/7PtzRFjoRK7K/8nZmh0SrooTDa5+oiF++BSEUm2RbtNWPHlCSzVKsOfBJFR8aHbIuLDn1AYaJgbfn3DAJbGGXI0Tc9wEY8KaoGRHRyNgqtevg= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1706218009; c=relaxed/simple; bh=xD3HHf84sA4LRTHgc7koIAliFmu4LPtakvcmhhTZDY0=; h=DKIM-Signature:MIME-Version:Message-ID:From:To:Subject:Date; b=Hzg8P7Ubj8zC+AKc15QS112IZFFcYknCyQv1k3ubkPHElzby8XJXFq32xBzgow4anrJ8Hi/7dIrarLkYSSvL9nRzlCuQn753hf6JoBYxVCvAP0vETN+y8XG/M5rIRWFSHdRG/mIVlTYsKrpM2qO3XPYUs98ImUCSLlacXO/nCbQ= ARC-Authentication-Results: i=1; server2.sourceware.org DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=gmx.de; s=s31663417; t=1706218005; x=1706822805; i=anlauf@gmx.de; bh=xD3HHf84sA4LRTHgc7koIAliFmu4LPtakvcmhhTZDY0=; h=X-UI-Sender-Class:From:To:Subject:Date; b=fFnGOG1dKpBhh3gRyTplCWG/U1kcyz9CvnRKPI0gBpvDmw6oGW88uHWQiZ7NoIhJ ZbFOycmmM+ahl+DGq8qSEZ4/MRLUF3g5v08aoXWvMLjy/reMU+c3CVSekMgXeWCMo 3k6ZpFjWH1C66hDoEPCUvxcBho5eV3dfJwOOnXY5GE2YOvVOw4aiwJt27MQ56WUxq bl91SU/DwL01uKA/I914azsfs9krT6AjB3hF30QWmYNIohNfmqcolfWlDLvlJwIxu MtI5JlH/b9gY4La/xFV+PFpS85VTjJyv+849TWulyInxcL6mgehnZGJn0cmGwFQ+8 uB7U8Br5rlhv2XBTUA== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [93.207.81.161] ([93.207.81.161]) by web-mail.gmx.net (3c-app-gmx-bs25.server.lan [172.19.170.77]) (via HTTP); Thu, 25 Jan 2024 22:26:45 +0100 MIME-Version: 1.0 Message-ID: From: Harald Anlauf To: fortran , gcc-patches Subject: [PATCH] Fortran: NULL actual to optional dummy with VALUE attribute [PR113377] Date: Thu, 25 Jan 2024 22:26:45 +0100 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:PDax7ZcQgrT5OT2e9Ls4JF/vMNw6cfx/2iJYBut/2oFVeV7tteT5B6fmzMspMfrlZPCEH qzfhkSOPSLz4T8sgFLwS0HRRnfvQuidV1yYJlq8sbCt1aIbTr8Mkzr/9iwY71riPZVY176jeSmhl Jk/KhEvkP0gFOq8MdPaBV1yXR8f2BnKpKokCK+PnENuX7mpqcSJYRUYeN777eKsuRW+Ujd/ejH6+ NCfOVxe0eyvLTDi7ThLLq4s5QGCzk+0MnE/uT0jYbUPthq3Ez2Hyr6utXQjdQz/dHe1W0uDcuARH 9E= UI-OutboundReport: notjunk:1;M01:P0:xk387rXgy9U=;KIjXNn72X0OksLs93SmJ0zADgUR zT8weyWkTIhoX63Sn63f2aOiKmQBtWTnosHoI7luKjVQcKzzNPeH0L9aCDu9WvoKcmjbfHcO1 +bUwYi24WPfAmcPrBxRqvEb42tIGB3fSkfU+/sHdVZH45BA7BR3EPql+ACH4DNsidEyQHUz7a ePZvrhrii+QsmcL1yFjYvTOpW5EGTyhy2yzUfia9hjw90ALVkpKDR4v+9nvh8Zt74JzqMWYbv isDXJCkRelT6mHXkxo8XVQWAvSpSSAjckRO0Kt1T9XxtaiQtXBrSyymOh1glyKp7Xgstx2Va1 C0QBlo4jUn/EJnptvtN6Wb7bOc1969wACIcbmaJeJj7JYupm6GDMuHHe0Mq43ybzR2E/oOTc5 TZKE0wKitrhKtoOMd6MGkAxlT6OgslOZfBZ0bRy92bIxLlPaGPpO5975TU5nSo8W3TA5ro6B3 1dK1DLpPNVnrV8Jke7kBUmfqeGVi1jaPoSLzMIGTfZxz1vIQ8ZkW09euoyRZQbr20kMj+OBSZ cg1B1QkTipcTbAkhd3P0mDneA8heg8YWsFnqSyszqcyvkVPNOKCR6cjS8Tx+5fGNMhlC7WzWH n509PmvJtMEZPQJPRgPbaoF9X9Rs777uQ00HoMckPaLTLTDQcHp0eEpz8qv6OwUe+AiWmGb+r DDOLWv846r1WKL1YYsd2ieIQij9tjkP9P11O43f7+qP2jYnj69nEL5pACkcfm991utcWi73fp ouhQIXspyfKf3WvNcbwRTgULGLTCP8tCabGWIcUOFVBxJai8GmhRMipt7g+N5qzbsRUjyIq4K 5VNFojHnLVtnFwqZjR00FquQ== X-Spam-Status: No, score=-10.6 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_BARRACUDACENTRAL, 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+incoming=patchwork.ozlabs.org@gcc.gnu.org Dear all, this is the third patch in a series that addresses dummy arguments with the VALUE attribute, now handling the passing of NULL actual arguments. It is based on the refactoring in the previous patch and reuses the handling of absent arguments. Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald From a0509b34d52b32a2e3511daefcb7dc308c755931 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Thu, 25 Jan 2024 22:19:10 +0100 Subject: [PATCH] Fortran: NULL actual to optional dummy with VALUE attribute [PR113377] gcc/fortran/ChangeLog: PR fortran/113377 * trans-expr.cc (conv_dummy_value): Treat NULL actual argument to optional dummy with the VALUE attribute as not present. (gfc_conv_procedure_call): Likewise. gcc/testsuite/ChangeLog: PR fortran/113377 * gfortran.dg/optional_absent_11.f90: New test. --- gcc/fortran/trans-expr.cc | 11 ++- .../gfortran.dg/optional_absent_11.f90 | 99 +++++++++++++++++++ 2 files changed, 108 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/optional_absent_11.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 3dc521fab9a..67abca9f6ba 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -6086,7 +6086,7 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym, gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension); /* Absent actual argument for optional scalar dummy. */ - if (e == NULL && fsym->attr.optional && !fsym->attr.dimension) + if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional) { /* For scalar arguments with VALUE attribute which are passed by value, pass "0" and a hidden argument for the optional status. */ @@ -6354,7 +6354,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, e->ts = temp_ts; } - if (e == NULL) + if (e == NULL + || (e->expr_type == EXPR_NULL + && fsym + && fsym->attr.value + && fsym->attr.optional + && !fsym->attr.dimension + && fsym->ts.type != BT_DERIVED + && fsym->ts.type != BT_CLASS)) { if (se->ignore_optional) { diff --git a/gcc/testsuite/gfortran.dg/optional_absent_11.f90 b/gcc/testsuite/gfortran.dg/optional_absent_11.f90 new file mode 100644 index 00000000000..1f63def46fa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/optional_absent_11.f90 @@ -0,0 +1,99 @@ +! { dg-do run } +! PR fortran/113377 +! +! Test that a NULL actual argument to an optional dummy is not present +! (see also F2018:15.5.2.12 on argument presence) + +program test_null_actual_is_absent + implicit none + integer :: k(4) = 1 + character :: c(4) = "#" + call one (k) + call three (c) +contains + subroutine one (i) + integer, intent(in) :: i(4) + integer :: kk = 2 + integer, allocatable :: aa + integer, pointer :: pp => NULL() + print *, "Scalar integer" + call two (kk, aa) + call two (kk, pp) + call two (kk, NULL()) + call two (kk, NULL(aa)) + call two (kk, NULL(pp)) + print *, "Elemental integer" + call two (i, aa) + call two (i, pp) + call two (i, NULL()) + call two (i, NULL(aa)) + call two (i, NULL(pp)) + print *, "Scalar integer; value" + call two_val (kk, aa) + call two_val (kk, pp) + call two_val (kk, NULL()) + call two_val (kk, NULL(aa)) + call two_val (kk, NULL(pp)) + print *, "Elemental integer; value" + call two_val (i, aa) + call two_val (i, pp) + call two_val (i, NULL()) + call two_val (i, NULL(aa)) + call two_val (i, NULL(pp)) + end + + elemental subroutine two (i, j) + integer, intent(in) :: i + integer, intent(in), optional :: j + if (present (j)) error stop 11 + end + + elemental subroutine two_val (i, j) + integer, intent(in) :: i + integer, value, optional :: j + if (present (j)) error stop 12 + end + + subroutine three (y) + character, intent(in) :: y(4) + character :: zz = "*" + character, allocatable :: aa + character, pointer :: pp => NULL() + print *, "Scalar character" + call four (zz, aa) + call four (zz, pp) + call four (zz, NULL()) + call four (zz, NULL(aa)) + call four (zz, NULL(pp)) + print *, "Elemental character" + call four (y, aa) + call four (y, pp) + call four (y, NULL()) + call four (y, NULL(aa)) + call four (y, NULL(pp)) + print *, "Scalar character; value" + call four_val (zz, aa) + call four_val (zz, pp) + call four_val (zz, NULL()) + call four_val (zz, NULL(aa)) + call four_val (zz, NULL(pp)) + print *, "Elemental character; value" + call four_val (y, aa) + call four_val (y, pp) + call four_val (y, NULL()) + call four_val (y, NULL(aa)) + call four_val (y, NULL(pp)) + end + + elemental subroutine four (i, j) + character, intent(in) :: i + character, intent(in), optional :: j + if (present (j)) error stop 21 + end + + elemental subroutine four_val (i, j) + character, intent(in) :: i + character, value, optional :: j + if (present (j)) error stop 22 + end +end -- 2.35.3