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 From patchwork Tue Jul 11 10:32:52 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 118412 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:a6b2:0:b0:3e4:2afc:c1 with SMTP id c18csp378765vqm; Tue, 11 Jul 2023 03:35:16 -0700 (PDT) X-Google-Smtp-Source: APBJJlHoHwQDxwOG9i/k+X+GIJQHnfRuVc/67c2UdayPKICP8wD5GgcIRlnM2Z29fhR0GQlhRdPa X-Received: by 2002:a17:907:3205:b0:993:b230:936b with SMTP id xg5-20020a170907320500b00993b230936bmr21172495ejb.6.1689071715983; Tue, 11 Jul 2023 03:35:15 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1689071715; cv=none; d=google.com; s=arc-20160816; b=NAe6NnPH+Hh/YGeurA0+h3xemu05LUhCwjG4EbOJVwIayK754NN6TBAxtX7Ke/Uzyk hukuoK6BGiB8G4TWY/EgtYKZqL/ddYm231qE43WEGRz17Bac97PvlAvvOO835p1crSPh d9O8HbGv/fpets0K0SQfC6YFTNpIZWs8Zpi3rd8yVJFyVF8Va+UZeeIY41ZG0dVPXXFS XCqTp0l6Tp+mfNZhk3Qx97WYyV7i5oxVS2+A0mKyQHTVPVmClsNtPNMPV9UI6To7tR6i qJaBaac9MWbViKXF11ZS5Uu2hHoHTFY9L6WIplL4PzIxnn4+zcfuQRfuYjKzeFPwCeaq 66Tw== 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=8WswCOgIPi+CHVCPV80kEyLjGgtnPDvmz1Ipjj17dFY=; fh=EAqAZnhg4AYtcBjfPm18lEF5V0R2rkI9MSWQf+svVaI=; b=RH1heXbumqnVQoE5laA+JZbjh3KVp3Ethp4ipD1lMPOjrbo0om6gf9hC0cHkJ71lWt Wyec0SpVGoc021zZhrPyNxa98nu0RdUaq3iZLgh4J2OK4x59apSiWU5DabvLuk+Qqb5E d7ps7jw0B4akJTFS3SHLKg/oy34dqrg90y8IgAeQMU7WRg4KG7xjRDvpP0H4Cz8+d07p M71+niR+rtlFBKnCrMeNdZqWvD9DRlGLw9zLD1mvtzIfKpEELNjDBbW+b1WUJ29gTpsp eqobsLeuv36JHIXl9JbHMDcO+5DIbiiKq0vyxJpaRMrwD18/kdWUoQX5Wrrt//L4P6NP jT2Q== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=x1A8EpA8; 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 f2-20020aa7d842000000b0051dd30da018si1704942eds.611.2023.07.11.03.35.15 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 11 Jul 2023 03:35:15 -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=x1A8EpA8; 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 936DA3854EBC for ; Tue, 11 Jul 2023 10:34:47 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 936DA3854EBC DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1689071687; bh=8WswCOgIPi+CHVCPV80kEyLjGgtnPDvmz1Ipjj17dFY=; 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=x1A8EpA8/vwKrtf4PQbXyTH8g5dOkmwj0Pseyj8RwVgFNGxRxpqbv+38CEc2ub/Vb rrj0/RayU/qIQlJ6rEHw4Q5vaWg+h3QnSD75rxZN6d4w7LVo2mycXOcGFmRhO6KiHi yn6ULHCYMCM/ytxEGvHV1WE5+ZbRgpJp2XusnWXE= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp-19.smtpout.orange.fr [80.12.242.19]) by sourceware.org (Postfix) with ESMTPS id AED763858031 for ; Tue, 11 Jul 2023 10:33:03 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org AED763858031 Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id JAfuqCdJWn02aJAg2qNA48; 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 2/3] fortran: Factor data references for scalar class argument wrapping [PR92178] Date: Tue, 11 Jul 2023 12:32:52 +0200 Message-Id: <20230711103253.1589353-3-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=-11.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=unavailable 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: 1771120063600106853 X-GMAIL-MSGID: 1771120063600106853 In the case of a scalar actual arg passed to a polymorphic assumed-rank dummy with INTENT(OUT) attribute, avoid repeatedly evaluating the actual argument reference by saving a pointer to it. This is non-optimal, but may also be invalid, because the data reference may depend on its own content. In that case the expression can't be evaluated after the data has been deallocated. There are two ways redundant expressions are generated: - parmse.expr, which contains the actual argument expression, is reused to get or set subfields in gfc_conv_class_to_class. - gfc_conv_class_to_class, to get the virtual table pointer associated with the argument, generates a new expression from scratch starting with the frontend expression. The first part is fixed by saving parmse.expr to a pointer and using the pointer instead of the original expression. The second part is fixed by adding a separate field to gfc_se that is set to the class container expression when the expression to evaluate is polymorphic. This needs the same field in gfc_ss_info so that its value can be propagated to gfc_conv_class_to_class which is modified to use that value. Finally gfc_conv_procedure saves the expression in that field to a pointer in between to avoid the same problem as for the first part. PR fortran/92178 gcc/fortran/ChangeLog: * trans.h (struct gfc_se): New field class_container. (struct gfc_ss_info): Ditto. (gfc_evaluate_data_ref_now): New prototype. * trans.cc (gfc_evaluate_data_ref_now): Implement it. * trans-array.cc (gfc_conv_ss_descriptor): Copy class_container field from gfc_se struct to gfc_ss_info struct. (gfc_conv_expr_descriptor): Copy class_container field from gfc_ss_info struct to gfc_se struct. * trans-expr.cc (gfc_conv_class_to_class): Use class container set in class_container field if available. (gfc_conv_variable): Set class_container field on encountering class variables or components, clear it on encountering non-class components. (gfc_conv_procedure_call): Evaluate data ref to a pointer now, and replace later references by usage of the pointer. gcc/testsuite/ChangeLog: * gfortran.dg/intent_out_20.f90: New test. --- gcc/fortran/trans-array.cc | 3 ++ gcc/fortran/trans-expr.cc | 26 ++++++++++++++++ gcc/fortran/trans.cc | 28 +++++++++++++++++ gcc/fortran/trans.h | 6 ++++ gcc/testsuite/gfortran.dg/intent_out_20.f90 | 33 +++++++++++++++++++++ 5 files changed, 96 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/intent_out_20.f90 diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index e7c51bae052..1c2af55d436 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -3271,6 +3271,7 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) gfc_add_block_to_block (block, &se.pre); info->descriptor = se.expr; ss_info->string_length = se.string_length; + ss_info->class_container = se.class_container; if (base) { @@ -7687,6 +7688,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) else if (deferred_array_component) se->string_length = ss_info->string_length; + se->class_container = ss_info->class_container; + gfc_free_ss_chain (ss); return; } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index b7e95e6d04d..5169fbcd974 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -1266,6 +1266,10 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, slen = build_zero_cst (size_type_node); } + else if (parmse->class_container != NULL_TREE) + /* Don't redundantly evaluate the expression if the required information + is already available. */ + tmp = parmse->class_container; else { /* Remove everything after the last class reference, convert the @@ -3078,6 +3082,11 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) return; } + if (sym->ts.type == BT_CLASS + && sym->attr.class_ok + && sym->ts.u.derived->attr.is_class) + se->class_container = se->expr; + /* Dereference the expression, where needed. */ se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only, is_classarray); @@ -3135,6 +3144,15 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) conv_parent_component_references (se, ref); gfc_conv_component_ref (se, ref); + + if (ref->u.c.component->ts.type == BT_CLASS + && ref->u.c.component->attr.class_ok + && ref->u.c.component->ts.u.derived->attr.is_class) + se->class_container = se->expr; + else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED + && ref->u.c.sym->attr.is_class)) + se->class_container = NULL_TREE; + if (!ref->next && ref->u.c.sym->attr.codimension && se->want_pointer && se->descriptor_only) return; @@ -6664,6 +6682,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, defer_to_dealloc_blk = true; + parmse.expr = gfc_evaluate_data_ref_now (parmse.expr, + &parmse.pre); + + if (parmse.class_container != NULL_TREE) + parmse.class_container + = gfc_evaluate_data_ref_now (parmse.class_container, + &parmse.pre); + gfc_init_block (&block); ptr = parmse.expr; if (e->ts.type == BT_CLASS) diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index 7ad85aee9e7..f1a3aacd850 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -174,6 +174,34 @@ gfc_evaluate_now (tree expr, stmtblock_t * pblock) return gfc_evaluate_now_loc (input_location, expr, pblock); } + +/* Returns a fresh pointer variable pointing to the same data as EXPR, adding + in BLOCK the initialization code that makes it point to EXPR. */ + +tree +gfc_evaluate_data_ref_now (tree expr, stmtblock_t *block) +{ + tree t = expr; + + STRIP_NOPS (t); + + /* If EXPR can be used as lhs of an assignment, we have to take the address + of EXPR. Otherwise, reassigning the pointer would retarget it to some + other data without EXPR being retargetted as well. */ + bool lvalue_p = DECL_P (t) || REFERENCE_CLASS_P (t) || INDIRECT_REF_P (t); + + tree value; + if (lvalue_p) + { + value = gfc_build_addr_expr (NULL_TREE, expr); + value = gfc_evaluate_now (value, block); + return build_fold_indirect_ref_loc (input_location, value); + } + else + return gfc_evaluate_now (expr, block); +} + + /* Like gfc_evaluate_now, but add the created variable to the function scope. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 0c8d004736d..82cdd694073 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -57,6 +57,10 @@ typedef struct gfc_se here. */ tree class_vptr; + /* When expr is a reference to a direct subobject of a class, store + the reference to the class object here. */ + tree class_container; + /* Whether expr is a reference to an unlimited polymorphic object. */ unsigned unlimited_polymorphic:1; @@ -263,6 +267,7 @@ typedef struct gfc_ss_info gfc_ss_type type; gfc_expr *expr; tree string_length; + tree class_container; union { @@ -525,6 +530,7 @@ void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr); /* If the value is not constant, Create a temporary and copy the value. */ tree gfc_evaluate_now_loc (location_t, tree, stmtblock_t *); tree gfc_evaluate_now (tree, stmtblock_t *); +tree gfc_evaluate_data_ref_now (tree, stmtblock_t *); tree gfc_evaluate_now_function_scope (tree, stmtblock_t *); /* Find the appropriate variant of a math intrinsic. */ diff --git a/gcc/testsuite/gfortran.dg/intent_out_20.f90 b/gcc/testsuite/gfortran.dg/intent_out_20.f90 new file mode 100644 index 00000000000..8e5d8c6909e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intent_out_20.f90 @@ -0,0 +1,33 @@ +! { 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 + type t + integer :: i + end type t + type u + class(t), allocatable :: ta + end type u + type(u), allocatable :: c(:) + allocate(c, source = [u(t(1)), u(t(4))]) + call bar ( & + allocated (c(c(1)%ta%i)%ta), & + c(c(1)%ta%i)%ta, & + allocated (c(c(1)%ta%i)%ta) & + ) + if (allocated (c(1)%ta)) stop 11 + if (.not. allocated (c(2)%ta)) stop 12 +contains + subroutine bar (alloc, x, alloc2) + logical :: alloc, alloc2 + class(t), allocatable, intent(out) :: x(..) + if (allocated (x)) stop 1 + if (.not. alloc) stop 2 + if (.not. alloc2) stop 3 + end subroutine bar +end From patchwork Tue Jul 11 10:32:53 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 118413 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:a6b2:0:b0:3e4:2afc:c1 with SMTP id c18csp379090vqm; Tue, 11 Jul 2023 03:36:00 -0700 (PDT) X-Google-Smtp-Source: APBJJlFssTkg7ZhsNV0t2xbW56P37xwRVX4sowheVbykBTht98TY2JxkK4ALT2CUqOASSj9VR6Pv X-Received: by 2002:a05:6512:5c7:b0:4fb:8eec:ce49 with SMTP id o7-20020a05651205c700b004fb8eecce49mr10553770lfo.31.1689071760160; Tue, 11 Jul 2023 03:36:00 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1689071760; cv=none; d=google.com; s=arc-20160816; b=tg5ElKGu8P6o/G7g6ykGpw8vkIb7Vh66qf8x0xfoi6eKzyergusyrXg2eOSMLCBneH RDd8pjUH/Yy8N4Vme80NXL0umuUONRDdXZZHtaKMJbh49/6VIJD02MdL3AhBE07wfhMZ a4Vq/sPSDRsmdNWamfkDv51sC/OgS8tjU/hOX2Cek8u5I+WWp6LmUO4RfaIgyAUuETro 4ewQesxuS9nOAUnLO/64t1Q8LDj/EtC6YG8vK9S/04O/RwOssilzxovin3BBmiIeQ9Re Tpm7/wkjPBhd9xWXV6baxY6u6VBufjdftP/tqAbnvHaMGRTT7d9GiwruTTxqFXOGDs4O uLrA== 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=DhNaFWv6kslI3Z9RlmbIRMPCZUUqOh/BCamlo+JbMBU=; fh=EAqAZnhg4AYtcBjfPm18lEF5V0R2rkI9MSWQf+svVaI=; b=z0Q9F+7KEdElQOh8/WGZjjHQeywPFr5LjpL+gpHchIb0dvwehsKuSqlYwr/yH/8Dl+ avjuaFkN8ybugb+UJcnsgj590oLGVDl2dCRkHDsNvByQCuQ9FZk0MTmSnJwS1Og5I+xO 6bc4y3NsJa8J0mQYUlkhE/XF5y/StHtFVOto3ZSiEoPAPTgUqvgg6jvpLP6UI5lWeVEl 34QRFWluRW44Vs+NwSegZi5n3nxxrHgLi1y5cPXIWaHXfUdI9uj3F4uUs7+1oqTA7AM5 n1reWS2BsNHl9CH84ZTib6Xr/pCPbcezaEfdw/b7MouLOpDijy36sTzdNouhekC3SJNh bWug== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=np2nt9MY; 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=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from server2.sourceware.org (server2.sourceware.org. [2620:52:3:1:0:246e:9693:128c]) by mx.google.com with ESMTPS id f25-20020a50ee99000000b0051e2667a8absi1857053edr.94.2023.07.11.03.35.59 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 11 Jul 2023 03:36:00 -0700 (PDT) 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=@gcc.gnu.org header.s=default header.b=np2nt9MY; 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=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id CD7263856DCB for ; Tue, 11 Jul 2023 10:35:43 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org CD7263856DCB DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1689071743; bh=DhNaFWv6kslI3Z9RlmbIRMPCZUUqOh/BCamlo+JbMBU=; 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=np2nt9MYuWwniyysKHMPnsPiJb1Mjp/fjpBW0NtIfnP7dgjZQsAI3bgmWjMXQRQDr GLa5nyfTteYphrmaStL4KYVxdiSpRDVfx4zPoJWLPR7wUrBZpOqpSJzvMvY1MrU+5J DEhov1j8xKhKG4MRTJXixkmm/LLY3gzMXvybTfmg= 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 CC1FE385770B for ; Tue, 11 Jul 2023 10:33:03 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org CC1FE385770B Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id JAfuqCdJWn02aJAg2qNA4B; 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 3/3] fortran: Reorder array argument evaluation parts [PR92178] Date: Tue, 11 Jul 2023 12:32:53 +0200 Message-Id: <20230711103253.1589353-4-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=-11.2 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: 1771120110068853767 X-GMAIL-MSGID: 1771120110068853767 In the case of an array actual arg passed to a polymorphic array dummy with INTENT(OUT) attribute, reorder the argument evaluation code to the following: - first evaluate arguments' values, and data references, - deallocate data references associated with an allocatable, intent(out) dummy, - create a class container using the freed data references. The ordering used to be incorrect between the first two items, when one argument was deallocated before a later argument evaluated its expression depending on the former argument. r14-2395-gb1079fc88f082d3c5b583c8822c08c5647810259 fixed it by treating arguments associated with an allocatable, intent(out) dummy in a separate, later block. This, however, wasn't working either if the data reference of such an argument was depending on its own content, as the class container initialization was trying to use deallocated content. This change generates class container initialization code in a separate block, so that it is moved after the deallocation block without moving the rest of the argument evaluation code. This alone is not sufficient to fix the problem, because the class container generation code repeatedly uses the full expression of the argument at a place where deallocation might have happened already. This is non-optimal, but may also be invalid, because the data reference may depend on its own content. In that case the expression can't be evaluated after the data has been deallocated. As in the scalar case previously treated, this is fixed by saving the data reference to a pointer before any deallocation happens, and then only refering to the pointer. gfc_reset_vptr is updated to take into account the already evaluated class container if it's available. Contrary to the scalar case, one hunk is needed to wrap the parameter evaluation in a conditional, to avoid regressing in optional_class_2.f90. This used to be handled by the class wrapper construction which wrapped the whole code in a conditional. With this change the class wrapper construction can't see the parameter evaluation code, so the latter is updated with an additional handling for optional arguments. PR fortran/92178 gcc/fortran/ChangeLog: * trans.h (gfc_reset_vptr): Add class_container argument. * trans-expr.cc (gfc_reset_vptr): Ditto. If a valid vptr can be obtained through class_container argument, bypass evaluation of e. (gfc_conv_procedure_call): Wrap the argument evaluation code in a conditional if the associated dummy is optional. Evaluate the data reference to a pointer now, and replace later references with usage of the pointer. gcc/testsuite/ChangeLog: * gfortran.dg/intent_out_21.f90: New test. --- gcc/fortran/trans-expr.cc | 86 ++++++++++++++++----- gcc/fortran/trans.h | 2 +- gcc/testsuite/gfortran.dg/intent_out_21.f90 | 33 ++++++++ 3 files changed, 101 insertions(+), 20 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/intent_out_21.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 5169fbcd974..dbb04f8c434 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -529,24 +529,32 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold, } -/* Reset the vptr to the declared type, e.g. after deallocation. */ +/* Reset the vptr to the declared type, e.g. after deallocation. + Use the variable in CLASS_CONTAINER if available. Otherwise, recreate + one with E. The generated assignment code is added at the end of BLOCK. */ void -gfc_reset_vptr (stmtblock_t *block, gfc_expr *e) +gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container) { - gfc_symbol *vtab; - tree vptr; - tree vtable; - gfc_se se; + tree vptr = NULL_TREE; - /* Evaluate the expression and obtain the vptr from it. */ - gfc_init_se (&se, NULL); - if (e->rank) - gfc_conv_expr_descriptor (&se, e); - else - gfc_conv_expr (&se, e); - gfc_add_block_to_block (block, &se.pre); - vptr = gfc_get_vptr_from_expr (se.expr); + if (class_container != NULL_TREE) + vptr = gfc_get_vptr_from_expr (class_container); + + if (vptr == NULL_TREE) + { + gfc_se se; + + /* Evaluate the expression and obtain the vptr from it. */ + gfc_init_se (&se, NULL); + if (e->rank) + gfc_conv_expr_descriptor (&se, e); + else + gfc_conv_expr (&se, e); + gfc_add_block_to_block (block, &se.pre); + + vptr = gfc_get_vptr_from_expr (se.expr); + } /* If a vptr is not found, we can do nothing more. */ if (vptr == NULL_TREE) @@ -556,6 +564,9 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e) gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0)); else { + gfc_symbol *vtab; + tree vtable; + /* Return the vptr to the address of the declared type. */ vtab = gfc_find_derived_vtab (e->ts.u.derived); vtable = vtab->backend_decl; @@ -6847,6 +6858,24 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_expr_descriptor (&parmse, e); bool defer_to_dealloc_blk = false; + if (fsym->attr.optional + && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional) + { + stmtblock_t block; + + gfc_init_block (&block); + gfc_add_block_to_block (&block, &parmse.pre); + + tree t = fold_build3_loc (input_location, COND_EXPR, + void_type_node, + gfc_conv_expr_present (e->symtree->n.sym), + gfc_finish_block (&block), + build_empty_stmt (input_location)); + + gfc_add_expr_to_block (&parmse.pre, t); + } + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ if (fsym->attr.intent == INTENT_OUT @@ -6855,6 +6884,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, stmtblock_t block; tree ptr; + /* In case the data reference to deallocate is dependent on + its own content, save the resulting pointer to a variable + and only use that variable from now on, before the + expression becomes invalid. */ + parmse.expr = gfc_evaluate_data_ref_now (parmse.expr, + &parmse.pre); + + if (parmse.class_container != NULL_TREE) + parmse.class_container + = gfc_evaluate_data_ref_now (parmse.class_container, + &parmse.pre); + gfc_init_block (&block); ptr = parmse.expr; ptr = gfc_class_data_get (ptr); @@ -6868,7 +6909,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, void_type_node, ptr, null_pointer_node); gfc_add_expr_to_block (&block, tmp); - gfc_reset_vptr (&block, e); + gfc_reset_vptr (&block, e, parmse.class_container); if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE @@ -6890,9 +6931,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, defer_to_dealloc_blk = true; } + gfc_se class_se = parmse; + gfc_init_block (&class_se.pre); + gfc_init_block (&class_se.post); + /* The conversion does not repackage the reference to a class array - _data descriptor. */ - gfc_conv_class_to_class (&parmse, e, fsym->ts, false, + 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), @@ -6902,9 +6947,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, CLASS_DATA (fsym)->attr.class_pointer || CLASS_DATA (fsym)->attr.allocatable); - /* Defer repackaging after deallocation. */ - if (defer_to_dealloc_blk) - gfc_add_block_to_block (&dealloc_blk, &parmse.pre); + 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); } else { diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 82cdd694073..7b41e8912b4 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -451,7 +451,7 @@ tree gfc_vptr_def_init_get (tree); tree gfc_vptr_copy_get (tree); tree gfc_vptr_final_get (tree); tree gfc_vptr_deallocate_get (tree); -void gfc_reset_vptr (stmtblock_t *, gfc_expr *); +void gfc_reset_vptr (stmtblock_t *, gfc_expr *, tree = NULL_TREE); void gfc_reset_len (stmtblock_t *, gfc_expr *); tree gfc_get_class_from_gfc_expr (gfc_expr *); tree gfc_get_class_from_expr (tree); diff --git a/gcc/testsuite/gfortran.dg/intent_out_21.f90 b/gcc/testsuite/gfortran.dg/intent_out_21.f90 new file mode 100644 index 00000000000..5f61a547471 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intent_out_21.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR fortran/92178 +! Check that in the case of a data reference depending on its own content +! passed as actual argument to an INTENT(OUT) dummy, no reference to the +! content happens after the deallocation. + +program p + implicit none + type t + integer :: i + end type t + type u + class(t), allocatable :: ta(:) + end type u + type(u), allocatable :: c(:) + c = [u([t(1), t(3)]), u([t(4), t(9)])] + call bar ( & + allocated (c(c(1)%ta(1)%i)%ta), & + c(c(1)%ta(1)%i)%ta, & + allocated (c(c(1)%ta(1)%i)%ta) & + ) + if (allocated(c(1)%ta)) stop 11 + if (.not. allocated(c(2)%ta)) stop 12 +contains + subroutine bar (alloc, x, alloc2) + logical :: alloc, alloc2 + class(t), allocatable, intent(out) :: x(:) + if (allocated (x)) stop 1 + if (.not. alloc) stop 2 + if (.not. alloc2) stop 3 + end subroutine bar +end