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(-)
@@ -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)
@@ -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 *);
@@ -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)
@@ -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;
new file mode 100644
@@ -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
@@ -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
@@ -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
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