From patchwork Wed Nov 1 22:10:20 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 1858102 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=XCg4phNc; 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 4SLLmj2XNjz1yQq for ; Thu, 2 Nov 2023 09:10:45 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 575BD3858031 for ; Wed, 1 Nov 2023 22:10:43 +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 D77E33858D37; Wed, 1 Nov 2023 22:10:21 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org D77E33858D37 Authentication-Results: sourceware.org; dmarc=pass (p=none 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 D77E33858D37 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=1698876632; cv=none; b=CXWJvplAbMfUBafP1CFMMhla8Zcf0y2kxY6f8dCYQg8FLEBOnHJLXnTlkcj4OkrLjqzHHcZ6lTkp89HshRylh0YQOSkeJfO2i3At0ECED2jtrQ38Sy11/Yov/gJ3Vij43GQzs+Jvyunx0HexxiuElwnljyzqIrlhx2bKu7H6Oto= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1698876632; c=relaxed/simple; bh=A+i2N6iFl+jSBnximwqVCXGmwT5ZiiGZmqfpGiKim1U=; h=DKIM-Signature:MIME-Version:Message-ID:From:To:Subject:Date; b=weLJi9ETnQ+9iT8KMGQRYsWyUTm6vZC5QhuaGr/icTTiBBarZGm8shoUDa/1h2GQ8L4w0KHa/ZKUtj/yzITxRBjDgqwz+IoA8lObGIUNH8eTUwPmfS/hVmAztILeEPp5cjHx+aHKmYfGw/YCqRZ0BI/rJedzV4bHVaN/sDQbpwA= ARC-Authentication-Results: i=1; server2.sourceware.org DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=gmx.de; s=s31663417; t=1698876620; x=1699481420; i=anlauf@gmx.de; bh=A+i2N6iFl+jSBnximwqVCXGmwT5ZiiGZmqfpGiKim1U=; h=X-UI-Sender-Class:From:To:Subject:Date; b=XCg4phNcokMudwEK88Zqmv1awhJJQx/pJjcSZas4FsZrRSYNtgvg9M9U1gSZwNt/ irWCd5dz8/G24+jW8yOCRu7i4hphQ7jRJ7v9d8PF++UBwOKCW/HV4TI+ZUO98xJrM pBdH2m35+DQBEtEnH1Q7bxf2vFclbTydNOEQuroDs55SncqjfJ0vi8ZW962Ph6WLk q1adxK4UZReQTfNQVo9cEJIdDrMbq02FM7V82flPXZfPCRJGqOTaXDrm+8+vj3mGN 6tG+y6CQ473P2/p+YVOZiQk/mcJ4frmNqVJUevm/UgFa5qkMz5sYYo/DilkjVw/H3 +HHUeO4G8pgyPvebYQ== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [93.207.89.93] ([93.207.89.93]) by web-mail.gmx.net (3c-app-gmx-bs47.server.lan [172.19.170.99]) (via HTTP); Wed, 1 Nov 2023 23:10:20 +0100 MIME-Version: 1.0 Message-ID: From: Harald Anlauf To: fortran , gcc-patches Subject: [PATCH] Fortran: passing of allocatable/pointer arguments to OPTIONAL+VALUE [PR92887] Date: Wed, 1 Nov 2023 23:10:20 +0100 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:pU8Z9rSWMUdgOjXXvi+LRzR2P/e2WBQCYXiUA3nO8dD83WdYzjScpGusXv1JeMGwKIUrj DU7nAkn+AZjcQ/FY+kzku+L0kyASlP41rZRNbw0hW+MPOAbeLppUnV3IYa6dBkZFjMVECGg//k5E lysiLyeGLZLXgPeBtCsd3y+D4EevYcjdcvEH8mFO/KS0pQR9fyDzIQW7GgvLA0jhphgLisE77lHM MGHHFShi4v8u3FFnL1rZqw9Ulqwox1QhmA76rQpViRh7QgOodaAw+MFyA6gmzJgXsRuoQpLbLWES VM= UI-OutboundReport: notjunk:1;M01:P0:KrsC4z5vBCw=;KFjVWyvOzng7HWzSMhSMiXyiCn1 FDm4jSIa4H9U8DG2vHwoHLH1F1i3QoK8BXfaNssQX+4U7xdaFtFAh6lcbZXg7HhUVMLf4+emg DUfKSsul0oEuqD9+HMOBxS3LijAqKIGih+NV5kqMocLGZTq7GmwZXYfA6t+YmcERmvl97pcwZ x+mBpdGJxbr/gqK3OQK2Rydp1v4ue2WPxT3ahxGLyhZi0L3HayAdWLmVctOe8NitnK2hWDRHq hd3LraPCW6jhbE+gh7xXDFK/JqhYPHXrJxbjf4sNRY8NVVPuOUoLYje1tG3sUsf+CDj2VtYp+ abIKzAeROsePK6BWtFXeVm7LiL411cPriKX5j9v+e9LwKw35fknbZoClrcIJhrF05tTiRc5ER EQT2EUT0F2UxtxtDCzj4C9D95ZHdQ2BoyrLBow2q1PWWvItsmR3DyYpAcCjpeI9HKoacOQ669 UBeg+UuWlrKFHsPQdCOqzWQe68z1uXKX3xEhKVMsxxFEuI7OUWJWGvsQlfQ4hTabu4Wf0By1l 8nkJmIx8JpWdPLtGqrB+Li1j5NkB6oA8uzTT/dn9gYxsVto5OoJ7JSIsRkLY3zMIG2/n4fDhR KbM8H4mE98VYGkI+Po1UbIu1rv6j0JhjVDALuMdFzlnH9A/8kdA+nigSqFd1bC/oXZUQprvqx JsU144DqmZL3Qt0O2U3tchwPbA051Kf262edIujK2jPpvGok4wpfMpKo2s6soMYR1dHZGAd8D Zv4UkwcinT2zV79sT/pdvF7oho9VnzbGdhUwA3jst5p0Lj0vjJoi77Vy6XaJFBc18EaER7Gsw FhprPF4RNcRCi51Ufzfkvem4dUgTHl9ayq1qZrJKTRVsg= X-Spam-Status: No, score=-11.2 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_H4, RCVD_IN_MSPIKE_WL, SCC_5_SHORT_WORD_LINES, 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, I've dusted off and cleaned up a previous attempt to fix the handling of allocatable or pointer actual arguments to OPTIONAL+VALUE dummies. The standard says that a non-allocated / non-associated actual argument in that case shall be treated as non-present. However, gfortran's calling conventions demand that the presence status for OPTIONAL+VALUE is passed as a hidden argument, while we need to pass something on the stack which has the right type. The solution is to conditionally create a temporary when needed. Testcase checked with NAG. Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald From 6927612d97a8e7360e651bb081745fc7659a4c4b Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Wed, 1 Nov 2023 22:55:36 +0100 Subject: [PATCH] Fortran: passing of allocatable/pointer arguments to OPTIONAL+VALUE [PR92887] gcc/fortran/ChangeLog: PR fortran/92887 * trans-expr.cc (conv_cond_temp): Helper function for creation of a conditional temporary. (gfc_conv_procedure_call): Handle passing of allocatable or pointer actual argument to dummy with OPTIONAL + VALUE attribute. Actual arguments that are not allocated or associated are treated as not present. gcc/testsuite/ChangeLog: PR fortran/92887 * gfortran.dg/value_optional_1.f90: New test. --- gcc/fortran/trans-expr.cc | 50 ++++++++++- .../gfortran.dg/value_optional_1.f90 | 83 +++++++++++++++++++ 2 files changed, 130 insertions(+), 3 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/value_optional_1.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 1b8be081a17..1c06ecb3c28 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -6030,6 +6030,28 @@ post_call: } +/* Create "conditional temporary" to handle scalar dummy variables with the + OPTIONAL+VALUE attribute that shall not be dereferenced. Use null value + as fallback. Only instances of intrinsic basic type are supported. */ + +void +conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond) +{ + tree temp; + gcc_assert (e->ts.type != BT_DERIVED && e->ts.type != BT_CLASS); + gcc_assert (e->rank == 0); + temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp"); + TREE_STATIC (temp) = 1; + TREE_CONSTANT (temp) = 1; + TREE_READONLY (temp) = 1; + DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp)); + parmse->expr = fold_build3_loc (input_location, COND_EXPR, + TREE_TYPE (parmse->expr), + cond, parmse->expr, temp); + parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre); +} + + /* Generate code for a procedure call. Note can return se->post != NULL. If se->direct_byref is set then se->expr contains the return parameter. Return nonzero, if the call has alternate specifiers. @@ -6470,9 +6492,31 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED) { - if (e->expr_type != EXPR_VARIABLE - || !e->symtree->n.sym->attr.optional - || e->ref != NULL) + /* F2018:15.5.2.12 Argument presence and + restrictions on arguments not present. */ + if (e->expr_type == EXPR_VARIABLE + && (gfc_expr_attr (e).allocatable + || gfc_expr_attr (e).pointer)) + { + gfc_se argse; + tree cond; + gfc_init_se (&argse, NULL); + argse.want_pointer = 1; + gfc_conv_expr (&argse, e); + cond = fold_convert (TREE_TYPE (argse.expr), + null_pointer_node); + cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + argse.expr, cond); + vec_safe_push (optionalargs, + fold_convert (boolean_type_node, + cond)); + /* Create "conditional temporary". */ + conv_cond_temp (&parmse, e, cond); + } + else if (e->expr_type != EXPR_VARIABLE + || !e->symtree->n.sym->attr.optional + || e->ref != NULL) vec_safe_push (optionalargs, boolean_true_node); else { diff --git a/gcc/testsuite/gfortran.dg/value_optional_1.f90 b/gcc/testsuite/gfortran.dg/value_optional_1.f90 new file mode 100644 index 00000000000..2f95316de52 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_optional_1.f90 @@ -0,0 +1,83 @@ +! { dg-do run } +! PR fortran/92887 +! +! Test passing nullified/disassociated pointer or unalloc allocatable +! to OPTIONAL + VALUE + +program p + implicit none !(type, external) + integer, allocatable :: aa + real, pointer :: pp + character, allocatable :: ca + character, pointer :: cp + complex, allocatable :: za + complex, pointer :: zp + type t + integer, allocatable :: aa + real, pointer :: pp => NULL() + complex, allocatable :: za + end type t + type(t) :: tt + nullify (pp, cp, zp) + call sub (aa, pp, ca, cp, za) + call sub (tt% aa, tt% pp, z=tt% za) + allocate (aa, pp, ca, cp, za, zp, tt% za) + aa = 1; pp = 2.; ca = "c"; cp = "d"; za = 3.; zp = 4.; tt% za = 4. + call ref (1, 2., "c", "d", (3.,0.)) + call ref (aa, pp, ca, cp, za) + call val (1, 2., "c", "d", (4.,0.)) + call val (aa, pp, ca, cp, zp) + call opt (1, 2., "c", "d", (4.,0.)) + call opt (aa, pp, ca, cp, tt% za) + deallocate (aa, pp, ca, cp, za, zp, tt% za) +contains + subroutine sub (x, y, c, d, z) + integer, value, optional :: x + real, value, optional :: y + character, value, optional :: c, d + complex, value, optional :: z + if (present(x)) stop 1 + if (present(y)) stop 2 + if (present(c)) stop 3 + if (present(d)) stop 4 + if (present(z)) stop 5 + end + ! call by reference + subroutine ref (x, y, c, d, z) + integer :: x + real :: y + character :: c, d + complex :: z + print *, "by reference :", x, y, c, d, z + if (x /= 1 .or. y /= 2.0) stop 11 + if (c /= "c" .or. d /= "d") stop 12 + if (z /= (3.,0.) ) stop 13 + end + ! call by value + subroutine val (x, y, c, d, z) + integer, value :: x + real, value :: y + character, value :: c, d + complex, value :: z + print *, "by value :", x, y, c, d, z + if (x /= 1 .or. y /= 2.0) stop 21 + if (c /= "c" .or. d /= "d") stop 22 + if (z /= (4.,0.) ) stop 23 + end + ! call by value, optional arguments + subroutine opt (x, y, c, d, z) + integer, value, optional :: x + real, value, optional :: y + character, value, optional :: c, d + complex, value, optional :: z + if (.not. present(x)) stop 31 + if (.not. present(y)) stop 32 + if (.not. present(c)) stop 33 + if (.not. present(d)) stop 34 + if (.not. present(z)) stop 35 + print *, "value+optional:", x, y, c, d, z + if (x /= 1 .or. y /= 2.0) stop 36 + if (c /= "c" .or. d /= "d") stop 37 + if (z /= (4.,0.) ) stop 38 + end +end -- 2.35.3