* [patch, fortran] Warn about out-of-bounds-errors in DO loops
@ 2017-09-17 22:35 Thomas Koenig
0 siblings, 0 replies; only message in thread
From: Thomas Koenig @ 2017-09-17 22:35 UTC (permalink / raw)
To: fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 1890 bytes --]
Hello world,
the attached patch implements the out-of-bounds errors for DO loops.
Seeing that we only warn for things like
REAL :: A(2)
A(3) = 42.
I think it is best to have an unconditional warning for
simple cases, and something enabled with -Wextra for stuff
like
REAL A(3)
DO I=1,10
(some jump statement, which could jump out of the loop)
A(I) = 21.
END DO
Regression-testing found some erroneous code in the testsuite,
also corrected.
OK for trunk?
I will update the documentation separately.
Regards
Thomas
2017-09-17 Thomas Koenig <tkoenig@gcc.gnu.org>
* lang.opt: Add -Wdo-subscript.
* frontend-passes.c (do_t): New type.
(doloop_list): Use variable of do_type.
(if_level): Variable to track if levels.
(select_level): Variable to track select levels.
(gfc_run_passes): Initialize i_level and select_level.
(doloop_code): Record current level of if + select
level in doloop_list. Add seen_goto if there could
be a branch outside the loop. Use different type for
doloop_list.
(doloop_function): Call do_intent and do_subscript; move
functionality of checking INTENT to do_intent.
(insert_index_t): New type, for callback_insert_index.
(callback_insert_index): New function.
(insert_index): New function.
(do_subscript): New function.
(do_intent): New function.
(gfc_code_walker): Keep track of if_level and select_level.
2017-09-17 Thomas Koenig <tkoenig@gcc.gnu.org>
* gfortran.dg/do_subscript_1.f90: New test.
* gfortran.dg/do_subscript_2.f90: New test.
* gfortran.dg/gomp/associate1.f90: Add out of bounds warning.
* gfortran.dg/predcom-1.f: Adjust loop bounds.
* gfortran.dg/unconstrained_commons.f: Add out of bounds warning.
[-- Attachment #2: p15.diff --]
[-- Type: text/x-patch, Size: 15416 bytes --]
Index: fortran/frontend-passes.c
===================================================================
--- fortran/frontend-passes.c (Revision 252894)
+++ fortran/frontend-passes.c (Arbeitskopie)
@@ -39,6 +39,8 @@ static bool optimize_lexical_comparison (gfc_expr
static void optimize_minmaxloc (gfc_expr **);
static bool is_empty_string (gfc_expr *e);
static void doloop_warn (gfc_namespace *);
+static int do_intent (gfc_expr **);
+static int do_subscript (gfc_expr **);
static void optimize_reduction (gfc_namespace *);
static int callback_reduction (gfc_expr **, int *, void *);
static void realloc_strings (gfc_namespace *);
@@ -98,10 +100,20 @@ static int iterator_level;
/* Keep track of DO loop levels. */
-static vec<gfc_code *> doloop_list;
+typedef struct {
+ gfc_code *c;
+ int branch_level;
+ bool seen_goto;
+} do_t;
+static vec<do_t> doloop_list;
static int doloop_level;
+/* Keep track of if and select case levels. */
+
+static int if_level;
+static int select_level;
+
/* Vector of gfc_expr * to keep track of DO loops. */
struct my_struct *evec;
@@ -133,6 +145,8 @@ gfc_run_passes (gfc_namespace *ns)
change. */
doloop_level = 0;
+ if_level = 0;
+ select_level = 0;
doloop_warn (ns);
doloop_list.release ();
int w, e;
@@ -2231,6 +2245,8 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTR
gfc_formal_arglist *f;
gfc_actual_arglist *a;
gfc_code *cl;
+ do_t loop, *lp;
+ bool seen_goto;
co = *c;
@@ -2239,16 +2255,67 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTR
if ((unsigned) doloop_level < doloop_list.length())
doloop_list.truncate (doloop_level);
+ seen_goto = false;
switch (co->op)
{
case EXEC_DO:
if (co->ext.iterator && co->ext.iterator->var)
- doloop_list.safe_push (co);
+ loop.c = co;
else
- doloop_list.safe_push ((gfc_code *) NULL);
+ loop.c = NULL;
+
+ loop.branch_level = if_level + select_level;
+ loop.seen_goto = false;
+ doloop_list.safe_push (loop);
break;
+ /* If anything could transfer control away from a suspicious
+ subscript, make sure to set seen_goto in the current DO loop
+ (if any). */
+ case EXEC_GOTO:
+ case EXEC_EXIT:
+ case EXEC_STOP:
+ case EXEC_ERROR_STOP:
+ case EXEC_CYCLE:
+ seen_goto = true;
+ break;
+
+ case EXEC_OPEN:
+ if (co->ext.open->err)
+ seen_goto = true;
+ break;
+
+ case EXEC_CLOSE:
+ if (co->ext.close->err)
+ seen_goto = true;
+ break;
+
+ case EXEC_BACKSPACE:
+ case EXEC_ENDFILE:
+ case EXEC_REWIND:
+ case EXEC_FLUSH:
+
+ if (co->ext.filepos->err)
+ seen_goto = true;
+ break;
+
+ case EXEC_INQUIRE:
+ if (co->ext.filepos->err)
+ seen_goto = true;
+ break;
+
+ case EXEC_READ:
+ case EXEC_WRITE:
+ if (co->ext.dt->err || co->ext.dt->end || co->ext.dt->eor)
+ seen_goto = true;
+ break;
+
+ case EXEC_WAIT:
+ if (co->ext.wait->err || co->ext.wait->end || co->ext.wait->eor)
+ loop.seen_goto = true;
+ break;
+
case EXEC_CALL:
if (co->resolved_sym == NULL)
@@ -2265,9 +2332,10 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTR
while (a && f)
{
- FOR_EACH_VEC_ELT (doloop_list, i, cl)
+ FOR_EACH_VEC_ELT (doloop_list, i, lp)
{
gfc_symbol *do_sym;
+ cl = lp->c;
if (cl == NULL)
break;
@@ -2282,14 +2350,14 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTR
"value inside loop beginning at %L as "
"INTENT(OUT) argument to subroutine %qs",
do_sym->name, &a->expr->where,
- &doloop_list[i]->loc,
+ &(doloop_list[i].c->loc),
co->symtree->n.sym->name);
else if (f->sym->attr.intent == INTENT_INOUT)
gfc_error_now ("Variable %qs at %L not definable inside "
"loop beginning at %L as INTENT(INOUT) "
"argument to subroutine %qs",
do_sym->name, &a->expr->where,
- &doloop_list[i]->loc,
+ &(doloop_list[i].c->loc),
co->symtree->n.sym->name);
}
}
@@ -2301,20 +2369,267 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTR
default:
break;
}
+ if (seen_goto && doloop_level > 0)
+ doloop_list[doloop_level-1].seen_goto = true;
+
return 0;
}
-/* Callback function for functions checking that we do not pass a DO variable
- to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
+/* Callback function to warn about different things within DO loops. */
static int
do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
void *data ATTRIBUTE_UNUSED)
{
+ do_t *last;
+
+ if (doloop_list.length () == 0)
+ return 0;
+
+ if ((*e)->expr_type == EXPR_FUNCTION)
+ do_intent (e);
+
+ last = &doloop_list.last();
+ if (last->seen_goto && !warn_do_subscript)
+ return 0;
+
+ if ((*e)->expr_type == EXPR_VARIABLE)
+ do_subscript (e);
+
+ return 0;
+}
+
+typedef struct
+{
+ gfc_symbol *sym;
+ mpz_t val;
+} insert_index_t;
+
+/* Callback function - if the expression is the variable in data->sym,
+ replace it with a constant from data->val. */
+
+static int
+callback_insert_index (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data)
+{
+ insert_index_t *d;
+ gfc_expr *ex, *n;
+
+ ex = (*e);
+ if (ex->expr_type != EXPR_VARIABLE)
+ return 0;
+
+ d = (insert_index_t *) data;
+ if (ex->symtree->n.sym != d->sym)
+ return 0;
+
+ n = gfc_get_constant_expr (BT_INTEGER, ex->ts.kind, &ex->where);
+ mpz_set (n->value.integer, d->val);
+
+ gfc_free_expr (ex);
+ *e = n;
+ return 0;
+}
+
+/* In the expression e, replace occurrences of the variable sym with
+ val. If this results in a constant expression, return true and
+ return the value in ret. Return false if the expression already
+ is a constant. Caller has to clear ret in that case. */
+
+static bool
+insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret)
+{
+ gfc_expr *n;
+ insert_index_t data;
+ bool rc;
+
+ if (e->expr_type == EXPR_CONSTANT)
+ return false;
+
+ n = gfc_copy_expr (e);
+ data.sym = sym;
+ mpz_init_set (data.val, val);
+ gfc_expr_walker (&n, callback_insert_index, (void *) &data);
+ gfc_simplify_expr (n, 0);
+
+ if (n->expr_type == EXPR_CONSTANT)
+ {
+ rc = true;
+ mpz_init_set (ret, n->value.integer);
+ }
+ else
+ rc = false;
+
+ mpz_clear (data.val);
+ gfc_free_expr (n);
+ return rc;
+
+}
+
+/* Check array subscripts for possible out-of-bounds accesses in DO
+ loops with constant bounds. */
+
+static int
+do_subscript (gfc_expr **e)
+{
+ gfc_expr *v;
+ gfc_array_ref *ar;
+ gfc_ref *ref;
+ int i,j;
+ gfc_code *dl;
+ do_t *lp;
+
+ v = *e;
+ /* Constants are already checked. */
+ if (v->expr_type == EXPR_CONSTANT)
+ return 0;
+
+ for (ref = v->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
+ {
+ ar = & ref->u.ar;
+ FOR_EACH_VEC_ELT (doloop_list, j, lp)
+ {
+ gfc_symbol *do_sym;
+ mpz_t do_start, do_step, do_end;
+ bool have_do_start, have_do_end;
+ bool error_not_proven;
+ int warn;
+
+ dl = lp->c;
+ if (dl == NULL)
+ break;
+
+ /* If we are within a branch, or a goto or equivalent
+ was seen in the DO loop before, then we cannot prove that
+ this expression is actually evaluated. Don't do anything
+ unless we want to see it all. */
+ error_not_proven = lp->seen_goto
+ || lp->branch_level < if_level + select_level;
+
+ if (error_not_proven && !warn_do_subscript)
+ break;
+
+ if (error_not_proven)
+ warn = OPT_Wdo_subscript;
+ else
+ warn = 0;
+
+ do_sym = dl->ext.iterator->var->symtree->n.sym;
+ if (do_sym->ts.type != BT_INTEGER)
+ continue;
+
+ /* If we do not know about the stepsize, the loop may be zero trip.
+ Do not warn in this case. */
+
+ if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
+ mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
+ else
+ continue;
+
+ if (dl->ext.iterator->start->expr_type == EXPR_CONSTANT)
+ {
+ have_do_start = true;
+ mpz_init_set (do_start, dl->ext.iterator->start->value.integer);
+ }
+ else
+ have_do_start = false;
+
+
+ if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
+ {
+ have_do_end = true;
+ mpz_init_set (do_end, dl->ext.iterator->end->value.integer);
+ }
+ else
+ have_do_end = false;
+
+ if (!have_do_start && !have_do_end)
+ return 0;
+
+ /* May have to correct the end value if the step does not equal
+ one. */
+ if (have_do_start && have_do_end && mpz_cmp_ui (do_step, 1) != 0)
+ {
+ mpz_t diff, rem;
+
+ mpz_init (diff);
+ mpz_init (rem);
+ mpz_sub (diff, do_end, do_start);
+ mpz_tdiv_r (rem, diff, do_step);
+ mpz_sub (do_end, do_end, rem);
+ mpz_clear (diff);
+ mpz_clear (rem);
+ }
+
+ for (i = 0; i< ar->dimen; i++)
+ {
+ mpz_t val;
+ if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_start
+ && insert_index (ar->start[i], do_sym, do_start, val))
+ {
+ if (ar->as->lower[i]
+ && ar->as->lower[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
+ gfc_warning (warn, "Array reference at %L out of bounds "
+ "(%ld < %ld) in loop beginning at %L",
+ &ar->start[i]->where, mpz_get_si (val),
+ mpz_get_si (ar->as->lower[i]->value.integer),
+ &doloop_list[j].c->loc);
+
+ if (ar->as->upper[i]
+ && ar->as->upper[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
+ gfc_warning (warn, "Array reference at %L out of bounds "
+ "(%ld > %ld) in loop beginning at %L",
+ &ar->start[i]->where, mpz_get_si (val),
+ mpz_get_si (ar->as->upper[i]->value.integer),
+ &doloop_list[j].c->loc);
+
+ mpz_clear (val);
+ }
+
+ if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_end
+ && insert_index (ar->start[i], do_sym, do_end, val))
+ {
+ if (ar->as->lower[i]
+ && ar->as->lower[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
+ gfc_warning (warn, "Array reference at %L out of bounds "
+ "(%ld < %ld) in loop beginning at %L",
+ &ar->start[i]->where, mpz_get_si (val),
+ mpz_get_si (ar->as->lower[i]->value.integer),
+ &doloop_list[j].c->loc);
+
+ if (ar->as->upper[i]
+ && ar->as->upper[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
+ gfc_warning (warn, "Array reference at %L out of bounds "
+ "(%ld > %ld) in loop beginning at %L",
+ &ar->start[i]->where, mpz_get_si (val),
+ mpz_get_si (ar->as->upper[i]->value.integer),
+ &doloop_list[j].c->loc);
+
+ mpz_clear (val);
+ }
+ }
+ }
+ }
+ }
+ return 0;
+}
+/* Function for functions checking that we do not pass a DO variable
+ to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
+
+static int
+do_intent (gfc_expr **e)
+{
gfc_formal_arglist *f;
gfc_actual_arglist *a;
gfc_expr *expr;
gfc_code *dl;
+ do_t *lp;
int i;
expr = *e;
@@ -2337,10 +2652,10 @@ do_function (gfc_expr **e, int *walk_subtrees ATTR
while (a && f)
{
- FOR_EACH_VEC_ELT (doloop_list, i, dl)
+ FOR_EACH_VEC_ELT (doloop_list, i, lp)
{
gfc_symbol *do_sym;
-
+ dl = lp->c;
if (dl == NULL)
break;
@@ -2353,13 +2668,13 @@ do_function (gfc_expr **e, int *walk_subtrees ATTR
gfc_error_now ("Variable %qs at %L set to undefined value "
"inside loop beginning at %L as INTENT(OUT) "
"argument to function %qs", do_sym->name,
- &a->expr->where, &doloop_list[i]->loc,
+ &a->expr->where, &doloop_list[i].c->loc,
expr->symtree->n.sym->name);
else if (f->sym->attr.intent == INTENT_INOUT)
gfc_error_now ("Variable %qs at %L not definable inside loop"
" beginning at %L as INTENT(INOUT) argument to"
" function %qs", do_sym->name,
- &a->expr->where, &doloop_list[i]->loc,
+ &a->expr->where, &doloop_list[i].c->loc,
expr->symtree->n.sym->name);
}
}
@@ -4055,6 +4370,10 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t code
WALK_SUBEXPR (co->ext.iterator->step);
break;
+ case EXEC_IF:
+ if_level ++;
+ break;
+
case EXEC_WHERE:
in_where = true;
break;
@@ -4073,6 +4392,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t code
case EXEC_SELECT:
WALK_SUBEXPR (co->expr1);
+ select_level ++;
for (b = co->block; b; b = b->block)
{
gfc_case *cp;
@@ -4329,6 +4649,12 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t code
if (co->op == EXEC_DO)
doloop_level --;
+ if (co->op == EXEC_IF)
+ if_level --;
+
+ if (co->op == EXEC_SELECT)
+ select_level --;
+
in_omp_workshare = saved_in_omp_workshare;
in_where = saved_in_where;
}
Index: fortran/lang.opt
===================================================================
--- fortran/lang.opt (Revision 252894)
+++ fortran/lang.opt (Arbeitskopie)
@@ -237,6 +237,10 @@ Wconversion-extra
Fortran Var(warn_conversion_extra) Warning
Warn about most implicit conversions.
+Wdo-subscript
+Fortran Var(warn_do_subscript) Warning LangEnabledBy(Fortran,Wextra)
+Warn about possibly incorrect subscripts in do loops
+
Wextra
Fortran Warning
; Documented in common
Index: testsuite/gfortran.dg/gomp/associate1.f90
===================================================================
--- testsuite/gfortran.dg/gomp/associate1.f90 (Revision 252894)
+++ testsuite/gfortran.dg/gomp/associate1.f90 (Arbeitskopie)
@@ -14,7 +14,7 @@ program associate1
type(dt) :: b(3)
i = 1
j = 2
- associate(k => v, l => a(i, j), m => a(i, :))
+ associate(k => v, l => a(i, j), m => a(i, :)) ! { dg-warning "out of bounds" }
associate(n => b(j)%c(:, :)%i, o => a, p => b)
!$omp parallel shared (l) ! { dg-error "ASSOCIATE name" }
!$omp end parallel
@@ -75,7 +75,7 @@ program associate1
end do
k = 1
!$omp simd linear (k : 2) ! { dg-error "ASSOCIATE name" }
- do i = 1, 10
+ do i = 1, 10 ! { dg-warning "out of bounds" }
k = k + 2
end do
end associate
Index: testsuite/gfortran.dg/predcom-1.f
===================================================================
--- testsuite/gfortran.dg/predcom-1.f (Revision 252894)
+++ testsuite/gfortran.dg/predcom-1.f (Arbeitskopie)
@@ -8,7 +8,7 @@
INTEGER I
REAL ANORM
INTRINSIC ABS
- DO 20 I = 1, N
+ DO 20 I = 2, N
ANORM = ANORM +ABS( E( I ) )+ ABS( E( I-1 ) )
20 CONTINUE
CLANHT = ANORM
Index: testsuite/gfortran.dg/unconstrained_commons.f
===================================================================
--- testsuite/gfortran.dg/unconstrained_commons.f (Revision 252894)
+++ testsuite/gfortran.dg/unconstrained_commons.f (Arbeitskopie)
@@ -9,8 +9,8 @@
IMPLICIT DOUBLE PRECISION (X)
INTEGER J
COMMON /MYCOMMON / X(1)
- DO 10 J=1,1024
- X(J+1)=X(J+7)
+ DO 10 J=1,1024 ! { dg-warning "out of bounds" }
+ X(J+1)=X(J+7) ! { dg-warning "out of bounds" }
10 CONTINUE
RETURN
END
[-- Attachment #3: do_subscript_1.f90 --]
[-- Type: text/x-fortran, Size: 1693 bytes --]
! { dg-do compile }
program main
real, dimension(3) :: a
a = 42.
do i=-1,3,2 ! { dg-warning "out of bounds" }
a(i) = 0 ! { dg-warning "out of bounds \\(-1 < 1\\)" }
end do
do i=4,1,-1 ! { dg-warning "out of bounds" }
a(i) = 22 ! { dg-warning "out of bounds \\(4 > 3\\)" }
end do
do i=1,4 ! { dg-warning "out of bounds" }
a(i) = 32 ! { dg-warning "out of bounds \\(4 > 3\\)" }
end do
do i=3,0,-1 ! { dg-warning "out of bounds" }
a(i) = 12 ! { dg-warning "out of bounds \\(0 < 1\\)" }
end do
do i=-1,3
if (i>0) a(i) = a(i) + 1 ! No warning inside if
end do
do i=-1,4
select case(i)
case(1:3)
a(i) = -234 ! No warning inside select case
end select
end do
do i=1,3 ! { dg-warning "out of bounds" }
a(i+1) = a(i) ! { dg-warning "out of bounds \\(4 > 3\\)" }
a(i-1) = a(i) ! { dg-warning "out of bounds \\(0 < 1\\)" }
end do
do i=3,1,-1 ! { dg-warning "out of bounds" }
a(i) = a(i-1) ! { dg-warning "out of bounds \\(0 < 1\\)" }
a(i) = a(i+1) ! { dg-warning "out of bounds \\(4 > 3\\)" }
end do
do i=1,2 ! { dg-warning "out of bounds" }
a(i) = a(i*i) ! { dg-warning "out of bounds \\(4 > 3\\)" }
end do
do i=1,4,2
a(i) = a(i)*2 ! No error
end do
do i=1,4
if (i > 3) exit
a(i) = 33
end do
do i=0,3 ! { dg-warning "out of bounds \\(0 < 1\\)" }
a(i) = 13. ! { dg-warning "out of bounds \\(0 < 1\\)" }
if (i < 1) exit
end do
do i=0,3
if (i < 1) cycle
a(i) = -21.
end do
do i=0,3 ! { dg-warning "out of bounds \\(0 < 1\\)" }
do j=1,2
a(i) = -123 ! { dg-warning "out of bounds \\(0 < 1\\)" }
end do
end do
end program main
[-- Attachment #4: do_subscript_2.f90 --]
[-- Type: text/x-fortran, Size: 683 bytes --]
! { dg-do compile }
! { dg-additional-options "-Wdo-subscript" }
program main
real, dimension(3) :: a
a = 42.
do i=-1,3 ! { dg-warning "out of bounds \\(-1 < 1\\)" }
select case(i)
case(1:3)
a(i) = -234 ! { dg-warning "out of bounds \\(-1 < 1\\)" }
end select
end do
do i=1,4,2
a(i) = a(i)*2 ! No warning - end value is 3
end do
do i=1,4 ! { dg-warning "out of bounds \\(4 > 3\\)" }
if (i > 3) exit
a(i) = 33 ! { dg-warning "out of bounds \\(4 > 3\\)" }
end do
do i=0,3 ! { dg-warning "out of bounds \\(0 < 1\\)" }
if (i < 1) cycle
a(i) = -21. ! { dg-warning "out of bounds \\(0 < 1\\)" }
end do
end program main
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2017-09-17 22:35 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2017-09-17 22:35 [patch, fortran] Warn about out-of-bounds-errors in DO loops Thomas Koenig
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).