Hi Steve,
On 12/20/19 1:26 AM, Steve Kargl wrote:
On Thu, Dec 19, 2019 at 09:30:49PM +0100, Tobias Burnus wrote:
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.)
See patch in comment #2 of PR. It regression tests cleanly,
so it seems your parenthetical statement is not a issue.
One has the choice between
(a) Using the location where the expression was defined (in the
scoping unit) – currently done
(i.e. replacing expr->where by expr->symtree->n.sym->where)
(b) using the location where the parameter is used, i.e. keeping
expr->where despite simplification.
What I meant is that there are more locations one to change from
%L to %C if one wants to get good diagnostic and keep using the
location of the declaration (as done currently) – instead of moving
to keeping the location of the expression used (as proposed).
In my opinion (b) is the most robust version while (a) can give in
_some_ cases a better diagnostic – as mentioned in the last email
and as shown by the dg-error changed I had to do in two test cases.
I played around and found two examples where the currently shown
location is not helpful.
The current compiler shows such errors:
5 | use m
| 1
Error: ‘dim’ argument of ‘size’ intrinsic at (1) is not a valid dimension index
1 | complex, parameter :: x(1) = 1
| 1
Error: STOP code at (1) must be either INTEGER or CHARACTER type
Using approach (b), one gets for those:
3 | stop x(1)
| 1
Error: STOP code at (1) must be either INTEGER or CHARACTER type
6 | print size([1,2],dim=d(1))
| 1
Error: ‘dim’ argument of ‘size’ intrinsic at (1) is not a valid dimension index
I think the latter diagnostic is much more helpful! I have to admit that I had
to
move the "e->where = p->where" further down – after the gfc_simplify_expr call
as that one again changed the location. — I also added the two examples.
OK for the trunk?
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 | 28 +++++++++++++++++++
gcc/testsuite/gfortran.dg/pr91565.f90 | 8 +++---
gcc/testsuite/gfortran.dg/pr91801.f90 | 4 +--
7 files changed, 64 insertions(+), 31 deletions(-)
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/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
