From patchwork Sun Jul 2 20:38:55 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 115150 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:9f45:0:b0:3ea:f831:8777 with SMTP id v5csp134757vqx; Sun, 2 Jul 2023 13:39:51 -0700 (PDT) X-Google-Smtp-Source: APBJJlE9w+gi/jpNXqGSxBAuhPzDE/WdWKpPQwEmf4fJKu48Ufuc5R84LP2Bd4lqdCibILhULLJ/ X-Received: by 2002:a17:906:4806:b0:992:ef60:aadd with SMTP id w6-20020a170906480600b00992ef60aaddmr5836006ejq.13.1688330391437; Sun, 02 Jul 2023 13:39:51 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1688330391; cv=none; d=google.com; s=arc-20160816; b=zYnC0BSewlpQylrA2FAdYMuQWCOOegeFHTDk92hBNetMoQDSyo1RojRbAbmeKyUpw+ BTae/kceh0XvnWigUkfDofReWEb+X5aBPQeu+3DMLAjiIMWCl+gEUkF8qWqDYPajKlk5 xRcx1e8gse+93ywHTDT1K3RdXwHOVXeQ2Kk7z9XQVafblz4zbukOq7qSTCOoFjmj02h2 WZWn1qxgz1hW9w+JTvKf6dtpgfmG7wEw4rs/8hlYrBgGQEQnJP4/hXUi+kCuceknEe6e DwYOnz7wqNwprvtlJNv9lYogHSx/Gdt3kuYfDewl1dvGbsk9A/VOoRzKJ3GTPOxAFMvl 2EYA== 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:ui-outboundreport :sensitivity:importance:date:subject:to:message-id:mime-version :dmarc-filter:delivered-to:dkim-signature:dkim-filter; bh=vc2fq/cCPJy2M4tt2WCXSLFlYX559Vask9GmnZZbEjc=; fh=+IEfvAe+9BRgPHWhQEl2uIBTtAiiGDh1ExRZeB5JJoc=; b=evDHYWtDlBtmQ9MpYoQg28QC7F65YJ8HEZoUJ4KeRV8ZXVCzpPk1zrZlicJt7vZjh7 lpbGvUba51fIuuHqxT/Rz8NnKPBdsFycuJnzrqbTs7296AHTu8+qgtpZRN0gC8Gp6QG3 H+SAjvMBFLqtx91y31nPgIfI5xKKw1Y9EUBCoODLR9AgmRliRCQIa28h6qQkKODg6Kk/ WjPnRsf10zVuMh6VLVeT4rxvF7JICTkx2AFQwIzJh1ihJAnyv4gaajpcJgec9Wj5so9x /3hAEf3rCBjJS7cMEndUxQlbEgRK2ih5jsbWd7c/8CvCw4AOEtndNIYp4L9DiM/exGjP g8tQ== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=BasyLwAt; 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 xa10-20020a170907b9ca00b009873cbdd6cfsi10190712ejc.706.2023.07.02.13.39.50 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sun, 02 Jul 2023 13:39:51 -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=BasyLwAt; 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 336183857B98 for ; Sun, 2 Jul 2023 20:39:42 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 336183857B98 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1688330382; bh=vc2fq/cCPJy2M4tt2WCXSLFlYX559Vask9GmnZZbEjc=; h=To:Subject:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=BasyLwAtk3uPYn5WovGg61sORF5sHirJt7yp6seCD4VYAqPnWYdUIdBJ48RP6O3S+ +4ErwigJPh3uSK7V0eEJfDn0wrqYpVGuFQDg5Dg9NqOmdjU0zCU/mkHWOQK27/cE+Q /KhMebuznJetWNRhSWJ+ezgatSOLK9Ge8Fp8H328= 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.15.15]) by sourceware.org (Postfix) with ESMTPS id 3394A3858412; Sun, 2 Jul 2023 20:38:57 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 3394A3858412 X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [79.232.149.247] ([79.232.149.247]) by web-mail.gmx.net (3c-app-gmx-bs45.server.lan [172.19.170.97]) (via HTTP); Sun, 2 Jul 2023 22:38:55 +0200 MIME-Version: 1.0 Message-ID: To: fortran , gcc-patches Subject: [PATCH] Fortran: fixes for procedures with ALLOCATABLE,INTENT(OUT) arguments [PR92178] Date: Sun, 2 Jul 2023 22:38:55 +0200 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:3Oz5MrbGAgAqvg6CJKiYSo7c2FY5FCv//77+26caQ/EO2zDbkLUFHenVOOKEc5URMYTGc N14IMuG4gLjLO+iiwlBlcD6je3SsgbYp1kOMG1IpeQ6wOWy1dbgvrZ13NjEl4ewOo8AOXyUHfMYv ww1Y6TdezF3zEzXuZ07N54vtTY4uTVQe6QOPX+jxJbqLBPLhSJdMkQ2giMi5C322gYN+ZkAIE/q4 FadldlaZQbz6kw1PNVyivJ6LcZCILrFXCdYRfwVMPai7JN46VLFckvFzYvgzcLiik/af9ZquVdKF LI= UI-OutboundReport: notjunk:1;M01:P0:pIqu4p71omY=;sWdKKdkfoV3l03HABiYgB3nxnAB 3btL0N2vutpFn8EH+02bwG7jA4XAl+fgvklj+frtxKgbBU3cx3kE+zw3KnPrXGScma/ySIXJw 7jEqNiPDI53QZiOf6sL9Bha8t1wW85FpJcngJ95eZS8YLbqhF7hM5ZUAEeyuGGYLLZ7htSxcY thnkX6sQXaPiH/IJWswfifJQOFb0b/AUZcJfyIwLX4MNchMPFWHgZgUuUR6nOx8+Vd2sH47ug UInFFGsG8ZU3RssmVQpbOmmWPAi7mNt6t+XIrO80zNJ+Ll0aIrBnt0JcwIwe5ioIiBlDuoqO1 O4jEpH4AtFcBb7W3kuc9aYBRC3DxUQ1i/coY+XZ6q30gHA+RfSysV3fk/3m+cSqlxdhe4a78u mT/aBeaDWuGhLVG3W7NA+IY9oQ3Jro2rNthc9Ifos0YdVlPzj3zzgHIO/xB9I2ty+AOLyR+an DFyfbtERVqHf0XS68YqDodS6NfOIExk+N3dxymuyrXiedtvQGKktL74E17WAFU+SF/3pG3YWU qs14t/dVfOfuwrbauJZFihMyLztsYMJMFjOOOqTlOOVcirofTblmQ3GFk9xqw2ZCyP0LyzuYa y9FUVXtz2ZYLgMV+/ri3YfI4DVJMznHTxvx/9dvo5eyvZm1gyizIuOwosumHY9ydmZkhwud/p 7WJPScv0IirDtHWv+zObWCkvj7YtxVXSxMd/AgtYLX6aszvK3XvqYfritMThdhFBdOhExf2lU 2A1KQWTG3y19a1PIscjMXCTMNwwbKb29vjFdgwtdy+qZOJqDpJ8ZWuVV3xNuwBVvw+oiBmxJF /Lyb9s464kdpuN0kpVIjpqOg== X-Spam-Status: No, score=-10.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_BARRACUDACENTRAL, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H2, 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.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Harald Anlauf via Gcc-patches From: Harald Anlauf Reply-To: Harald Anlauf Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: =?utf-8?q?INBOX?= X-GMAIL-THRID: =?utf-8?q?1770342728591055133?= X-GMAIL-MSGID: =?utf-8?q?1770342728591055133?= Dear all, the attached patch fixes a long-standing issue with the order of evaluation of procedure argument expressions and deallocation of allocatable actual arguments passed to allocatable dummies with intent(out) attribute. It is based on an initial patch by Steve, handles issues pointed out by Tobias, and includes a suggestion by Tobias to scan the procedure arguments first to decide whether the creation of temporaries is needed. There is one unresolved issue left that might be more general: it appears to affect character arguments (only) in that quite often there still is no temporary generated. I haven't found the reason why and would like to defer this, unless someone has a good suggestion. Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald From 609ba636927811cddc74fb815cb18809c7d33565 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Sun, 2 Jul 2023 22:14:19 +0200 Subject: [PATCH] Fortran: fixes for procedures with ALLOCATABLE,INTENT(OUT) arguments [PR92178] gcc/fortran/ChangeLog: PR fortran/92178 * trans-expr.cc (gfc_conv_procedure_call): Check procedures for allocatable dummy arguments with INTENT(OUT) and move deallocation of actual arguments after evaluation of argument expressions before the procedure is executed. gcc/testsuite/ChangeLog: PR fortran/92178 * gfortran.dg/pr92178.f90: New test. * gfortran.dg/pr92178_2.f90: New test. Co-authored-by: Steven G. Kargl --- gcc/fortran/trans-expr.cc | 52 ++++++++++++++-- gcc/testsuite/gfortran.dg/pr92178.f90 | 83 +++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/pr92178_2.f90 | 46 ++++++++++++++ 3 files changed, 177 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pr92178.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr92178_2.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 30946ba3f63..16e8f037cfc 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -6085,9 +6085,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else info = NULL; - stmtblock_t post, clobbers; + stmtblock_t post, clobbers, dealloc_blk; gfc_init_block (&post); gfc_init_block (&clobbers); + gfc_init_block (&dealloc_blk); gfc_init_interface_mapping (&mapping); if (!comp) { @@ -6117,6 +6118,33 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && UNLIMITED_POLY (sym) && comp && (strcmp ("_copy", comp->name) == 0); + /* First scan argument list for allocatable actual arguments passed to + allocatable dummy arguments with INTENT(OUT). As the corresponding + actual arguments are deallocated before execution of the procedure, we + evaluate actual argument expressions to avoid problems with possible + dependencies. */ + bool force_eval_args = false; + gfc_formal_arglist *tmp_formal; + for (arg = args, tmp_formal = formal; arg != NULL; + arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL) + { + e = arg->expr; + fsym = tmp_formal ? tmp_formal->sym : NULL; + if (e && fsym + && e->expr_type == EXPR_VARIABLE + && fsym->attr.intent == INTENT_OUT + && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok + ? CLASS_DATA (fsym)->attr.allocatable + : fsym->attr.allocatable) + && e->symtree + && e->symtree->n.sym + && gfc_variable_attr (e, NULL).allocatable) + { + force_eval_args = true; + break; + } + } + /* Evaluate the arguments. */ for (arg = args, argc = 0; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL, ++argc) @@ -6680,7 +6708,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else tmp = gfc_finish_block (&block); - gfc_add_expr_to_block (&se->pre, tmp); + gfc_add_expr_to_block (&dealloc_blk, tmp); } /* A class array element needs converting back to be a @@ -6980,7 +7008,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, build_empty_stmt (input_location)); } if (tmp != NULL_TREE) - gfc_add_expr_to_block (&se->pre, tmp); + gfc_add_expr_to_block (&dealloc_blk, tmp); } tmp = parmse.expr; @@ -7004,7 +7032,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, void_type_node, gfc_conv_expr_present (e->symtree->n.sym), tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&se->pre, tmp); + gfc_add_expr_to_block (&dealloc_blk, tmp); } } } @@ -7101,6 +7129,21 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } } + /* If any actual argument of the procedure is allocatable and passed + to an allocatable dummy with INTENT(OUT), we conservatively + evaluate all actual argument expressions before deallocations are + performed and the procedure is executed. This ensures we conform + to F2023:15.5.3, 15.5.4. Create temporaries except for constants, + variables, and functions returning pointers that can appear in a + variable definition context. */ + if (e && fsym && force_eval_args + && e->expr_type != EXPR_VARIABLE + && !gfc_is_constant_expr (e) + && (e->expr_type != EXPR_FUNCTION + || !(gfc_expr_attr (e).pointer + || gfc_expr_attr (e).proc_pointer))) + parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre); + if (fsym && need_interface_mapping && e) gfc_add_interface_mapping (&mapping, fsym, &parmse, e); @@ -7499,6 +7542,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, vec_safe_push (arglist, parmse.expr); } + gfc_add_block_to_block (&se->pre, &dealloc_blk); gfc_add_block_to_block (&se->pre, &clobbers); gfc_finish_interface_mapping (&mapping, &se->pre, &se->post); diff --git a/gcc/testsuite/gfortran.dg/pr92178.f90 b/gcc/testsuite/gfortran.dg/pr92178.f90 new file mode 100644 index 00000000000..de3998d6b8c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr92178.f90 @@ -0,0 +1,83 @@ +! { dg-do run } +! +! PR fortran/92178 +! Re-order argument deallocation + +program p + implicit none + integer, allocatable :: a(:) + class(*), allocatable :: c(:) + type t + integer, allocatable :: a(:) + end type t + type(t) :: b + integer :: k = -999 + + ! Test based on original PR + a = [1] + call assign (a, (max(a(1),0))) + if (allocated (a)) stop 9 + if (k /= 1) stop 10 + + ! Additional variations based on suggestions by Tobias Burnus + ! to check that argument expressions are evaluated early enough + a = [1, 2] + call foo (allocated (a), size (a), test (a), a) + if (allocated (a)) stop 11 + + a = [1, 2] + k = 1 + call foo (allocated (a), size (a), test (k*a), a) + if (allocated (a)) stop 12 + + b% a = [1, 2] + call foo (allocated (b% a), size (b% a), test (b% a), b% a) + if (allocated (b% a)) stop 13 + + c = [3, 4] + call bar (allocated (c), size (c), test2 (c), c) + if (allocated (c)) stop 14 + +contains + + subroutine assign (a, i) + integer, allocatable, intent(out) :: a(:) + integer, value :: i + k = i + end subroutine + + subroutine foo (alloc, sz, tst, x) + logical, value :: alloc, tst + integer, value :: sz + integer, allocatable, intent(out) :: x(:) + if (allocated (x)) stop 1 + if (.not. alloc) stop 2 + if (sz /= 2) stop 3 + if (.not. tst) stop 4 + end subroutine foo + ! + logical function test (zz) + integer :: zz(2) + test = zz(2) == 2 + end function test + ! + subroutine bar (alloc, sz, tst, x) + logical, value :: alloc, tst + integer, value :: sz + class(*), allocatable, intent(out) :: x(:) + if (allocated (x)) stop 5 + if (.not. alloc) stop 6 + if (sz /= 2) stop 7 + if (.not. tst) stop 8 + end subroutine bar + ! + logical function test2 (zz) + class(*), intent(in) :: zz(:) + select type (zz) + type is (integer) + test2 = zz(2) == 4 + class default + stop 99 + end select + end function test2 +end diff --git a/gcc/testsuite/gfortran.dg/pr92178_2.f90 b/gcc/testsuite/gfortran.dg/pr92178_2.f90 new file mode 100644 index 00000000000..bc9208dcf6d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr92178_2.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! +! PR fortran/92178 +! Contributed by Tobias Burnus + +program foo + implicit none (type, external) + + type t + end type t + + type, extends(t) :: t2 + end type t2 + + type(t2) :: x2 + class(t), allocatable :: aa + + call check_intentout_false(allocated(aa), aa, & + allocated(aa)) + if (allocated(aa)) stop 1 + + allocate(t2 :: aa) + if (.not.allocated(aa)) stop 2 + if (.not.same_type_as(aa, x2)) stop 3 + call check_intentout_true(allocated(aa), (same_type_as(aa, x2)), aa, & + allocated(aa), (same_type_as(aa, x2))) + if (allocated(aa)) stop 4 + +contains + subroutine check_intentout_false(alloc1, yy, alloc2) + logical, value :: alloc1, alloc2 + class(t), allocatable, intent(out) :: yy + if (allocated(yy)) stop 11 + if (alloc1) stop 12 + if (alloc2) stop 13 + end subroutine check_intentout_false + subroutine check_intentout_true(alloc1, same1, zz, alloc2, same2) + logical, value :: alloc1, alloc2, same1, same2 + class(t), allocatable, intent(out) :: zz + if (allocated(zz)) stop 21 + if (.not.alloc1) stop 22 + if (.not.alloc2) stop 23 + if (.not.same1) stop 24 + if (.not.same2) stop 25 + end subroutine check_intentout_true +end program -- 2.35.3