From: Tobias Burnus Date: Fri, 20 Dec 2019 11:35:20 +0000 (+0000) Subject: Fortran] PR 92996 – fix rank resolution EXPR_ARRAY X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=de89b5748d68b76b06e3beca4a956060afb79a3d;p=gcc.git Fortran] PR 92996 – fix rank resolution EXPR_ARRAY PR fortran/92996 gcc/fortran/ * 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 gcc/testsuite/ * gfortran.dg/array_simplify_4.f90: New. * gfortran.dg/pr91565.f90: Update dg-error. * gfortran.dg/pr91801.f90: Likewise. From-SVN: r279638 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d382ac05666..8d480c5ce12 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2019-12-20 Tobias Burnus + + 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. + 2019-12-20 Tobias Burnus * openmp.c (resolve_omp_clauses): Move is-coindexed check from here ... diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 9e3c8c42297..fc67a9dd5b0 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) @@ -2073,6 +2082,7 @@ simplify_parameter_variable (gfc_expr *p, int type) if (e->expr_type != EXPR_CONSTANT && p->ref != NULL) e->ref = gfc_copy_ref (p->ref); t = gfc_simplify_expr (e, type); + e->where = p->where; /* Only use the simplification if it eliminated all subobject references. */ if (t && !e->ref) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 7919b690ec0..b38238a9faa 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3352,6 +3352,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/ChangeLog b/gcc/testsuite/ChangeLog index 8f2aba2f7ed..d5bd666eec3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2019-12-20 Tobias Burnus + + PR fortran/92996 + * gfortran.dg/array_simplify_4.f90: New. + * gfortran.dg/pr91565.f90: Update dg-error. + * gfortran.dg/pr91801.f90: Likewise. + 2019-12-20 Tobias Burnus * gfortran.dg/goacc/coindexed-1.f90: New. 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..2aa522be44d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/array_simplify_4.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/92996 +! +! Contributed by G. Steinmetz +! + +module m + integer, parameter :: d(2) = [0,0] +end module m + +subroutine one +use m +print size([1,2],dim=d(1)) ! { dg-error "'dim' argument of 'size' intrinsic at .1. is not a valid dimension index" } +end + +subroutine two +complex, parameter :: x = 1 + +stop x ! { dg-error "STOP code at .1. must be either INTEGER or CHARACTER type" } +end + +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