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 <tkoe...@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 <tkoe...@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.
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
! { 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
! { 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