From patchwork Tue Jan 23 20:36:41 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 1889894 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=Bn60SKTU; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; 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 [8.43.85.97]) (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 4TKJmn2Gzzz23dy for ; Wed, 24 Jan 2024 07:37:29 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 5B46F3858C20 for ; Tue, 23 Jan 2024 20:37:27 +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 C32A9385840D; Tue, 23 Jan 2024 20:36:42 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org C32A9385840D 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 C32A9385840D 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=1706042209; cv=none; b=IgsXI/1QZxmGLdD6V4el9Ed+CvcOr77Rp66FgseF5wJ+KOO6w/xhyLvutmntXTeaHpRaudRFdaGkbYQQ42TpxVb6aMFKTXllFMU6JEL5jYizm4IYfznrurzEMC/gYAsRQWd5/7IIVKj2fYkepydC0heQ4gaqoVyRw8vMTI/zpl8= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1706042209; c=relaxed/simple; bh=HXVsI44hAx1w1h2mt0qM6Hw6ANRmLGClzTJ8WFlrZfQ=; h=DKIM-Signature:MIME-Version:Message-ID:From:To:Subject:Date; b=JcVG0JUBcROEOb0Bph1Xx1Z59UN4iGdpWFiK3Iv6Hu9PlMS8wLOlDjKoWo9tskFnHQ0qm9M0MJfdBKw3KZl4P0Y9z6kSMEHQTTV2Jahp3wOloFPb0OW7+c445Ghss7tsBvJhzrWkLpvoia+f5STaZ3y/7WZ6utuUcBR2TxRq95E= ARC-Authentication-Results: i=1; server2.sourceware.org DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=gmx.de; s=s31663417; t=1706042201; x=1706647001; i=anlauf@gmx.de; bh=HXVsI44hAx1w1h2mt0qM6Hw6ANRmLGClzTJ8WFlrZfQ=; h=X-UI-Sender-Class:From:To:Subject:Date; b=Bn60SKTU5NoWMB3BUpVyFCpoqp+stiIj7f3SP/L6q7fN02JA+EP5Me5hourR+1Tg gGp1Xu62Pdwyqfe87hu6nm2nr+8VswNjH6FO7yCdYApWh99suROc7xSGcZUpNNjuH sIkJUupmlqh7dsVMpqvAskHj0oM43f7E2p8Dadnl41fYqaRxCwgW/GemS+eQT5G9F 17iklhOmTqgQ+pxxoNptjEk7VOEB6HEMNsqMY+WhsdnfxvkskPWu6Pf5ZECuKXNNQ q+Wx7BXP+lYGqfHnRqzKVHyUbLBrWd1srYDPYkWmRP8B9BxsymY0LPKtQ0YGEUJCZ R1oIxUCpfqczhu5/Pw== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [93.207.81.52] ([93.207.81.52]) by web-mail.gmx.net (3c-app-gmx-bs40.server.lan [172.19.170.92]) (via HTTP); Tue, 23 Jan 2024 21:36:41 +0100 MIME-Version: 1.0 Message-ID: From: Harald Anlauf To: fortran , gcc-patches Subject: [PATCH] Fortran: passing of optional dummies to elemental procedures [PR113377] Date: Tue, 23 Jan 2024 21:36:41 +0100 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:fGxGc26yAiVEzvNqMVvSEQnO0m5nKNh7S36DICrtIsUW5/Yc7s5WMnDE6o/4HsXlKeqld jjiBBgyu0QXWNGrtZWLFiBUjhIHBi71DRKn7oUhydneffjkBZKn/o72ccMK3CS0SLLMh1CZCpUjk raaGjJabd5KmOa5L8FteGMj/preubOlLCLK58xPcpctHhwSvrb8xiCQ6y742xhmtTl9qztmP8pLT AZYa7Ud2XVkHHTjc2sWYHpDJb2/v9MPLAASXyfg+6MUyNik35R0CW5dz2C8Cm0zvB42ApHo4fw8n fQ= UI-OutboundReport: notjunk:1;M01:P0:mZVxygesE2c=;i57eY3MmbRLi5h6Zik9Z9xSA2Xv VVaYOr/413lzwBYmryZWC+RtBpZrU8CkWqbfQeWIMhVCKxL5bDfhOWDGltNTIIVNv2B/P5KbR Emf7cTGoeI1e6ow4mEfsI2CNc2elx098VtFtTcQGgJGw+vRVjN8imCMm+7yz9AKY6BWzA85V4 n0C1Z9QoT/7V0l3Sg0+QWx2GDbrREnmQzUjsFJKLHzXnSDFOcAujhRijDXysxOg+lFvL6uW5S hzs6GV8oXW6SywrVypl7h3KuUtrUyctsESUfczZa3uDdJe58tZI4+g1PGGUDqOJsBR+dtY/Bx /go0Qpjw0/9Wv1DUUUD6+AVqnmLybOFQZ53HRu0yJQJb67XbWwGko019ddZC6cvuZI90P+5zw th25YtWp87MYhOYHBDe/TA/oghktONuPZYn8peDZc0iskgG/Ppm0N/SZLMnhVIVJDYYz5vTqf e3JnRuX5n3Cvc59rGD92vFFt+XYChKYyH2pqY7prhjsOWyyxmqFEUi7bzwYUTKkVqdBtM0p5z G8yerDXAkPXktAgBnqOA1UN8nP3bQPgop+/CbrwKBXLbKhCiLnpAz9SIq1sYFtEw34i2XMUrf BYTIPngRjwr/jVdHfla7VZlZlmcT9MZnp78y2x4dAYukO6FI/OteOu5jmciqGN1HI0McjatoE toLETnjbxlhWHKhC5jlOSVa4TzuQR6JnNFRdljpZzYi+8WYvTQnwV07YVT1B9uxfgUXAtpJYz lTasy0Pbm0YvZcx4dlnGLym3FXLE3ST/CRLak8nZW3VRkamIUaFQzAjLfasprgKmZAIh7Qf3J M5ukJEMe77LMzj0J4W269dNEOuiPcTqnBkRK1FfewXGKw= 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+incoming=patchwork.ozlabs.org@gcc.gnu.org Dear all, here's the second part of a series for the treatment of missing optional arguments passed to optional dummies, now fixing the case that the latter procedures are elemental. Adjustments were necessary when the missing dummy has the VALUE attribute. I factored the code for the treatment of VALUE, hoping that the monster loop in gfc_conv_procedure_call will become slightly easier to overlook. Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald From bd97af4225bf596260610ea37241ee503842435e Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Tue, 23 Jan 2024 21:23:42 +0100 Subject: [PATCH] Fortran: passing of optional dummies to elemental procedures [PR113377] gcc/fortran/ChangeLog: PR fortran/113377 * trans-expr.cc (conv_dummy_value): New. (gfc_conv_procedure_call): Factor code for handling dummy arguments with the VALUE attribute in the scalar case into conv_dummy_value(). Reuse and adjust for calling elemental procedures. gcc/testsuite/ChangeLog: PR fortran/113377 * gfortran.dg/optional_absent_10.f90: New test. --- gcc/fortran/trans-expr.cc | 198 +++++++++------- .../gfortran.dg/optional_absent_10.f90 | 219 ++++++++++++++++++ 2 files changed, 333 insertions(+), 84 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/optional_absent_10.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 128add47516..0fac0523670 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -6075,6 +6075,105 @@ conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond) } +/* Helper function for the handling of (currently) scalar dummy variables + with the VALUE attribute. Argument parmse should already be set up. */ +static void +conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym, + vec *& optionalargs) +{ + tree tmp; + + 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) + { + /* For scalar arguments with VALUE attribute which are passed by + value, pass "0" and a hidden argument for the optional status. */ + if (fsym->ts.type == BT_CHARACTER) + { + /* Pass a NULL pointer for an absent CHARACTER arg and a length of + zero. */ + parmse->expr = null_pointer_node; + parmse->string_length = build_int_cst (gfc_charlen_type_node, 0); + } + else + parmse->expr = fold_convert (gfc_sym_type (fsym), + integer_zero_node); + vec_safe_push (optionalargs, boolean_false_node); + + return; + } + + /* gfortran argument passing conventions: + actual arguments to CHARACTER(len=1),VALUE + dummy arguments are actually passed by value. + Strings are truncated to length 1. */ + if (gfc_length_one_character_type_p (&fsym->ts)) + { + if (e->expr_type == EXPR_CONSTANT + && e->value.character.length > 1) + { + e->value.character.length = 1; + gfc_conv_expr (parmse, e); + } + + tree slen1 = build_int_cst (gfc_charlen_type_node, 1); + gfc_conv_string_parameter (parmse); + parmse->expr = gfc_string_to_single_character (slen1, parmse->expr, + e->ts.kind); + /* Truncate resulting string to length 1. */ + parmse->string_length = slen1; + } + + if (fsym->attr.optional + && fsym->ts.type != BT_CLASS + && fsym->ts.type != BT_DERIVED) + { + /* F2018:15.5.2.12 Argument presence and + restrictions on arguments not present. */ + if (e->expr_type == EXPR_VARIABLE + && e->rank == 0 + && (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 && e->ref->type != REF_ARRAY)) + vec_safe_push (optionalargs, boolean_true_node); + else + { + tmp = gfc_conv_expr_present (e->symtree->n.sym); + if (e->ts.type != BT_CHARACTER && !e->symtree->n.sym->attr.value) + parmse->expr + = fold_build3_loc (input_location, COND_EXPR, + TREE_TYPE (parmse->expr), + tmp, parmse->expr, + fold_convert (TREE_TYPE (parmse->expr), + integer_zero_node)); + + vec_safe_push (optionalargs, + fold_convert (boolean_type_node, tmp)); + } + } +} + + + /* 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. @@ -6279,19 +6378,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && !fsym->attr.dimension && fsym->ts.type != BT_CLASS && !gfc_bt_struct (sym->ts.type)) { - if (fsym->ts.type == BT_CHARACTER) - { - /* Pass a NULL pointer for an absent CHARACTER arg - and a length of zero. */ - parmse.expr = null_pointer_node; - parmse.string_length - = build_int_cst (gfc_charlen_type_node, - 0); - } - else - parmse.expr = fold_convert (gfc_sym_type (fsym), - integer_zero_node); - vec_safe_push (optionalargs, boolean_false_node); + conv_dummy_value (&parmse, e, fsym, optionalargs); } else { @@ -6392,12 +6479,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } } + /* Scalar dummy arguments of intrinsic type with VALUE attribute. */ + if (fsym + && fsym->attr.value + && !fsym->attr.dimension + // && (fsym->ts.type != BT_CHARACTER + // || gfc_length_one_character_type_p (&fsym->ts)) + && fsym->ts.type != BT_DERIVED + && fsym->ts.type != BT_CLASS) + conv_dummy_value (&parmse, e, fsym, optionalargs); + /* If we are passing an absent array as optional dummy to an elemental procedure, make sure that we pass NULL when the data pointer is NULL. We need this extra conditional because of scalarization which passes arrays elements to the procedure, ignoring the fact that the array can be absent/unallocated/... */ - if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE) + else if (ss->info->can_be_null_ref + && ss->info->type != GFC_SS_REFERENCE) { tree descriptor_data; @@ -6487,76 +6585,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } else { - gfc_conv_expr (&parmse, e); - - /* ABI: actual arguments to CHARACTER(len=1),VALUE - dummy arguments are actually passed by value. - Strings are truncated to length 1. */ - if (gfc_length_one_character_type_p (&fsym->ts)) - { - if (e->expr_type == EXPR_CONSTANT - && e->value.character.length > 1) - { - e->value.character.length = 1; - gfc_conv_expr (&parmse, e); - } - - tree slen1 = build_int_cst (gfc_charlen_type_node, 1); - gfc_conv_string_parameter (&parmse); - parmse.expr - = gfc_string_to_single_character (slen1, - parmse.expr, - e->ts.kind); - /* Truncate resulting string to length 1. */ - parmse.string_length = slen1; - } - - if (fsym->attr.optional - && fsym->ts.type != BT_CLASS - && fsym->ts.type != BT_DERIVED) - { - /* 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 - { - tmp = gfc_conv_expr_present (e->symtree->n.sym); - if (!e->symtree->n.sym->attr.value) - parmse.expr - = fold_build3_loc (input_location, COND_EXPR, - TREE_TYPE (parmse.expr), - tmp, parmse.expr, - fold_convert (TREE_TYPE (parmse.expr), - integer_zero_node)); - - vec_safe_push (optionalargs, - fold_convert (boolean_type_node, - tmp)); - } - } + gfc_conv_expr (&parmse, e); + conv_dummy_value (&parmse, e, fsym, optionalargs); } } diff --git a/gcc/testsuite/gfortran.dg/optional_absent_10.f90 b/gcc/testsuite/gfortran.dg/optional_absent_10.f90 new file mode 100644 index 00000000000..acdabbdf164 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/optional_absent_10.f90 @@ -0,0 +1,219 @@ +! { dg-do run } +! PR fortran/113377 +! +! Test passing of missing optional arguments of intrinsic type +! to scalar dummies of elemental subroutines + +module m_char + implicit none +contains + subroutine test_char () + character :: k(7) = "#" + character(4) :: c(7) = "*" + call one (k) + call one_val (k) + call one_ij (k) + call one_jj (k) + call one_j4 (k) + call three (c) + call three_val (c) + call three_ij (c) + call three_jj (c) + call three_j4 (c) + end subroutine test_char + + subroutine one (i, j) + character, intent(in) :: i(7) + character, intent(in), optional :: j + character, allocatable :: aa + character, pointer :: pp => NULL() + if (present (j)) stop 1 + call two (i, j) + call two_val (i, j) + call two (i, aa) + call two (i, pp) + call two_val (i, aa) + call two_val (i, pp) + end + + subroutine one_val (i, j) + character, intent(in) :: i(7) + character, value, optional :: j + if (present (j)) stop 2 + call two (i, j) + call two_val (i, j) + end + + subroutine one_ij (i, j) + character, intent(in) :: i(7) + character, intent(in), optional :: j(7) + if (present (j)) stop 3 + call two (i, j) + call two_val (i, j) + end + + subroutine one_jj (i, j) + character, intent(in) :: i(7) + character, intent(in), optional :: j(:) + if (present (j)) stop 4 + call two (i, j) + call two_val (i, j) + end + + subroutine one_j4 (i, j) + character, intent(in) :: i(:) + character, intent(in), optional :: j(7) + if (present (j)) stop 5 + call two (i, j) + call two_val (i, j) + end + + elemental subroutine two (i, j) + character, intent(in) :: i + character, intent(in), optional :: j + if (present (j)) error stop 11 + end + + elemental subroutine two_val (i, j) + character, intent(in) :: i + character, value, optional :: j + if (present (j)) error stop 12 + end + + subroutine three (i, j) + character(4), intent(in) :: i(7) + character(4), intent(in), optional :: j + character(4), allocatable :: aa + character(4), pointer :: pp => NULL() + if (present (j)) stop 6 + call four (i, j) + call four_val (i, j) + call four (i, aa) + call four (i, pp) + call four_val (i, aa) + call four_val (i, pp) + end + + subroutine three_val (i, j) + character(4), intent(in) :: i(7) + character(4), value, optional :: j + if (present (j)) stop 7 + call four (i, j) + call four_val (i, j) + end + + subroutine three_ij (i, j) + character(4), intent(in) :: i(7) + character(4), intent(in), optional :: j(7) + if (present (j)) stop 8 + call four (i, j) + call four_val (i, j) + end + + subroutine three_jj (i, j) + character(4), intent(in) :: i(7) + character(4), intent(in), optional :: j(:) + if (present (j)) stop 9 + call four (i, j) + call four_val (i, j) + end + + subroutine three_j4 (i, j) + character(4), intent(in) :: i(:) + character(4), intent(in), optional :: j(7) + if (present (j)) stop 10 + call four (i, j) + call four_val (i, j) + end + + elemental subroutine four (i, j) + character(4), intent(in) :: i + character(4), intent(in), optional :: j + if (present (j)) error stop 13 + end + + elemental subroutine four_val (i, j) + character(4), intent(in) :: i + character(4), value, optional :: j + if (present (j)) error stop 14 + end +end + +module m_int + implicit none +contains + subroutine test_int () + integer :: k(4) = 1 + call one (k) + call one_val (k) + call one_ij (k) + call one_jj (k) + call one_j4 (k) + end + + subroutine one (i, j) + integer, intent(in) :: i(4) + integer, intent(in), optional :: j + integer, allocatable :: aa + integer, pointer :: pp => NULL() + if (present (j)) stop 21 + call two (i, j) + call two_val (i, j) + call two (i, aa) + call two (i, pp) + call two_val (i, aa) + call two_val (i, pp) + end + + subroutine one_val (i, j) + integer, intent(in) :: i(4) + integer, value, optional :: j + if (present (j)) stop 22 + call two (i, j) + call two_val (i, j) + end + + subroutine one_ij (i, j) + integer, intent(in) :: i(4) + integer, intent(in), optional :: j(4) + if (present (j)) stop 23 + call two (i, j) + call two_val (i, j) + end + + subroutine one_jj (i, j) + integer, intent(in) :: i(4) + integer, intent(in), optional :: j(:) + if (present (j)) stop 24 + call two (i, j) + call two_val (i, j) + end + + subroutine one_j4 (i, j) + integer, intent(in) :: i(:) + integer, intent(in), optional :: j(4) + if (present (j)) stop 25 + call two (i, j) + call two_val (i, j) + end + + elemental subroutine two (i, j) + integer, intent(in) :: i + integer, intent(in), optional :: j + if (present (j)) error stop 31 + end + + elemental subroutine two_val (i, j) + integer, intent(in) :: i + integer, value, optional :: j + if (present (j)) error stop 32 + end +end + +program p + use m_int + use m_char + implicit none + call test_int () + call test_char () +end -- 2.35.3