From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: 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] Content-Type: multipart/mixed; boundary=rehcsed-a15ce06b-03a5-48b8-b81f-c810a5bf0aa9 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 List-Id: --rehcsed-a15ce06b-03a5-48b8-b81f-c810a5bf0aa9 Content-Type: text/plain; charset=UTF-8 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 --rehcsed-a15ce06b-03a5-48b8-b81f-c810a5bf0aa9 Content-Type: text/x-patch Content-Disposition: attachment; filename=pr92887.diff Content-Transfer-Encoding: quoted-printable =46rom 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. =2D-- 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 =2D-- 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 t= he + OPTIONAL+VALUE attribute that shall not be dereferenced. Use null val= ue + 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 !=3D BT_DERIVED && e->ts.type !=3D BT_CLASS); + gcc_assert (e->rank =3D=3D 0); + temp =3D gfc_create_var (TREE_TYPE (parmse->expr), "condtemp"); + TREE_STATIC (temp) =3D 1; + TREE_CONSTANT (temp) =3D 1; + TREE_READONLY (temp) =3D 1; + DECL_INITIAL (temp) =3D build_zero_cst (TREE_TYPE (temp)); + parmse->expr =3D fold_build3_loc (input_location, COND_EXPR, + TREE_TYPE (parmse->expr), + cond, parmse->expr, temp); + parmse->expr =3D gfc_evaluate_now (parmse->expr, &parmse->pre); +} + + /* Generate code for a procedure call. Note can return se->post !=3D NUL= L. 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 !=3D BT_CLASS && fsym->ts.type !=3D BT_DERIVED) { - if (e->expr_type !=3D EXPR_VARIABLE - || !e->symtree->n.sym->attr.optional - || e->ref !=3D NULL) + /* F2018:15.5.2.12 Argument presence and + restrictions on arguments not present. */ + if (e->expr_type =3D=3D 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 =3D 1; + gfc_conv_expr (&argse, e); + cond =3D fold_convert (TREE_TYPE (argse.expr), + null_pointer_node); + cond =3D 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 !=3D EXPR_VARIABLE + || !e->symtree->n.sym->attr.optional + || e->ref !=3D NULL) vec_safe_push (optionalargs, boolean_true_node); else { diff --git a/gcc/testsuite/gfortran.dg/value_optional_1.f90 b/gcc/testsuit= e/gfortran.dg/value_optional_1.f90 new file mode 100644 index 00000000000..2f95316de52 =2D-- /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 =3D> 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=3Dtt% za) + allocate (aa, pp, ca, cp, za, zp, tt% za) + aa =3D 1; pp =3D 2.; ca =3D "c"; cp =3D "d"; za =3D 3.; zp =3D 4.; tt% = za =3D 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 /=3D 1 .or. y /=3D 2.0) stop 11 + if (c /=3D "c" .or. d /=3D "d") stop 12 + if (z /=3D (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 /=3D 1 .or. y /=3D 2.0) stop 21 + if (c /=3D "c" .or. d /=3D "d") stop 22 + if (z /=3D (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 /=3D 1 .or. y /=3D 2.0) stop 36 + if (c /=3D "c" .or. d /=3D "d") stop 37 + if (z /=3D (4.,0.) ) stop 38 + end +end =2D- 2.35.3 --rehcsed-a15ce06b-03a5-48b8-b81f-c810a5bf0aa9--