From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mout.gmx.net (mout.gmx.net [212.227.15.19]) by sourceware.org (Postfix) with ESMTPS id 596BB3857C53; Mon, 27 Nov 2023 19:31:53 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 596BB3857C53 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 596BB3857C53 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=1701113515; cv=none; b=Jb50h2f10lAoX98+bvT1BYqsrT1qfz/9P5gWjx35odxY3WK+YsnCPToYJexu3NNeNRh90XRZLoArXvPSt3wM3X4yivHnrJ6P03WBBT68zK7nx7x7JFY+eRVwNKub/plDwfs4rOoJobUI/DcQ0UyTzRmcUP1j/ZGjBWD7M24eu7o= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1701113515; c=relaxed/simple; bh=fZtcTfNbglPtLM1tkfmo9Fos6Jkf4h/dvZJJwSrPQrk=; h=DKIM-Signature:MIME-Version:Message-ID:From:To:Subject:Date; b=TGnXE4ogC+/6MD2SPUA9e40XJR06GuaCwPOwAEYDOGF8tyjfp6U5hVPJ8ClIsrgpqyjnKAWyrgA+bbWaBPdM/9EIsSbmcqz1egLJQX3ojvUc4pTD8kKjp57dD6GXzLDlmJkDxXrmGMZlbvsD3ifoiBzf+geCQL9MuZQH94Ip4mM= ARC-Authentication-Results: i=1; server2.sourceware.org DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=gmx.de; s=s31663417; t=1701113512; x=1701718312; i=anlauf@gmx.de; bh=fZtcTfNbglPtLM1tkfmo9Fos6Jkf4h/dvZJJwSrPQrk=; h=X-UI-Sender-Class:From:To:Subject:Date; b=KnZ7Qx3sPyiqNdabimnlf/WH0nnEzLm90Cd+IwhgI06JBZ/Tsqx0Fxi/TpuetTsm Rx/41civ/ksrWXTVNL6lF7QuyDfYn+HnGmkdJAAK4HlkF3oO9nXD/e/8OH+rSJc9Y PoasmK81rkpdFECRJgW0F2+cxnGbfne6/HIOnNxYS0Iwdc54nuzLyG1EHhLYeiXs+ /PdaZIFe/M8/rnSCZDmDGd1Xh0VJ4VYrx2QDCUoGwq1eQ+PU84EtuJM3qOiWzwiNm JQ0W0kGgpHAA0oCcBMxJCG/PDte0id5qrHn7kw11Mmyvh/WDaoenVolOOmbXFlUoW Tlpw4uAvPHTiaVLsgw== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [79.251.10.55] ([79.251.10.55]) by web-mail.gmx.net (3c-app-gmx-bs45.server.lan [172.19.170.97]) (via HTTP); Mon, 27 Nov 2023 20:31:52 +0100 MIME-Version: 1.0 Message-ID: From: Harald Anlauf To: fortran , gcc-patches Subject: [PATCH] Fortran: deferred-length character optional dummy arguments [PR93762,PR100651] Content-Type: multipart/mixed; boundary=nika-28b96b6a-06c0-417c-8dc1-398a516c0d49 Date: Mon, 27 Nov 2023 20:31:52 +0100 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:mbs9NGwwzyDTqtmc4eba9A5KrZf0EhFhFC4WYovRakpATkuzq4yyCCQUEdAPPzuaMffUK w7FhiKhGM2DxiDMlNx4m2dToTfqdzqNk4wH0B3UTsaXJ6UK+ICxN3Ha7KOLF2lj7JvFYcNsHQ0y1 MiEfnRaNmBWX983ZP/Cki9jSU6SKWKMOD/WMXGyggyTP2NUAFm9avY5OtxJInDAUXz41/Re2gZIc PnbbF/t7mYLksZ0QWdNPoqx2M5XVwQEsBxxcjiKwPlYdhGu8JIWGYYJNwi8U5ygNTlqaLmspnN+j xk= UI-OutboundReport: notjunk:1;M01:P0:0IZUSTrSgqo=;hx4cDmP3l1vVrELKXpt2c9nq+c5 ICyBgXXN+t4r7Yv/QPcfTsaZmJUqf2Uk4TfXhU4naND/9Z1D2OSNkeWLXqLqS+AeCDF3/wnpy 3ZXMX3KuVSEha5V9sl1fEsOfedNHd94N0xSeaZYHDiX1WTX49oNeKWB46woxvh5EE2VBnVtWC mJ6s0qquMfS2PgNCXyjBk6efn+q/ualksaFT1VDSatpJXPp7oFQaxWXSVKZJxxfodoUocor5P +VRgnK+ke+inwj/cLdV069PNHue6v2fqdxwMw1FvSLcfaYQipUej/htHoa0aJNc57csDt93c0 D8sFCx1q8ZWxgY4O54CjHiAX1m3Pf6MBKBg5sRzeqbW5eXSnt90I7nTB9o8a+oUgKCGXoh+um 2Prot2NlLykmHNld3jJrNTwyFUT1YfFM/BQliVkQGenqxBMcMZ7c2IsFVC8AHiKJHVF5Jq9ga cO0XznOoAUxKFJxciSJ9PpwbzQa4wqKdQLV6aebdJS4FdyZmIzv4PlgWPsFGVFYtNBOvZ1zNd YnPZDovOoh9ZHqBTxlSKXJWKRZdGVMUuwfdxvqTol3wlRFFR9APjbituvSXWJmuEKLaR01D6d iW/euq01Ag0f5fnqqXkUmGiQzzqjfU1cS3Fcth2fMQNyiEwfDWmZGDBOnuwdGdZjNuAVwcP4+ UvUJv1teDbIsFyNVsqaA89TMPMxC71YTThiwbfaK8ytMrYraQ0g79wqp9hs2PipTSfRFMfdTH Hp6KI8YR2jfDFj3BXBkHrKZgtDHuMTbPz/z0KjkaE7PNxHfoFpePuAkUEpLIEqFg+HVMo77be itT5laQYXozyme1nqYVpMrkA== 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 List-Id: --nika-28b96b6a-06c0-417c-8dc1-398a516c0d49 Content-Type: text/plain; charset=UTF-8 Dear all, the attached patch fixes the passing of deferred-length character to optional dummy arguments: the character length shall be passed by reference, not by value. Original analysis of the issue by Steve in PR93762, independently done by FX in PR100651. The patch fixes both PRs. Regtested on x86_64-pc-linux-gnu. OK for mainline? As the fix is local and affects only deferred-length character, would it be ok to backport to 13-branch? Thanks, Harald --nika-28b96b6a-06c0-417c-8dc1-398a516c0d49 Content-Type: text/x-patch Content-Disposition: attachment; filename=pr100651.diff Content-Transfer-Encoding: quoted-printable =46rom 8ce1c8e7d0390361a1507000b7abbf6509b2fee9 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Mon, 27 Nov 2023 20:19:11 +0100 Subject: [PATCH] Fortran: deferred-length character optional dummy argumen= ts [PR93762,PR100651] gcc/fortran/ChangeLog: PR fortran/93762 PR fortran/100651 * trans-expr.cc (gfc_conv_missing_dummy): The character length for deferred-length dummy arguments is passed by reference, so that its value can be returned. Adjust handling for optional dummies. gcc/testsuite/ChangeLog: PR fortran/93762 PR fortran/100651 * gfortran.dg/optional_deferred_char_1.f90: New test. =2D-- gcc/fortran/trans-expr.cc | 22 +++- .../gfortran.dg/optional_deferred_char_1.f90 | 100 ++++++++++++++++++ 2 files changed, 118 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/optional_deferred_char_1.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 50c4604a025..e992f60d8bb 100644 =2D-- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -2116,10 +2116,24 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * ar= g, gfc_typespec ts, int kind) if (ts.type =3D=3D BT_CHARACTER) { - tmp =3D build_int_cst (gfc_charlen_type_node, 0); - tmp =3D fold_build3_loc (input_location, COND_EXPR, gfc_charlen_typ= e_node, - present, se->string_length, tmp); - tmp =3D gfc_evaluate_now (tmp, &se->pre); + /* Handle deferred-length dummies that pass the character length by + reference so that the value can be returned. */ + if (ts.deferred && INDIRECT_REF_P (se->string_length)) + { + tmp =3D gfc_build_addr_expr (NULL_TREE, se->string_length); + tmp =3D fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), + present, tmp, null_pointer_node); + tmp =3D gfc_evaluate_now (tmp, &se->pre); + tmp =3D build_fold_indirect_ref_loc (input_location, tmp); + } + else + { + tmp =3D build_int_cst (gfc_charlen_type_node, 0); + tmp =3D fold_build3_loc (input_location, COND_EXPR, + gfc_charlen_type_node, + present, se->string_length, tmp); + tmp =3D gfc_evaluate_now (tmp, &se->pre); + } se->string_length =3D tmp; } return; diff --git a/gcc/testsuite/gfortran.dg/optional_deferred_char_1.f90 b/gcc/= testsuite/gfortran.dg/optional_deferred_char_1.f90 new file mode 100644 index 00000000000..d399dd11ca2 =2D-- /dev/null +++ b/gcc/testsuite/gfortran.dg/optional_deferred_char_1.f90 @@ -0,0 +1,100 @@ +! { dg-do run } +! PR fortran/93762 +! PR fortran/100651 - deferred-length character as optional dummy argumen= t + +program main + implicit none + character(:), allocatable :: err_msg, msg3(:) + character(:), pointer :: err_msg2 =3D> NULL() + + ! Subroutines with optional arguments + call to_int () + call to_int_p () + call test_rank1 () + call assert_code () + call assert_p () + call assert_rank1 () + + ! Test passing of optional arguments + call to_int (err_msg) + if (.not. allocated (err_msg)) stop 1 + if (len (err_msg) /=3D 7) stop 2 + if (err_msg(1:7) /=3D "foo bar") stop 3 + + call to_int2 (err_msg) + if (.not. allocated (err_msg)) stop 4 + if (len (err_msg) /=3D 7) stop 5 + if (err_msg(1:7) /=3D "foo bar") stop 6 + deallocate (err_msg) + + call to_int_p (err_msg2) + if (.not. associated (err_msg2)) stop 11 + if (len (err_msg2) /=3D 8) stop 12 + if (err_msg2(1:8) /=3D "poo bla ") stop 13 + deallocate (err_msg2) + + call to_int2_p (err_msg2) + if (.not. associated (err_msg2)) stop 14 + if (len (err_msg2) /=3D 8) stop 15 + if (err_msg2(1:8) /=3D "poo bla ") stop 16 + deallocate (err_msg2) + + call test_rank1 (msg3) + if (.not. allocated (msg3)) stop 21 + if (len (msg3) /=3D 2) stop 22 + if (size (msg3) /=3D 42) stop 23 + if (any (msg3 /=3D "ok")) stop 24 + deallocate (msg3) + +contains + + ! Deferred-length character, allocatable: + subroutine assert_code (err_msg0) + character(:), optional, allocatable :: err_msg0 + if (present (err_msg0)) err_msg0 =3D 'foo bar' + end + ! Test: optional argument + subroutine to_int (err_msg1) + character(:), optional, allocatable :: err_msg1 + call assert_code (err_msg1) + end + ! Control: non-optional argument + subroutine to_int2 (err_msg2) + character(:), allocatable :: err_msg2 + call assert_code (err_msg2) + end + + ! Rank-1: + subroutine assert_rank1 (msg) + character(:), optional, allocatable, intent(out) :: msg(:) + if (present (msg)) then + allocate (character(2) :: msg(42)) + msg(:) =3D "ok" + end if + end + + subroutine test_rank1 (msg1) + character(:), optional, allocatable, intent(out) :: msg1(:) + call assert_rank1 (msg1) + end + + ! Deferred-length character, pointer: + subroutine assert_p (err_msg0) + character(:), optional, pointer :: err_msg0 + if (present (err_msg0)) then + if (associated (err_msg0)) deallocate (err_msg0) + allocate (character(8) :: err_msg0) + err_msg0 =3D 'poo bla' + end if + end + + subroutine to_int_p (err_msg1) + character(:), optional, pointer :: err_msg1 + call assert_p (err_msg1) + end + + subroutine to_int2_p (err_msg2) + character(:), pointer :: err_msg2 + call assert_p (err_msg2) + end +end =2D- 2.35.3 --nika-28b96b6a-06c0-417c-8dc1-398a516c0d49--