From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from smtp.smtpout.orange.fr (smtp-19.smtpout.orange.fr [80.12.242.19]) by sourceware.org (Postfix) with ESMTPS id A348A3858408 for ; Tue, 11 Jul 2023 10:33:03 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org A348A3858408 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=gcc.gnu.org Authentication-Results: sourceware.org; spf=fail smtp.mailfrom=gcc.gnu.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id JAfuqCdJWn02aJAg2qNA41; Tue, 11 Jul 2023 12:33:02 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=wanadoo.fr; s=t20230301; t=1689071582; bh=7uv1H+G7Ne4MLas8/mQgGIml/9xHm/2cBo/P9LNmR+k=; h=From:To:Subject:Date:In-Reply-To:References; b=DaT5PLF+LCsdn4gmjH3PXq8lN8F/OJFPUv/ANwjkIuVbwrmCTFyMml0JeJ5mF/13y 4NqWsgdQYjuSjh3v5SVkEAQNFnWQ+i9fY6NELQzPOCV2RTKjl4THR+0COWyEswbfdE GUN4ekCAKa87HPmUlSXTZGuXXy9u/Ls/fDCP38ipuoL7iGuy0y6mIg0KAT9KLzbtAP DtqxH7i4AcXFmCGff3dALnm7mxU6Wg5DwvYQ0xnqd/L8hx93jUpQEbFRhCkol6pTAM iu+K2i1ayBunSP43vc2gv3PR0vpDor/JZCgwbtlfntNOmYSQbsPSGPEkkR0w9Xp6N5 fYicmsFBwx5bg== 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 From: Mikael Morin 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 Content-Transfer-Encoding: 8bit X-Spam-Status: No, score=-9.1 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_H2,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 List-Id: 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 -- 2.40.1