From patchwork Tue Jul 11 10:32:51 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 118411 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:a6b2:0:b0:3e4:2afc:c1 with SMTP id c18csp378307vqm; Tue, 11 Jul 2023 03:34:13 -0700 (PDT) X-Google-Smtp-Source: APBJJlEzYVCWHr1rPMl+erHvtgTj/pQhi2s7swt9f5wacVr/c/atIw4awqc+lfBbkOVJocpHW8qB X-Received: by 2002:aa7:dad8:0:b0:51b:c887:dd1e with SMTP id x24-20020aa7dad8000000b0051bc887dd1emr14656081eds.18.1689071653666; Tue, 11 Jul 2023 03:34:13 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1689071653; cv=none; d=google.com; s=arc-20160816; b=LsufZcpqWMJgd6Xs3+IDMlKL5+3nGft1EWj+elqpbcyCu8RM/N63HtkHJfeRIsO9Es e8iK6vC2XCuDGBnoDBfkWT06krnnJcg2nuzuZdkuMToUv1My7hxwUcUxaF7IAMBytx6k 5W+DmcflGsEMmejAr2dTqWF0VoqhvUjbHWtwMfiziZ/zNc4hpWHLqiaEMwop3uS2GFHr 5j5NpY2hrRpMrADVdKcGK1X+svdza6txVxvZF9TYb+3fcCMN9yAB6ZikTPkxYgMKoq/r vfdgcPwGrsf4IbPzxQh16TomZOt8X8UbAEBGBXmJlGBrSZQkvwZcY1B0tYfrHfETpiQc Bjjg== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=sender:errors-to:reply-to:from:list-subscribe:list-help:list-post :list-archive:list-unsubscribe:list-id:precedence :content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:to:dmarc-filter:delivered-to:dkim-signature :dkim-filter; bh=7uv1H+G7Ne4MLas8/mQgGIml/9xHm/2cBo/P9LNmR+k=; fh=EAqAZnhg4AYtcBjfPm18lEF5V0R2rkI9MSWQf+svVaI=; b=qE5h9jP69BaPes8VIPyIaIJKF7gT46mus2p1T5DzlGYiALmTPkauTsF20L9fczMgNl ctUDOmK88AsikIlMezLKataSdVuOgG5i9nnfjGKuZbS1r/El2wGQDKmyWNd21zLrV7fn 3y79ESG8pso9MLYxe+F6klYzIyRsxLPiyspHUWCPR4ZwaN4aMddRLh7MbsJMtUmCvu/C Rs2Ey9TV0An0nejgO1LpRIpkkhRs51PJilSxsqKtifXUEh+L9pvXf79suQdNPNt+zsdA hHfShiQY1+MZzBWMS19V3Gzg0JtcHukaz0Sf6hKBZxNSeP2H+RpqBkWXJi4zDprq3s50 CF2w== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=JhcKyH8l; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from server2.sourceware.org (ip-8-43-85-97.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id u1-20020a05640207c100b0051e04ea21ebsi1720352edy.202.2023.07.11.03.34.13 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 11 Jul 2023 03:34:13 -0700 (PDT) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) client-ip=8.43.85.97; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=JhcKyH8l; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 5DC59385AF90 for ; Tue, 11 Jul 2023 10:33:50 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 5DC59385AF90 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1689071630; bh=7uv1H+G7Ne4MLas8/mQgGIml/9xHm/2cBo/P9LNmR+k=; h=To:Subject:Date:In-Reply-To:References:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:List-Subscribe:From:Reply-To: From; b=JhcKyH8lLWkiIApPly8Ttbkxl3l+uQ33O/fiZReqOw2w/cA7QZLuZnVFzxIQpDNfg GaVlV4nlzsPtEtr4AY4AspB4bO+xoqEB+X6Exu6PG/cx4b3J1C3uyXjxMp6df1pcTy ug+95awFERg29qqZQv1jsXmkkwJdR1ueRXoVAcCc= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp-20.smtpout.orange.fr [80.12.242.20]) by sourceware.org (Postfix) with ESMTPS id ABFB73858284 for ; Tue, 11 Jul 2023 10:33:03 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org ABFB73858284 Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id JAfuqCdJWn02aJAg2qNA41; Tue, 11 Jul 2023 12:33:02 +0200 X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Tue, 11 Jul 2023 12:33:02 +0200 X-ME-IP: 86.215.161.51 To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [PATCH 1/3] fortran: defer class wrapper initialization after deallocation [PR92178] Date: Tue, 11 Jul 2023 12:32:51 +0200 Message-Id: <20230711103253.1589353-2-mikael@gcc.gnu.org> X-Mailer: git-send-email 2.40.1 In-Reply-To: <20230711103253.1589353-1-mikael@gcc.gnu.org> References: <20230711103253.1589353-1-mikael@gcc.gnu.org> MIME-Version: 1.0 X-Spam-Status: No, score=-9.8 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, FORGED_SPF_HELO, GIT_PATCH_0, JMQ_SPF_NEUTRAL, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H4, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_NEUTRAL, 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.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Mikael Morin via Gcc-patches From: Mikael Morin Reply-To: Mikael Morin Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: INBOX X-GMAIL-THRID: 1771119998218634191 X-GMAIL-MSGID: 1771119998218634191 If an actual argument is associated with an INTENT(OUT) dummy, and code to deallocate it is generated, generate the class wrapper initialization after the actual argument deallocation. This is achieved by passing a cleaned up expression to gfc_conv_class_to_class, so that the class wrapper initialization code can be isolated and moved independently after the deallocation. PR fortran/92178 gcc/fortran/ChangeLog: * trans-expr.cc (gfc_conv_procedure_call): Use a separate gfc_se struct, initalized from parmse, to generate the class wrapper. After the class wrapper code has been generated, copy it back depending on whether parameter deallocation code has been generated. gcc/testsuite/ChangeLog: * gfortran.dg/intent_out_19.f90: New test. --- gcc/fortran/trans-expr.cc | 18 ++++++++++++++++- gcc/testsuite/gfortran.dg/intent_out_19.f90 | 22 +++++++++++++++++++++ 2 files changed, 39 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/intent_out_19.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 7017b652d6e..b7e95e6d04d 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -6500,6 +6500,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else { + bool defer_to_dealloc_blk = false; if (e->ts.type == BT_CLASS && fsym && fsym->ts.type == BT_CLASS && (!CLASS_DATA (fsym)->as @@ -6661,6 +6662,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, stmtblock_t block; tree ptr; + defer_to_dealloc_blk = true; + gfc_init_block (&block); ptr = parmse.expr; if (e->ts.type == BT_CLASS) @@ -6717,7 +6720,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && ((CLASS_DATA (fsym)->as && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK) || CLASS_DATA (e)->attr.dimension)) - gfc_conv_class_to_class (&parmse, e, fsym->ts, false, + { + gfc_se class_se = parmse; + gfc_init_block (&class_se.pre); + gfc_init_block (&class_se.post); + + gfc_conv_class_to_class (&class_se, e, fsym->ts, false, fsym->attr.intent != INTENT_IN && (CLASS_DATA (fsym)->attr.class_pointer || CLASS_DATA (fsym)->attr.allocatable), @@ -6727,6 +6735,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, CLASS_DATA (fsym)->attr.class_pointer || CLASS_DATA (fsym)->attr.allocatable); + parmse.expr = class_se.expr; + stmtblock_t *class_pre_block = defer_to_dealloc_blk + ? &dealloc_blk + : &parmse.pre; + gfc_add_block_to_block (class_pre_block, &class_se.pre); + gfc_add_block_to_block (&parmse.post, &class_se.post); + } + if (fsym && (fsym->ts.type == BT_DERIVED || fsym->ts.type == BT_ASSUMED) && e->ts.type == BT_CLASS diff --git a/gcc/testsuite/gfortran.dg/intent_out_19.f90 b/gcc/testsuite/gfortran.dg/intent_out_19.f90 new file mode 100644 index 00000000000..03036ed382a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intent_out_19.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! PR fortran/92178 +! Check that if a data reference passed is as actual argument whose dummy +! has INTENT(OUT) attribute, any other argument depending on the +! same data reference is evaluated before the data reference deallocation. + +program p + implicit none + class(*), allocatable :: c + c = 3 + call bar (allocated(c), c, allocated (c)) + if (allocated (c)) stop 14 +contains + subroutine bar (alloc, x, alloc2) + logical :: alloc, alloc2 + class(*), allocatable, intent(out) :: x(..) + if (allocated (x)) stop 5 + if (.not. alloc) stop 6 + if (.not. alloc2) stop 16 + end subroutine bar +end