From patchwork Thu Dec 19 20:30:49 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 1213699 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=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-516332-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="UcmpfQRC"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 47f3S82XR1z9sPT for ; Fri, 20 Dec 2019 07:31:18 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; q=dns; s=default; b=GM2Yb3gdIRlcuYNNRNowzmf1hv9AbKZxo2HwlFCRxUSrdazjy0 7ZUCieYT8cvwQV5fHRhQCgAnvkGXRvIbpe2Shs74yVVg0gFDzKCWgPKms8g4UOAy gpXI9Es3Z6XJvHvGVzxD2d7E6AbJEAJt+0wV0qQZHW9w7guIgfxQXZPYs= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; s= default; bh=BN5jT+Oi0pKapGGG579xKo+YxiI=; b=UcmpfQRCQZqz6kG4TSr3 4N2NrWQ8M3VeKxOZaR5P4bRyR1SJ0j6qFwrSiM00VDXcjhbdPA33P/0S+WFFBCqa XgWWcL+E05awqhlpZ3qB6ZsyltcsXuOVXnI1sXyGKsW9TI+K75xDw7qV5TMJRjaE 8JKtGTa3AMVCr1o/SCkucfs= Received: (qmail 46067 invoked by alias); 19 Dec 2019 20:31:06 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 46054 invoked by uid 89); 19 Dec 2019 20:31:06 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-16.8 required=5.0 tests=AWL, BAYES_00, GARBLED_SUBJECT, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, SPF_PASS autolearn=ham version=3.3.1 spammy=Contributed, f03, sk:x86-64-, forgotten X-HELO: esa3.mentor.iphmx.com Received: from esa3.mentor.iphmx.com (HELO esa3.mentor.iphmx.com) (68.232.137.180) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 19 Dec 2019 20:31:04 +0000 IronPort-SDR: XgilJ/Syt754+6frpDxNQT6CXO86Y2b8CT9ieddIyGClbF1keQ0P50XxETyVb1i2TUlnKo69Fz mW2ZB6kjVlfYbDvs7HwYsrB+YJ+TZAS2jUWSQn1lkQWD9Oz7ROeEVg+sOSU3koicWlRFSzEOdD eRQHbNjRgImzjoD9xwW2d3Sbx1VsAIWchakQsJWBSF+HmYjjNybdLcpR3rGV3EY7u4YEQf49JA INJD2ZRe7kG9zeo+1RZU/UsdbhklXEaIGBtPpgUAzxxw5NYStSCEcERGI7rAYhvfCvL5JMDMV/ WM8= Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa3.mentor.iphmx.com with ESMTP; 19 Dec 2019 12:31:02 -0800 IronPort-SDR: jPHggby11ov/tevUsnh/1mLxIdGj5u+s0ZIpEoDyXuKrs1Xj/T8ga9ZlbITLuZD4qk66VnXMDK n92LJkvWi7Eukjoo+5GoZ+3Cvv4uiY7cNHvf78iGog/j+L/VitbbnDYhF8ZJMoQgfqxFRsLOwG o7rbV8cTvts8n1/zfAw/M0gUdAPBy5K36euYh3yYjQx62g+uuS1krh9WGqG2mILphZ+sQ1fRA9 Xm5GiMQhaYCvxk66DINW2c4TzcW8K9P3e4O7c32XusUNu+kcuoJKhmE/PT4gbB/cc86HJCAbtf 0FA= To: fortran , gcc-patches From: Tobias Burnus Subject: =?utf-8?q?=5BPatch=2C_Fortran=5D_PR_92996_=E2=80=93_fix_rank_res?= =?utf-8?q?olution_EXPR=5FARRAY?= Message-ID: Date: Thu, 19 Dec 2019 21:30:49 +0100 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.3.0 MIME-Version: 1.0 X-IsSubscribed: yes Hi all, expressions initially have "expr->rank = 0" (cf. gfc_match_rvalue, called by match_expr). This is later fixed during the resolution in "expression_rank", which is called by (gfc_)resolve_ref, which in turn is called by gfc_resolve_expr. Additionally, the resolve_array_ref ensures that the number of specified indices matches the rank. However, if one calls gfc_simplify_expr, array-valued FL_PARAMETER are converted to EXPR_ARRAY. As they are a somewhat amorphous object, a later call of "expression_rank" is a no-op and the interesting information is already gone. Hence, we need to resolve the FL_PARAMETER EXPR_VARIABLE before converting it to EXPR_ARRAY. We cannot call gfc_resolve_expr as resolve_variable in turn calls gfc_simplify_expr – repeating this until one runs out of stack space. Hence: We now call gfc_resolve_ref explicitly before conversion to EXPR_ARRAY – and gfc_expression_rank. And the accumulated errors are forced to be output; in principle, this could be done by the caller – but my feeling is that it is easily forgotten and ignoring this error does not make much sense; hence, I force it. Additionally, when creating EXPR_ARRAY, the location is now set to the usage of the parameter-variable. Before, it pointed to the place where the variable was initialized, i.e. "sym->value->where" (due to  gfc_copy_expr (...->value). As minor cleanup, I remove "gfc_init_expr_flag" before the call to gfc_reduce_init_expr as the callee already sets those variables and also cleaned up expression_rank a tiny bit. * * * Side-effect of the changed location: without the patch, one gets 5 | integer, parameter :: a(2) = [2,0] ! { dg-error "Element with a value of" } | 1 6 | print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "for the RESHAPE intrinsic near" } | 2 Error: Element with a value of 0 in ORDER at (1) must be in the range [1, ..., 2] for the RESHAPE intrinsic near (2) which is a bit nicer than the new 6 | print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "for the RESHAPE intrinsic near" } | 2 1 Error: Element with a value of 0 in ORDER at (1) must be in the range [1, ..., 2] for the RESHAPE intrinsic near (2) On the other hand, without that change, one gets: 10 | stop a ! { dg-error "STOP code at .1. must be scalar" } | 1 Error: STOP code at (1) must be scalar instead of 8 | integer, parameter :: a(2) = [1, 2] | 1 Error: STOP code at (1) must be scalar The latter could be "solved" by using %C instead of %L after gfc_simplify_expr in gfc_match_stopcode. [The "ref" has its own address (e->ref->u.ar->where); hence, the a(1,1) error would be still fine.] (Though, this potentially effects more.) Thoughts? * * * Build and regtested on x86-64-gnu-linux. OK for the trunk? Cheers, Tobias PR fortran/92996 * expr.c (simplify_parameter_variable): Call gfc_resolve_ref and gfc_expression_rank; fix location info. * gfortran.h (gfc_resolve_ref, gfc_expression_rank): Declare. * match.c (gfc_match_stopcode): Remove redundant setting of gfc_init_expr_flag; early return if gfc_simplify_expr has an error. * resolve.c (gfc_expression_rank): Renamed from expression_rank; minor cleanup. (gfc_resolve_ref): Removed static and renamed from resolve_ref. (resolve_variable, resolve_typebound_function, resolve_typebound_subroutine, resolve_ppc_call, resolve_expr_ppc, gfc_resolve_expr, resolve_procedure): Update calls. PR fortran/92996 * gfortran.dg/array_simplify_4.f90: New. * gfortran.dg/pr91565.f90: Update dg-error. * gfortran.dg/pr91801.f90: Likewise. gcc/fortran/expr.c | 10 +++++++ gcc/fortran/gfortran.h | 2 ++ gcc/fortran/match.c | 5 ++-- gcc/fortran/resolve.c | 38 +++++++++++--------------- gcc/testsuite/gfortran.dg/array_simplify_4.f90 | 12 ++++++++ gcc/testsuite/gfortran.dg/pr91565.f90 | 8 +++--- gcc/testsuite/gfortran.dg/pr91801.f90 | 4 +-- 7 files changed, 48 insertions(+), 31 deletions(-) diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 9e3c8c42297..abd9a46c695 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -2044,6 +2044,15 @@ simplify_parameter_variable (gfc_expr *p, int type) gfc_expr *e; bool t; + /* Set rank and check array ref; as resolve_variable calls + gfc_simplify_expr, call gfc_resolve_ref + gfc_expression_rank instead. */ + if (!gfc_resolve_ref (p)) + { + gfc_error_check (); + return false; + } + gfc_expression_rank (p); + if (gfc_is_size_zero_array (p)) { if (p->expr_type == EXPR_ARRAY) @@ -2064,6 +2073,7 @@ simplify_parameter_variable (gfc_expr *p, int type) if (e == NULL) return false; + e->where = p->where; e->rank = p->rank; if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 3907d1407ac..e93c1f79b74 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3349,6 +3349,8 @@ void gfc_free_statements (gfc_code *); void gfc_free_association_list (gfc_association_list *); /* resolve.c */ +void gfc_expression_rank (gfc_expr *); +bool gfc_resolve_ref (gfc_expr *); bool gfc_resolve_expr (gfc_expr *); void gfc_resolve (gfc_namespace *); void gfc_resolve_code (gfc_code *, gfc_namespace *); diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index b5945049de5..d3e3abcb700 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -3073,7 +3073,8 @@ gfc_match_stopcode (gfc_statement st) if (e != NULL) { - gfc_simplify_expr (e, 0); + if (!gfc_simplify_expr (e, 0)) + goto cleanup; /* Test for F95 and F2003 style STOP stop-code. */ if (e->expr_type != EXPR_CONSTANT && (f95 || f03)) @@ -3085,9 +3086,7 @@ gfc_match_stopcode (gfc_statement st) /* Use the machinery for an initialization expression to reduce the stop-code to a constant. */ - gfc_init_expr_flag = true; gfc_reduce_init_expr (e); - gfc_init_expr_flag = false; /* Test for F2008 style STOP stop-code. */ if (e->expr_type != EXPR_CONSTANT && f08) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index b437c595500..92ed413fe0a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5189,8 +5189,8 @@ gfc_resolve_substring_charlen (gfc_expr *e) /* Resolve subtype references. */ -static bool -resolve_ref (gfc_expr *expr) +bool +gfc_resolve_ref (gfc_expr *expr) { int current_part_dimension, n_components, seen_part_dimension; gfc_ref *ref, **prev; @@ -5359,7 +5359,7 @@ fail: examining the base symbol and any reference structures it may have. */ void -expression_rank (gfc_expr *e) +gfc_expression_rank (gfc_expr *e) { gfc_ref *ref; int i, rank; @@ -5374,14 +5374,8 @@ expression_rank (gfc_expr *e) goto done; /* Constructors can have a rank different from one via RESHAPE(). */ - if (e->symtree == NULL) - { - e->rank = 0; - goto done; - } - - e->rank = (e->symtree->n.sym->as == NULL) - ? 0 : e->symtree->n.sym->as->rank; + e->rank = ((e->symtree == NULL || e->symtree->n.sym->as == NULL) + ? 0 : e->symtree->n.sym->as->rank); goto done; } @@ -5406,7 +5400,7 @@ expression_rank (gfc_expr *e) { /* Figure out the rank of the section. */ if (rank != 0) - gfc_internal_error ("expression_rank(): Two array specs"); + gfc_internal_error ("gfc_expression_rank(): Two array specs"); for (i = 0; i < ref->u.ar.dimen; i++) if (ref->u.ar.dimen_type[i] == DIMEN_RANGE @@ -5686,7 +5680,7 @@ resolve_variable (gfc_expr *e) } } - if (e->ref && !resolve_ref (e)) + if (e->ref && !gfc_resolve_ref (e)) return false; if (sym->attr.flavor == FL_PROCEDURE @@ -5848,7 +5842,7 @@ resolve_procedure: } if (t) - expression_rank (e); + gfc_expression_rank (e); if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e)) add_caf_get_intrinsic (e); @@ -6642,7 +6636,7 @@ resolve_typebound_function (gfc_expr* e) if (st == NULL) return resolve_compcall (e, NULL); - if (!resolve_ref (e)) + if (!gfc_resolve_ref (e)) return false; /* Get the CLASS declared type. */ @@ -6775,7 +6769,7 @@ resolve_typebound_subroutine (gfc_code *code) if (st == NULL) return resolve_typebound_call (code, NULL, NULL); - if (!resolve_ref (code->expr1)) + if (!gfc_resolve_ref (code->expr1)) return false; /* Get the CLASS declared type. */ @@ -6838,7 +6832,7 @@ resolve_ppc_call (gfc_code* c) if (!comp->attr.subroutine) gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where); - if (!resolve_ref (c->expr1)) + if (!gfc_resolve_ref (c->expr1)) return false; if (!update_ppc_arglist (c->expr1)) @@ -6881,7 +6875,7 @@ resolve_expr_ppc (gfc_expr* e) if (!comp->attr.function) gfc_add_function (&comp->attr, comp->name, &e->where); - if (!resolve_ref (e)) + if (!gfc_resolve_ref (e)) return false; if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc, @@ -7011,7 +7005,7 @@ gfc_resolve_expr (gfc_expr *e) break; case EXPR_SUBSTRING: - t = resolve_ref (e); + t = gfc_resolve_ref (e); break; case EXPR_CONSTANT: @@ -7025,14 +7019,14 @@ gfc_resolve_expr (gfc_expr *e) case EXPR_ARRAY: t = false; - if (!resolve_ref (e)) + if (!gfc_resolve_ref (e)) break; t = gfc_resolve_array_constructor (e); /* Also try to expand a constructor. */ if (t) { - expression_rank (e); + gfc_expression_rank (e); if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e)) gfc_expand_constructor (e, false); } @@ -7051,7 +7045,7 @@ gfc_resolve_expr (gfc_expr *e) break; case EXPR_STRUCTURE: - t = resolve_ref (e); + t = gfc_resolve_ref (e); if (!t) break; diff --git a/gcc/testsuite/gfortran.dg/array_simplify_4.f90 b/gcc/testsuite/gfortran.dg/array_simplify_4.f90 new file mode 100644 index 00000000000..051d285b6eb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/array_simplify_4.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR fortran/92996 +! +! Contributed by G. Steinmetz +! +program p + integer, parameter :: a(2) = [1, 2] + stop a(1) ! OK + stop a ! { dg-error "STOP code at .1. must be scalar" } + stop a(1,1) ! { dg-error "Rank mismatch in array reference at .1. .2/1." } +end diff --git a/gcc/testsuite/gfortran.dg/pr91565.f90 b/gcc/testsuite/gfortran.dg/pr91565.f90 index b43a57acf13..e4e121c717a 100644 --- a/gcc/testsuite/gfortran.dg/pr91565.f90 +++ b/gcc/testsuite/gfortran.dg/pr91565.f90 @@ -2,16 +2,16 @@ ! PR fortran/91565 ! Contributed by Gerhard Steinmetz program p - integer, parameter :: a(2) = [2,2] ! { dg-error "\(1\)" } - print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "not a permutation" } + integer, parameter :: a(2) = [2,2] + print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "ORDER at .1. is not a permutation of the size of SHAPE at .2." } end subroutine foo - integer, parameter :: a(1) = 1 ! { dg-error "\(1\)" } + integer, parameter :: a(1) = 1 print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "are different" } end subroutine bar - integer, parameter :: a(1,2) = 1 ! { dg-error "\(1\)" } + integer, parameter :: a(1,2) = 1 print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "are different" } end diff --git a/gcc/testsuite/gfortran.dg/pr91801.f90 b/gcc/testsuite/gfortran.dg/pr91801.f90 index d2d82b88464..809068b9659 100644 --- a/gcc/testsuite/gfortran.dg/pr91801.f90 +++ b/gcc/testsuite/gfortran.dg/pr91801.f90 @@ -2,6 +2,6 @@ ! PR fortran/91801 ! Code contributed by Gerhard Steinmetz program p - integer, parameter :: a(2) = [2,0] ! { dg-error "Element with a value of" } - print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "for the RESHAPE intrinsic near" } + integer, parameter :: a(2) = [2,0] + print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "Element with a value of 0 in ORDER at .1. must be in the range .1, ..., 2. for the RESHAPE intrinsic near .2." } end