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: 206115 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a05:7300:a81b:b0:108:e6aa:91d0 with SMTP id bq27csp1732095dyb; Sun, 25 Feb 2024 12:26:49 -0800 (PST) X-Forwarded-Encrypted: i=3; AJvYcCWzve/b/hP5HJmrVs+BZUZp+GtCwrHNCk9KWWMT27zjjdibWyGZWuOCCKLV1GxgiJ22m5LgVv5NdKod3+iwA8w9dWc2cg== X-Google-Smtp-Source: AGHT+IFrbLWLoWsagHGyDrQ+S3GBZF6dcGmFsemr5Mu6P+zAzdH3iR7mgBKg3IU8IHAjpCZjttnj X-Received: by 2002:a9d:7491:0:b0:6e4:72b9:a9c9 with SMTP id t17-20020a9d7491000000b006e472b9a9c9mr6341645otk.30.1708892808988; Sun, 25 Feb 2024 12:26:48 -0800 (PST) ARC-Seal: i=2; a=rsa-sha256; t=1708892808; cv=pass; d=google.com; s=arc-20160816; b=rFhnWBjaJZ9QLMNGplGicuSsbbwpSx6kvUejaYKf/jPhxGX8vF1x2aUVXr5v7n27YQ 3upTieFdvqJUwbnC1QIw0H1OssKC719ToDtYD9BaRumZoM52HtrLRnrstZ+90HKHfg+Z 4o5ZvvONboPBiiiB1qU894sJ5Kb8CdvPTcQG7wFslG/fSKduDQK3eAGbzfenDmxnhCCF rRyN8QcvxdZx3UJ2Dqw0nM1VAmfEPQXUpMZs+bgKnqKU3dUAcspOazuR0JxSa2n9/YNx dfR+qKp5Zrxtx6MGrYm45b+fA6sbKcXT18o3MSLLc+gj9kK7Qr5Owiwr3MSyYo2U0SUu nRqA== ARC-Message-Signature: i=2; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=errors-to:list-subscribe:list-help:list-post:list-archive :list-unsubscribe:list-id:precedence:ui-outboundreport:sensitivity :importance:date:subject:to:from:message-id:mime-version :dkim-signature:arc-filter:dmarc-filter:delivered-to; bh=hKkkzJqmGJI4u0lhyTdqgLEdGaOv89MMs9IdRZiQMks=; fh=+IEfvAe+9BRgPHWhQEl2uIBTtAiiGDh1ExRZeB5JJoc=; b=XNjbGihdtS3INwpMEBV1fVc5xp6PUchcd1nZaG5V+NBYfDc5IGoNaRztJH143SHYyi ARSCXkvKs8SV0hC4+EghnsRq4Xp/kMzyVyKyuTB9YP3WWQkp62y7OMOJ323U4p6ve5gH dOW5By/HDm0qcuS9wHQbXRTLtlQvyw6Q8nU3da6ORQh46KV0Ni0iIGiUjWgFdPWAvCQZ S0M1w0WCzkdZ2GR9yk9DYv1FMUohhkvcGLArtvNlX/8rwOv0pL60UlrMJe7CPyPBjqdn KZW8SwQUAykIcD6gJUcsOcBGe4IpGEIR4l2qIJ5FEwLFW43rtw5cqc7y0eGZFkUHGZYz otoA==; dara=google.com ARC-Authentication-Results: i=2; mx.google.com; dkim=pass header.i=@gmx.de header.s=s31663417 header.b=i1p3H0Cb; arc=pass (i=1); spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=QUARANTINE sp=QUARANTINE dis=NONE) header.from=gmx.de Received: from server2.sourceware.org (server2.sourceware.org. [2620:52:3:1:0:246e:9693:128c]) by mx.google.com with ESMTPS id 14-20020ac8590e000000b0042e685c98a7si3961425qty.242.2024.02.25.12.26.48 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sun, 25 Feb 2024 12:26:48 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) client-ip=2620:52:3:1:0:246e:9693:128c; Authentication-Results: mx.google.com; dkim=pass header.i=@gmx.de header.s=s31663417 header.b=i1p3H0Cb; arc=pass (i=1); spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=QUARANTINE sp=QUARANTINE dis=NONE) header.from=gmx.de Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id A72173858C33 for ; Sun, 25 Feb 2024 20:26:48 +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+ouuuleilei=gmail.com@gcc.gnu.org X-getmail-retrieved-from-mailbox: INBOX X-GMAIL-THRID: 1791903985828886953 X-GMAIL-MSGID: 1791903985828886953 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