From patchwork Sun Feb 25 20:26:01 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 1903975 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=i1p3H0Cb; 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 4TjZyt6Fxkz23cb for ; Mon, 26 Feb 2024 07:26:28 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 483093858C74 for ; Sun, 25 Feb 2024 20:26:26 +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.17.21]) by sourceware.org (Postfix) with ESMTPS id 537643858C32; Sun, 25 Feb 2024 20:26:02 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 537643858C32 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 537643858C32 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=212.227.17.21 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1708892766; cv=none; b=mgE/gU+MUtp/pa4xXNB8Se1FxbORO0yaXU9zLduxy+h+YjDLL50jzJv4bAE12glXXFx9b3EUt+i0F/jWiU8nx1W9bQcJVJeuhz+8pcJGxXtmGh61cUv5cV7HbN79UPDGN3mL6xXqRNbWXfe9UQkjrxZCplt6qFnHriYyoY/2RjU= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1708892766; c=relaxed/simple; bh=vYqSU3pxCue7Q/DYRYg0ndZslWFbyCzLQ45bFwPkj10=; h=DKIM-Signature:MIME-Version:Message-ID:From:To:Subject:Date; b=KbrTQ1ipMfWGw6Ryhyxnh1v5PxDJfjSv7LIQrPHVCA8UmYOAIVjDfL+lVxVR4XZcH4W/wszT7/oix3HuNNCUrRVPe2weKlHK7VOkdeRlt4Xa9HyBsPtzN8n6QBbaaijB6JuyQ/NLF3J5Hl6/Og2lrZAjq41dUsoqH/KrcYq67tw= ARC-Authentication-Results: i=1; server2.sourceware.org DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=gmx.de; s=s31663417; t=1708892761; x=1709497561; i=anlauf@gmx.de; bh=vYqSU3pxCue7Q/DYRYg0ndZslWFbyCzLQ45bFwPkj10=; h=X-UI-Sender-Class:From:To:Subject:Date; b=i1p3H0Cbb7sCoun1Tnoa7ZyI2bV6uydoDgq3UN4zK9e0XwwaShO28XIbcd7gcAsS wCwsAOIK1Iz6vgnucaFqAtCqcagTnEv7Dm0mcNlE8Kebr2vm+Bp9MRDWLSeDbBKBU u2WtYBywuI95F8ccaFfg1mSuNhvGkmFVhz0cDjTmgbwFNljJqBKeJmxU/sIoWRtUI 2OKBBmWoq3QtMUjmWjWM4TY4qWUvLEC7vDWl/bDX0hYcKLEy8u7V1qFYHiIqG3JMe k9SgX5tu+4Z3riTvKITkMdgHsa90tcMYgYl+l/NDtax0Pqg/ZIss46nq6HtzfMSkj 6C8VAlY8q6gKaRE0lQ== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [79.232.154.59] ([79.232.154.59]) by web-mail.gmx.net (3c-app-gmx-bap36.server.lan [172.19.172.106]) (via HTTP); Sun, 25 Feb 2024 21:26:01 +0100 MIME-Version: 1.0 Message-ID: From: Harald Anlauf To: fortran , gcc-patches Subject: [PATCH] Fortran: do not evaluate polymorphic functions twice in assignment [PR114012] Date: Sun, 25 Feb 2024 21:26:01 +0100 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:hd4B/5S/2sfa8DKBQXp9mRTeiqvI699cqFPjrvnUmUIf1DZOXOwsGrMnreWApD7kHR2zN vKI9OamL/qF8CSnbTZ1Wm728MxFDpHtMulRwZhULKw8H/bnlCh4DYrPwSyrLBh5tyRkbEKZ6ZDho xQWkxAJw3fWb189FKeE0XiT8FKtxRjuIMnm/Gyx+wqohQ+C75GSTlRgZQ5xv9+ZxlM7EigmWQraD mG1cBBkNZQ9xgFbRU7M6UKkyZ43hU84bmSd40cS083C1awcaTkc/mU1Nwn07cqe8c2T+OWHdzt5d Bs= UI-OutboundReport: notjunk:1;M01:P0:Z55ssV02fUk=;DZ7yQvyhsA9IlTsYF0dnxKxzP2l MUlRsdcfu/Z/WC6/jixFjrCCyS/sm5QcEJuODSXy47Dd11stmXGzM8+ZJTo2/pMXI3kkFnllq 2A2TTeoaN0TXz4mVre26T2Srzd42j7TFEI3+5IzNQPWSmxavdXOnkjZ3w6kAD/00F3L6pmSzh 1re2UtzhQyGfxE/oo+f+U4ejZmsvELSe4Xdv/v1uneW2C4LKKNDZKgStXvTsloXw5jHRi3Avs npA5M9DXMNvY/jmIE/Nk2JlncX3sutuaRuXAvMwRvcfaM7ObCqPZ4kjLLvElO50hIAMliyGT4 LfA+tXoUlitG6nCzmDpBSrQmYuU+iUFYLCS+19Et55Q1SGNV+ekR9U47sQYArwnVIXxYnQxHG lm51u2ptf0yMLjlrYY6uViCMygJdNEX+TiS7h6lFN8zYK0s9XxTnVfSA+CmBxmRK4ZEX/RZch MGz0q3CTNvcDA4RlUkhgvgBgb9pHth+HHnvhyakSmsp0bTYE6vlUoGwGxjd+ISsfm4IuAKFtp UdJ04XygAAhxAU+fXXNbLncv8bhv7BjtTNDdKfORAMP7iSGaZLHVIvAf39KJqVvTo278SMHpD gsn83xSRj1yVjO/5mx2iHsikbxFDuQTz4/Nq0Q0q1RWDDV36OB1w+QInbOOYXALyct/vO4t1Y kR/YYODbnF0nhMS1NUJlOggqvtMoIbTbyfmhKuF3RqIch1HysLUvwPTr82uIpfs= 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, the attached simple patch fixes an issue where we evaluated polymorphic functions twice in assignments: once for the _data component, and once for the _vptr. Using save_expr prevents the double evaluation. Regtested on x86_64-pc-linux-gnu. OK for mainline? And a backport to 13-branch after some delay? Thanks, Harald From 7a16143448ee21b716b54a94f83f9ee477af1b63 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Sun, 25 Feb 2024 21:18:23 +0100 Subject: [PATCH] Fortran: do not evaluate polymorphic functions twice in assignment [PR114012] PR fortran/114012 gcc/fortran/ChangeLog: * trans-expr.cc (gfc_conv_procedure_call): Evaluate non-trivial arguments just once before assigning to an unlimited polymorphic dummy variable. gcc/testsuite/ChangeLog: * gfortran.dg/pr114012.f90: New test. --- gcc/fortran/trans-expr.cc | 4 ++ gcc/testsuite/gfortran.dg/pr114012.f90 | 81 ++++++++++++++++++++++++++ 2 files changed, 85 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/pr114012.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 118dfd7c9b2..d63c304661a 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -6691,6 +6691,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tree efield; + /* Evaluate arguments just once. */ + if (e->expr_type != EXPR_VARIABLE) + parmse.expr = save_expr (parmse.expr); + /* Set the _data field. */ tmp = gfc_class_data_get (var); efield = fold_convert (TREE_TYPE (tmp), diff --git a/gcc/testsuite/gfortran.dg/pr114012.f90 b/gcc/testsuite/gfortran.dg/pr114012.f90 new file mode 100644 index 00000000000..9dbb031c664 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr114012.f90 @@ -0,0 +1,81 @@ +! { dg-do run } +! PR fortran/114012 +! +! Polymorphic functions were evaluated twice in assignment + +program test + implicit none + + type :: custom_int + integer :: val = 2 + end type + + interface assignment(=) + procedure assign + end interface + interface operator(-) + procedure neg + end interface + + type(custom_int) :: i + integer :: count_assign, count_neg + + count_assign = 0 + count_neg = 0 + + i = 1 + if (count_assign /= 1 .or. count_neg /= 0) stop 1 + + i = -i + if (count_assign /= 2 .or. count_neg /= 1) stop 2 + if (i% val /= -1) stop 3 + + i = neg(i) + if (count_assign /= 3 .or. count_neg /= 2) stop 4 + if (i% val /= 1) stop 5 + + i = (neg(i)) + if (count_assign /= 4 .or. count_neg /= 3) stop 6 + if (i% val /= -1) stop 7 + + i = - neg(i) + if (count_assign /= 5 .or. count_neg /= 5) stop 8 + if (i% val /= -1) stop 9 + +contains + + subroutine assign (field, val) + type(custom_int), intent(out) :: field + class(*), intent(in) :: val + + count_assign = count_assign + 1 + + select type (val) + type is (integer) +! print *, " in assign(integer)", field%val, val + field%val = val + type is (custom_int) +! print *, " in assign(custom)", field%val, val%val + field%val = val%val + class default + error stop + end select + + end subroutine assign + + function neg (input_field) result(output_field) + type(custom_int), intent(in), target :: input_field + class(custom_int), allocatable :: output_field + allocate (custom_int :: output_field) + + count_neg = count_neg + 1 + + select type (output_field) + type is (custom_int) +! print *, " in neg", output_field%val, input_field%val + output_field%val = -input_field%val + class default + error stop + end select + end function neg +end program test -- 2.35.3