From patchwork Sat Jan 20 21:58:49 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 1888822 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=ilkLdaM2; 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 4THVkb4wFMz1yPv for ; Sun, 21 Jan 2024 08:59:19 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 8C1A53858293 for ; Sat, 20 Jan 2024 21:59:17 +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 2E7453858D33; Sat, 20 Jan 2024 21:58:51 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 2E7453858D33 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 2E7453858D33 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=1705787933; cv=none; b=k5bGh4rDnz35OcIVkw4uKSDTd7JQvrOp16GpD0JcDkv2ugRkplkiQB8dyee30yjCiNT2iqNc2v2dsFwK09Hs6WXy8TTRjVGa/6P+qHM8wt6RXF1me1JK4cQViuXvTcwZDTVaByK9FMqP8EfKq7YOhjt6hThza8X2kOtZrTjZZ3o= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1705787933; c=relaxed/simple; bh=++6QrBHebSFdb/QIJl35ZMbhRkA9P25DcVexKsSgYok=; h=DKIM-Signature:MIME-Version:Message-ID:From:To:Subject:Date; b=vAKR39lEdomKGOs3l6Bw+/xZrhG+Um4XYU+c3mUeY5Lu/OIDGoJPaoXwPtoQMOf0YmRX1uhOw++SG3K47RHhr7wCxym47mpMBuTZjCeLKygdjbX9RwJCFWUOP2YJk2dCTBhSS/KAN+i2b8y4USsMugxi8Hr9qB9X3MHAQtLNTYY= ARC-Authentication-Results: i=1; server2.sourceware.org DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=gmx.de; s=s31663417; t=1705787929; x=1706392729; i=anlauf@gmx.de; bh=++6QrBHebSFdb/QIJl35ZMbhRkA9P25DcVexKsSgYok=; h=X-UI-Sender-Class:From:To:Subject:Date; b=ilkLdaM2E+q9hGq95QvSqjNSQgBYJmySH/9iZfsRhiZ6wrhgKvR0h7P5Vajh1xYv fyZuLtu3YSmBYLI1nDowY9l723+KNW6knAgg3LnGFHSJUd/UYOPESDoVLdti1c5hN NoTiVeR5NSafPWaIyAjgPY9He4Hz7X137u49/aTa1FGWnaj7owVuWIXK6sHjSzgRz Yuvtdkx7LrzyLc84CX7Bz+aapfaysCXH69BnGeW+hYcpj/75Mn8cX8SHuRNJpN3Iy Z8z9iaoTScBNz4zABnK/O/FSnOYle7f9Kbw7SlJx1gsc+v2oyBnVWQ6nJkueN56JD uLbVi2Eo1tpJ2xN1VQ== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [79.251.4.12] ([79.251.4.12]) by web-mail.gmx.net (3c-app-gmx-bs19.server.lan [172.19.170.71]) (via HTTP); Sat, 20 Jan 2024 22:58:49 +0100 MIME-Version: 1.0 Message-ID: From: Harald Anlauf To: fortran , gcc-patches Subject: [PATCH] Fortran: passing of optional scalar arguments with VALUE attribute [PR113377] Date: Sat, 20 Jan 2024 22:58:49 +0100 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:TLu9wm9G5rxW/DC0DEruF0EMWajdv6nrXT25RWXQk8TUkLFeQ3oLGT5ic3Pn5rqzCdYpZ mR2JIVH0C38y/xaGtp1aD0/TTANYv3mxW9rREoAJLdgdTd3JBDnMZ5SOYtXMgE0HMjz3CQnkTw4P CKz83KPoauE+LNUWPLnk6kzGWksUwZNyrNvPcjMZIk1u9JOTDELCoRVEebC4/7q7BIzQQt/A79Gt PbHcr83V2PLUvmxtNhHq9C8pV64IAcZBsVRibiiq1Gc0x2VwKo84bSk7TBgTpvBorH8/AfJ7i925 eM= UI-OutboundReport: notjunk:1;M01:P0:RVdZu68hcss=;lnBTpN1CDhxooZ5PUlgHrt66tfC 0w9UMdi1swv+iSuxCthbBOZtbW0552QKIClSQbQlj8YmSiwWtFjj+l5xvG2iSqDFapxJAhV6/ 6ar+Jf058CXL5ubqUM4QQzD64yIqsTAtZCaiU3U5x424Ds6uNN6EL2FAP7e4coSG3DJw5eN32 wI/j/26GN0vCL8Pgy/ad0rwM0jnvIuWciAnnN12THw1gdUZfmwiU6wmJBj3GpiB01F2CUVRwc J/u0kz3oortJtkdalzhjTZdhXPkRwTZF6tQl+OkaELEtUGH/j63PeAB4pV6hsxwyqDaSgZXLn oQ0B7Vmizr+3PlFEFTj+leY8YhOgfeh5afwyvmn1dTk95y8j0eBFwBmFfIOTqQCJ02sLMfTns FvNfYUCPKJ2BUkp3PKTFBujL87V18QrZWRHoH0iFlwuc9W3KOmG3dLkCvDqwjMuDq6rYr2Sm8 qorLCd5nORBhNEKm39ahEpNpUK988L+0EYhVGrb1Kej6dBrBzgsj5RDqT84KiMuJZ17FaNuTI Kav5hKEc6w5n6NhVwMcp09HUhVeQsvV3u12B/2LUgTeiqyYVad2y6druxZYAuSwstX8DCKp0A xv/PlDo5STa8A1D5TGWt18BqCVkBc1vC+VlzDgZSz2IkUlkGClx7y8kHOWnWSSQEfy3ilhvTg CesmF6RwnF32x/11+Y0SIQN3Sfkih3nGWoTd6DFCYVdbxpoUjrcReBUOnoeKkmWnK9xgbOEV3 lHnNXCKgfaMjBZWYctht6dFhHnfptKUObhhljPSJP4lqEklzMAUsQ8YSaDodSuTuYMyfE1pfu 6N+weGyQhalBdnHowQ6XjzjQ== X-Spam-Status: No, score=-11.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+incoming=patchwork.ozlabs.org@gcc.gnu.org Dear all, here's the first part of an attempt to fix issues with optional dummy arguments as actual arguments to optional dummies. This patch rectifies the case of scalar dummies with the VALUE attribute, which in gfortran's argument passing convention are passed on the stack when they are of intrinsic type, and have a hidden variable for the presence status. The testcase tries to cover valid combinations of actual and dummy argument. A few tests that are not standard-conforming but would still work with gfortran (due to the argument passing convention) are left there but commented out with a pointer to the standard (thanks, Mikael!). Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald From f6a65138391c902d2782973665059d7d059a50d1 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Sat, 20 Jan 2024 22:18:02 +0100 Subject: [PATCH] Fortran: passing of optional scalar arguments with VALUE attribute [PR113377] gcc/fortran/ChangeLog: PR fortran/113377 * trans-expr.cc (gfc_conv_procedure_call): Fix handling of optional scalar arguments of intrinsic type with the VALUE attribute. gcc/testsuite/ChangeLog: PR fortran/113377 * gfortran.dg/optional_absent_9.f90: New test. --- gcc/fortran/trans-expr.cc | 5 + .../gfortran.dg/optional_absent_9.f90 | 324 ++++++++++++++++++ 2 files changed, 329 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/optional_absent_9.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 9dd1f4086f4..2f47a75955c 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -6526,6 +6526,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_init_se (&argse, NULL); argse.want_pointer = 1; gfc_conv_expr (&argse, e); + if (e->symtree->n.sym->attr.dummy + && POINTER_TYPE_P (TREE_TYPE (argse.expr))) + argse.expr = gfc_build_addr_expr (NULL_TREE, + argse.expr); cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node); cond = fold_build2_loc (input_location, NE_EXPR, @@ -7256,6 +7260,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && e->symtree->n.sym->attr.optional && (((e->rank != 0 && elemental_proc) || e->representation.length || e->ts.type == BT_CHARACTER + || (e->rank == 0 && e->symtree->n.sym->attr.value) || (e->rank != 0 && (fsym == NULL || (fsym->as diff --git a/gcc/testsuite/gfortran.dg/optional_absent_9.f90 b/gcc/testsuite/gfortran.dg/optional_absent_9.f90 new file mode 100644 index 00000000000..495a6c00d7f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/optional_absent_9.f90 @@ -0,0 +1,324 @@ +! { dg-do run } +! PR fortran/113377 +! +! Test passing of missing optional scalar dummies of intrinsic type + +module m_int + implicit none +contains + subroutine test_int () + integer :: k = 1 + call one (k) + call one_val (k) + call one_all (k) + call one_ptr (k) + end + + subroutine one (i, j) + integer, intent(in) :: i + integer ,optional :: j + integer, allocatable :: aa + integer, pointer :: pp => NULL() + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + call two (i, aa) + call two (i, pp) + end + + subroutine one_val (i, j) + integer, intent(in) :: i + integer, value, optional :: j + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + end + + subroutine one_all (i, j) + integer, intent(in) :: i + integer, allocatable,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 8 +! call two_val (i, j) ! invalid (*) F2018:15.5.2.12, par. 3, clause 8 + call two_all (i, j) + end +! (*) gfortran argument passing conventions ("scalar dummy arguments of type +! INTEGER, LOGICAL, REAL, COMPLEX, and CHARACTER(len=1) with VALUE attribute +! pass the presence status separately") may still allow this case pass + + subroutine one_ptr (i, j) + integer, intent(in) :: i + integer, pointer ,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 7 +! call two_val (i, j) ! invalid (*) F2018:15.5.2.12, par. 3, clause 7 + call two_ptr (i, j) + end + + subroutine two (i, j) + integer, intent(in) :: i + integer, intent(in), optional :: j + if (present (j)) error stop 11 + end + + subroutine two_val (i, j) + integer, intent(in) :: i + integer, value, optional :: j + if (present (j)) error stop 12 + end + + subroutine two_all (i, j) + integer, intent(in) :: i + integer, allocatable,optional :: j + if (present (j)) error stop 13 + end + + subroutine two_ptr (i, j) + integer, intent(in) :: i + integer, pointer, optional :: j + if (present (j)) error stop 14 + end +end + +module m_char + implicit none +contains + subroutine test_char () + character :: k = "#" + call one (k) + call one_val (k) + call one_all (k) + call one_ptr (k) + end + + subroutine one (i, j) + character, intent(in) :: i + character ,optional :: j + character, allocatable :: aa + character, pointer :: pp => NULL() + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + call two (i, aa) + call two (i, pp) + end + + subroutine one_val (i, j) + character, intent(in) :: i + character, value, optional :: j + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + end + + subroutine one_all (i, j) + character, intent(in) :: i + character, allocatable,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 8 +! call two_val (i, j) ! invalid (*) F2018:15.5.2.12, par. 3, clause 8 + call two_all (i, j) + end +! (*) gfortran argument passing conventions ("scalar dummy arguments of type +! INTEGER, LOGICAL, REAL, COMPLEX, and CHARACTER(len=1) with VALUE attribute +! pass the presence status separately") may still allow this case pass + + subroutine one_ptr (i, j) + character, intent(in) :: i + character, pointer ,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 7 +! call two_val (i, j) ! invalid (*) F2018:15.5.2.12, par. 3, clause 7 + call two_ptr (i, j) + end + + subroutine two (i, j) + character, intent(in) :: i + character, intent(in), optional :: j + if (present (j)) error stop 21 + end + + subroutine two_val (i, j) + character, intent(in) :: i + character, value, optional :: j + if (present (j)) error stop 22 + end + + subroutine two_all (i, j) + character, intent(in) :: i + character, allocatable,optional :: j + if (present (j)) error stop 23 + end + + subroutine two_ptr (i, j) + character, intent(in) :: i + character, pointer, optional :: j + if (present (j)) error stop 24 + end +end + +module m_char4 + implicit none +contains + subroutine test_char4 () + character(kind=4) :: k = 4_"#" + call one (k) + call one_val (k) + call one_all (k) + call one_ptr (k) + end + + subroutine one (i, j) + character(kind=4), intent(in) :: i + character(kind=4) ,optional :: j + character(kind=4), allocatable :: aa + character(kind=4), pointer :: pp => NULL() + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + call two (i, aa) + call two (i, pp) + end + + subroutine one_val (i, j) + character(kind=4), intent(in) :: i + character(kind=4), value, optional :: j + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + end + + subroutine one_all (i, j) + character(kind=4), intent(in) :: i + character(kind=4), allocatable,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 8 +! call two_val (i, j) ! invalid (*) F2018:15.5.2.12, par. 3, clause 8 + call two_all (i, j) + end +! (*) gfortran argument passing conventions ("scalar dummy arguments of type +! INTEGER, LOGICAL, REAL, COMPLEX, and CHARACTER(KIND=4)(len=1) with VALUE attribute +! pass the presence status separately") may still allow this case pass + + subroutine one_ptr (i, j) + character(kind=4), intent(in) :: i + character(kind=4), pointer ,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 7 +! call two_val (i, j) ! invalid (*) F2018:15.5.2.12, par. 3, clause 7 + call two_ptr (i, j) + end + + subroutine two (i, j) + character(kind=4), intent(in) :: i + character(kind=4), intent(in), optional :: j + if (present (j)) error stop 31 + end + + subroutine two_val (i, j) + character(kind=4), intent(in) :: i + character(kind=4), value, optional :: j + if (present (j)) error stop 32 + end + + subroutine two_all (i, j) + character(kind=4), intent(in) :: i + character(kind=4), allocatable,optional :: j + if (present (j)) error stop 33 + end + + subroutine two_ptr (i, j) + character(kind=4), intent(in) :: i + character(kind=4), pointer, optional :: j + if (present (j)) error stop 34 + end +end + +module m_complex + implicit none +contains + subroutine test_complex () + complex :: k = 3. + call one (k) + call one_val (k) + call one_all (k) + call one_ptr (k) + end + + subroutine one (i, j) + complex, intent(in) :: i + complex ,optional :: j + complex, allocatable :: aa + complex, pointer :: pp => NULL() + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + call two (i, aa) + call two (i, pp) + end + + subroutine one_val (i, j) + complex, intent(in) :: i + complex, value, optional :: j + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + end + + subroutine one_all (i, j) + complex, intent(in) :: i + complex, allocatable,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 8 +! call two_val (i, j) ! invalid (*) F2018:15.5.2.12, par. 3, clause 8 + call two_all (i, j) + end +! (*) gfortran argument passing conventions ("scalar dummy arguments of type +! COMPLEX, LOGICAL, REAL, COMPLEX, and CHARACTER(len=1) with VALUE attribute +! pass the presence status separately") may still allow this case pass + + subroutine one_ptr (i, j) + complex, intent(in) :: i + complex, pointer ,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 7 +! call two_val (i, j) ! invalid (*) F2018:15.5.2.12, par. 3, clause 7 + call two_ptr (i, j) + end + + subroutine two (i, j) + complex, intent(in) :: i + complex, intent(in), optional :: j + if (present (j)) error stop 41 + end + + subroutine two_val (i, j) + complex, intent(in) :: i + complex, value, optional :: j + if (present (j)) error stop 42 + end + + subroutine two_all (i, j) + complex, intent(in) :: i + complex, allocatable,optional :: j + if (present (j)) error stop 43 + end + + subroutine two_ptr (i, j) + complex, intent(in) :: i + complex, pointer, optional :: j + if (present (j)) error stop 44 + end +end + +program p + use m_int + use m_char + use m_char4 + use m_complex + implicit none + call test_int () + call test_char () + call test_char4 () + call test_complex () +end -- 2.35.3