From patchwork Thu Sep 23 19:13:59 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 45397 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id BC3973858003 for ; Thu, 23 Sep 2021 19:14:34 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa4.mentor.iphmx.com (esa4.mentor.iphmx.com [68.232.137.252]) by sourceware.org (Postfix) with ESMTPS id BA9E73858D34; Thu, 23 Sep 2021 19:14:07 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org BA9E73858D34 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: yKuwJtO2rHZi051wydYCb/BxqQ7tI/eWYMNgu6/teJd8UlXJOT5aLdiloVqXahoMUxkXrjnIlk hOuQpsGEgZW6nYkhmEq+meBq0wlUreEZRxMuKjUeK58SbzgTRTT3/qr3Uo7Sd2Q6gMmHhg+y8s axc3UuT/Al3JZaXHAMOwR/xMKpT4lQRIEFbgZHF1oPgzOPFaxlOFiTGVQL4mhV2j49S7E/tNIF roXlbVXmiLIVOjCQrAvXOMXuiXKEuybMD5yNMtcP3lGNsvABHd5CP9uhMixwpijbBVuFjYsm0W sRxUN1dz3isHh3yRsiua/JcS X-IronPort-AV: E=Sophos;i="5.85,317,1624348800"; d="diff'?scan'208";a="66397995" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa4.mentor.iphmx.com with ESMTP; 23 Sep 2021 11:14:06 -0800 IronPort-SDR: zxNcmLzbeNwlDI1NPMaT8WL2Fo3Rqe86BVFdsHg4JyiSNTniOXjn1a8pr6flEZPW7qQvJvMzJT 3WPq4BDad8EfW8ig3gcfKB7jaZww07w019zfpIO5QtMKdNeBXup5QpUMJ0FPt0JYu1zXuunZHR IOSYa20zWFrspULDSnuYr3uKb+kFpkzBa8hDotE6wWAleWtBf2/b62duL7l+Dyh3XHlNuTKkpF 9khZXJxdYZVrOiuVX00mWNx8+/G9aQrU0qRBrzXvn5RkGPdstaJgkhzltJO/zoP46gmywiFPqb jbA= Subject: [Patch] Fortran: Fix associated intrinsic with assumed rank [PR101334] [was: [PATCH, Fortran] Fixes for F2018 C838 (PR fortran/101334)] From: Tobias Burnus To: Sandra Loosemore , "gcc-patches@gcc.gnu.org" , "fortran@gcc.gnu.org" References: Message-ID: Date: Thu, 23 Sep 2021 21:13:59 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.14.0 MIME-Version: 1.0 In-Reply-To: Content-Language: en-US X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-09.mgc.mentorg.com (139.181.222.9) To svr-ies-mbx-01.mgc.mentorg.com (139.181.222.1) X-Spam-Status: No, score=-11.6 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) 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: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" On 20.09.21 09:58, Tobias Burnus wrote: > On 20.09.21 06:01, Sandra Loosemore wrote: >> This patch fixes some bugs in handling of assumed-rank arguments >> revealed by the TS29113 testsuite, ... giving a bogus error when >> passing one as the first argument to the ASSOCIATED intrinsic. ... > > ... if I try the following testcase, which is now permitted, I get > two ICEs. Can you check? > > * The first one seems to be a bug in gfc_conv_intrinsic_function, which > assumes also for assumed rank that if the first argument is an array, > the second argument must also be an array. > > * For the second one, I see in the dump: > p->dim[p->dtype.rank + -1].stride > is seems as '-1' is gfc_array_index_type while 'dtype.rank' is > signed_char_type_node. I fixed that issue + extended the testcase. OK for mainline? Tobias PS: Sorry for the testcase, it should have used a separate function for scalar vs. array target, but it somehow evolved like that. PPS: Pending patches: (1) this one, (2) "Fortran: Improve file-reading error diagnostic [PR55534]" (third in the series), (3) "[Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070]" – plus (4) GFC<->CFI array-descriptor conversion patch, but I will repost an extended/cleaned-up version soon. ----------------- Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955 Fortran: Fix associated intrinsic with assumed rank [PR101334] ASSOCIATE (ptr, tgt) takes as first argument also an assumed-rank array; however, using it together with a tgt (required to be non assumed rank) had issues for both scalar and nonscalar tgt. PR fortran/101334 gcc/fortran/ChangeLog: * trans-intrinsic.c (gfc_conv_associated): Support assumed-rank 'pointer' with scalar/array 'target' argument. libgfortran/ChangeLog: * intrinsics/associated.c (associated): Also check for same rank. gcc/testsuite/ChangeLog: * gfortran.dg/associated_assumed_rank.f90: New test. gcc/fortran/trans-intrinsic.c | 30 +++-- .../gfortran.dg/associated_assumed_rank.f90 | 126 +++++++++++++++++++++ libgfortran/intrinsics/associated.c | 3 +- 3 files changed, 149 insertions(+), 10 deletions(-) diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 612ca41a016..60e94f0bdc2 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -8974,7 +8974,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) gfc_se arg2se; tree tmp2; tree tmp; - tree nonzero_arraylen; + tree nonzero_arraylen = NULL_TREE; gfc_ss *ss; bool scalar; @@ -9074,14 +9074,16 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) { tmp = gfc_conv_descriptor_rank (arg1se.expr); tmp = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (tmp), tmp, gfc_index_one_node); + TREE_TYPE (tmp), tmp, + build_int_cst (TREE_TYPE (tmp), 1)); } else tmp = gfc_rank_cst[arg1->expr->rank - 1]; tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp); - nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, tmp, - build_int_cst (TREE_TYPE (tmp), 0)); + if (arg2->expr->rank != 0) + nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); /* A pointer to an array, call library function _gfor_associated. */ arg1se.want_pointer = 1; @@ -9091,16 +9093,26 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) arg2se.want_pointer = 1; arg2se.force_no_tmp = 1; - gfc_conv_expr_descriptor (&arg2se, arg2->expr); + if (arg2->expr->rank != 0) + gfc_conv_expr_descriptor (&arg2se, arg2->expr); + else + { + gfc_conv_expr (&arg2se, arg2->expr); + arg2se.expr + = gfc_conv_scalar_to_descriptor (&arg2se, arg2se.expr, + gfc_expr_attr (arg2->expr)); + arg2se.expr = gfc_build_addr_expr (NULL_TREE, arg2se.expr); + } gfc_add_block_to_block (&se->pre, &arg2se.pre); gfc_add_block_to_block (&se->post, &arg2se.post); se->expr = build_call_expr_loc (input_location, gfor_fndecl_associated, 2, arg1se.expr, arg2se.expr); se->expr = convert (logical_type_node, se->expr); - se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, se->expr, - nonzero_arraylen); + if (arg2->expr->rank != 0) + se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, se->expr, + nonzero_arraylen); } /* If target is present zero character length pointers cannot diff --git a/gcc/testsuite/gfortran.dg/associated_assumed_rank.f90 b/gcc/testsuite/gfortran.dg/associated_assumed_rank.f90 new file mode 100644 index 00000000000..f1b91998006 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associated_assumed_rank.f90 @@ -0,0 +1,126 @@ +! { dg-do run } + +! PR fortran/101334 + +implicit none (type, external) +real, target :: AT(10,10), BT +real, contiguous, pointer :: A(:,:) +real, pointer :: B +real, pointer :: AP(:,:), BP +real, pointer :: CP(:), DP(:,:), D, EP(:) + +call test_char() + +A => AT +B => BT + +AP => A +BP => B +call foo(AP,B, A, 1) ! OK - associated +call foo(BP,B, A, 2) ! OK - associated + +! Those are all not associated: + +AP => null() +BP => null() +call foo(AP, B, A, 3) ! LHS not associated +call foo(BP, B, A, 4) ! LHS not associated + +DP => null() +D => null() +call foo(AP, B, DP, 5) ! LHS+RHS not associated +call foo(BP, D, A, 6) ! LHS+RHS not associated + +AP => A +BP => B +call foo(AP, B, DP, 7) ! RHS not associated +call foo(BP, D, A, 8) ! RHS not associated + +CP(1:size(A)) => A +call foo(CP, B, A, 9) ! Shape (rank) differs + +AP => A(2:,:) +call foo(AP, B, A, 10) ! Shape differs + +AP => A(:,2:) +call foo(AP, B, A, 11) ! Shape differs + +AP(10:,10:) => A +call foo(AP, B, A, 12) ! OK - bounds different, shape same + +CP => AT(1:-1, 5) +EP => AT(1:-1, 5) ! Case(i) + case(iv) +call foo2(CP, EP) ! CP associated - but CP not associated with EP +contains +subroutine foo2(p, lpd) + implicit none (type, external) + real, pointer :: p(..) ! "pointer" + real, pointer :: lpd(:) ! array "target" + if (.not.associated(p)) stop 18 ! OK - associated + if (associated(p, lpd)) stop 19 ! .. but for zero-sized array +end + +subroutine foo(p, lp, lpd, cnt) + implicit none (type, external) + real, pointer :: p(..) ! "pointer" + real, pointer :: lp ! scalar "target" + real, pointer :: lpd(:,:) ! array "target" + integer, value :: cnt + + if (cnt == 1) then + if (.not. associated(p, lpd)) stop 1 ! OK + elseif (cnt == 2) then + if (.not. associated(p, lp)) stop 2 ! OK + elseif (cnt == 3) then + if (associated(p, lpd)) stop 3 ! LHS NULL ptr + if (associated(p)) stop 4 ! LHS NULL ptr + elseif (cnt == 4) then + if (associated(p, lp)) stop 5 ! LHS NULL ptr + if (associated(p)) stop 6 ! LHS NULL ptr + elseif (cnt == 5) then + if (associated(p, lpd)) stop 7 ! LHS+RHS NULL ptr + if (associated(p)) stop 8 ! LHS+RHS NULL ptr + elseif (cnt == 6) then + if (associated(p, lp)) stop 9 ! LHS+RHS NULL ptr + if (associated(p)) stop 10 ! LHS+RHS NULL ptr + elseif (cnt == 7) then + if (associated(p, lpd)) stop 11 ! RHS NULL ptr + elseif (cnt == 8) then + if (associated(p, lp)) stop 12 ! RHS NULL ptr + elseif (cnt == 9) then + if (associated(p, lpd)) stop 13 ! rank differs + if (associated(p, lp)) stop 14 ! rank differs + elseif (cnt == 10) then + if (associated(p, lpd)) stop 15 ! shape differs + elseif (cnt == 11) then + if (associated(p, lpd)) stop 16 ! shape differs + elseif (cnt == 12) then + if (.not.associated(p, lpd)) stop 17 ! OK - shape same, lbound different + else + stop 99 + endif +end +subroutine test_char() + character(len=0), target :: str0 + character(len=2), target :: str2 + character(len=:), pointer :: ptr + ptr => str0 + call test_char2(ptr, str0) + ptr => str2 + call test_char2(ptr, str2) +end +subroutine test_char2(x,y) + character(len=:), pointer :: x + character(len=*), target :: y + if (len(y) == 0) then + if (len(x) /= 0) stop 20 + if (.not. associated(x)) stop 21 + if (associated(x, y)) stop 22 + else + if (len(y) /= 2) stop 23 + if (len(x) /= 2) stop 24 + if (.not. associated(x)) stop 25 + if (.not. associated(x, y)) stop 26 + end if +end +end diff --git a/libgfortran/intrinsics/associated.c b/libgfortran/intrinsics/associated.c index 943fc69ed47..60c88ff9021 100644 --- a/libgfortran/intrinsics/associated.c +++ b/libgfortran/intrinsics/associated.c @@ -41,8 +41,9 @@ associated (const gfc_array_void *pointer, const gfc_array_void *target) return 0; if (GFC_DESCRIPTOR_DTYPE (pointer).type != GFC_DESCRIPTOR_DTYPE (target).type) return 0; - rank = GFC_DESCRIPTOR_RANK (pointer); + if (rank != GFC_DESCRIPTOR_RANK (target)) + return 0; for (n = 0; n < rank; n++) { long extent;