From patchwork Fri Mar 12 20:43:14 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 1452389 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=qFfWH9kJ; dkim-atps=neutral Received: from sourceware.org (unknown [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4DxySs3NRqz9sRN for ; Sat, 13 Mar 2021 07:43:24 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 223F33861828; Fri, 12 Mar 2021 20:43:20 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 223F33861828 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1615581800; bh=eOZkkCb+BnNO0k8pkyVbbDkyCqVxtXPDXxp76YVWmQg=; h=To:Subject:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=qFfWH9kJq1qjALbsqLi1hCHuWtCOr4jm31jTSeiYqRfO295n4pi1ya0uWXsPiSYWl 7j2jz0nf9HLeFHYYE/uXwHzI/ALpF7+it4XZ+4xbbzJFY8PMgnRUVflsyctfuDn4fu um04DVqPpe4sfupc4ailX7i8KHIvreypT3EAlSO0= 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.22]) by sourceware.org (Postfix) with ESMTPS id 5C8DF3857831; Fri, 12 Mar 2021 20:43:16 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 5C8DF3857831 X-UI-Sender-Class: 01bb95c1-4bf8-414a-932a-4f6e2808ef9c Received: from [93.207.90.50] ([93.207.90.50]) by web-mail.gmx.net (3c-app-gmx-bap22.server.lan [172.19.172.92]) (via HTTP); Fri, 12 Mar 2021 21:43:14 +0100 MIME-Version: 1.0 Message-ID: To: fortran , gcc-patches Subject: [PATCH] PR fortran/99112 - [11 Regression] ICE with runtime diagnostics for SIZE intrinsic function Date: Fri, 12 Mar 2021 21:43:14 +0100 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:0HqoPxCpq/KSp5QQRSY3FAqr7pAjKlGVlk8KXUwLMeUMF5vtkaQODwW+MldUCbBEUpaYG K/l7Vnqq2pYoQS3NftPLDGRTHHk2uek2EPYo3Wxiah+j8FNCL3aWzKtI0F3b6ExEuRapb8R0e0Up zb+jRLCWMZHUwRdaw+pILM61QfvMq6S5ZIUk32RpMmrfmMPmQ+S7iBuUNdGGvHgF5qEhWWFkXzDX uOA8FxCFzS+lsgDwqTHc9e5FuZwLGe/uaq2hn6RtLW3vLrJHYnzmFzSmtgaCOSQVk4ep+QnDHble 10= X-UI-Out-Filterresults: notjunk:1;V03:K0:OGBCquDgAl8=:hVec/WaqbABElzVBh/ktpK AEv92Bw4SZ93Jknym2Cul4zdyx7wmoytFFPC7yA0HJX1CnBZhq/Byq39zhAn1S0bCz31by5Zq VnZQLMRTasyXyjmfMAnQ8bvEY+rfNuTUnsaoHAWs61egbQPKIYnG8q/MIYApCfUk+TtOGVTf0 skE2LvG3IRO6Cz/n+43VFJqkpRcVwN2zst3/518h8Abwp1Fx0OlBWNuAWoTW/ww662QyJKxsu j+5FvHaRYGlXFDgQsjckZX8S96U7qMBC54FymBmwPaIBUpfgKi9snjY2Z8lgK+DIosdoNhzRV iwaTc2wDRoidYCi6aHryPBSulYSF1meztQ9Vl54p/WDmMc7AQYRRm0rXGN3mrj4vLtWt/WitY Pwh1AHvkn9C8UkwueDYuCFrhPpPiRe5YJSzXbrKiGLvRl2d2BAkBy9T2M87WwpZamM6GZ/kv+ OgYvPb1Y4DeDtGLKCecmUSdAkvnpQO2nTRbKYEr70o8EHXZII+BBchjglyiGmQAozDW83neVu xtMNoOAhQvx0vxmW7l+C5PJ+7ZCTFJyIPRY0d0gpAZ0Srpp4eKlRtowYFeWLRFDk+QZ9F77FR Wxj7a2ivgDpoE= X-Spam-Status: No, score=-12.4 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H2, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) 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@gcc.gnu.org Sender: "Gcc-patches" Dear all, the addition of runtime checks for the SIZE intrinsic created a regression that showed up for certain CLASS arguments to procedures. Paul did most of the work (~ 99%), but asked me to dig into an issue with an inappropriately selected error message. This actually turned out to be a simple one-liner on top of Paul's patch. Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald P.S.: I couldn't find a Changelog entry that uses co-authors. Is the version below correct? PR fortran/99112 - ICE with runtime diagnostics for SIZE intrinsic function Add/fix handling of runtime checks for CLASS arguments with ALLOCATABLE or POINTER attribute. gcc/fortran/ChangeLog: * trans-expr.c (gfc_conv_procedure_call): Fix runtime checks for CLASS arguments. * trans-intrinsic.c (gfc_conv_intrinsic_size): Likewise. gcc/testsuite/ChangeLog: * gfortran.dg/pr99112.f90: New test. Co-authored-by: Paul Thomas diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 85c16d7f4c3..53c47e18dfd 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -6662,6 +6662,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, symbol_attribute attr; char *msg; tree cond; + tree temp; if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION) attr = gfc_expr_attr (e); @@ -6732,16 +6733,25 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else goto end_pointer_check; - tmp = parmse.expr; + if (fsym && fsym->ts.type == BT_CLASS) + { + temp = build_fold_indirect_ref_loc (input_location, + parmse.expr); + temp = gfc_class_data_get (temp); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (temp))) + temp = gfc_conv_descriptor_data_get (temp); + } + else + temp = parmse.expr; /* If the argument is passed by value, we need to strip the INDIRECT_REF. */ - if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr))) - tmp = gfc_build_addr_expr (NULL_TREE, tmp); + if (!POINTER_TYPE_P (TREE_TYPE (temp))) + temp = gfc_build_addr_expr (NULL_TREE, temp); cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, tmp, - fold_convert (TREE_TYPE (tmp), + logical_type_node, temp, + fold_convert (TREE_TYPE (temp), null_pointer_node)); } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 9cf3642f694..5e53d1162fa 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -8006,8 +8006,10 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) { symbol_attribute attr; char *msg; + tree temp; + tree cond; - attr = gfc_expr_attr (e); + attr = sym ? sym->attr : gfc_expr_attr (e); if (attr.allocatable) msg = xasprintf ("Allocatable argument '%s' is not allocated", e->symtree->n.sym->name); @@ -8017,14 +8019,24 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) else goto end_arg_check; - argse.descriptor_only = 1; - gfc_conv_expr_descriptor (&argse, actual->expr); - tree temp = gfc_conv_descriptor_data_get (argse.expr); - tree cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, temp, - fold_convert (TREE_TYPE (temp), - null_pointer_node)); + if (sym) + { + temp = gfc_class_data_get (sym->backend_decl); + temp = gfc_conv_descriptor_data_get (temp); + } + else + { + argse.descriptor_only = 1; + gfc_conv_expr_descriptor (&argse, actual->expr); + temp = gfc_conv_descriptor_data_get (argse.expr); + } + + cond = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, temp, + fold_convert (TREE_TYPE (temp), + null_pointer_node)); gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg); + free (msg); } end_arg_check: diff --git a/gcc/testsuite/gfortran.dg/pr99112.f90 b/gcc/testsuite/gfortran.dg/pr99112.f90 new file mode 100644 index 00000000000..94010615b83 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr99112.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fcheck=pointer -fdump-tree-original" } +! PR99112 - ICE with runtime diagnostics for SIZE intrinsic function + +module m + type t + end type +contains + function f (x, y) result(z) + class(t) :: x(:) + class(t) :: y(size(x)) + type(t) :: z(size(x)) + end + function g (x) result(z) + class(*) :: x(:) + type(t) :: z(size(x)) + end + subroutine s () + class(t), allocatable :: a(:), b(:), c(:), d(:) + class(t), pointer :: p(:) + c = f (a, b) + d = g (p) + end +end +! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 3 "original" } } +! { dg-final { scan-tree-dump-times "Allocatable actual argument" 2 "original" } } +! { dg-final { scan-tree-dump-times "Pointer actual argument" 1 "original" } }