Hello world, the attached patch, which is not in its final stage, implements some warnings for index variables of DO loops. For the following situations, errors/warnings are issued when an index loop variable is passed as an actual argument:
- If the dummy argument has INTENT(OUT). I think an error should be issued unconditionally. - If the dummy argument has INTENT(INOUT). My opinion is that a warning should be issued unconditionally, but I am open to the opinions that an error would be better, or that it should depend on an option. - If the dummy argument has no INTENT, or if the procedure has no explicit interface, I think that there should be a warning depending on an option (which I haven't yet implemented). Opinions? If there is agreement on the question of which options should select which errors/warnings, then I will submit a final patch including some more comments, a ChangeLog entry and a deja-gnuified test case. Thomas
Index: frontend-passes.c =================================================================== --- frontend-passes.c (Revision 192894) +++ frontend-passes.c (Arbeitskopie) @@ -39,6 +39,7 @@ static bool optimize_trim (gfc_expr *); static bool optimize_lexical_comparison (gfc_expr *); static void optimize_minmaxloc (gfc_expr **); static bool empty_string (gfc_expr *e); +static void do_warn (gfc_namespace *); /* How deep we are inside an argument list. */ @@ -76,12 +77,29 @@ static bool in_omp_workshare; static int iterator_level; -/* Entry point - run all passes for a namespace. So far, only an - optimization pass is run. */ +/* Keep track of DO loop levels. */ +static gfc_code **do_list; +static int do_size, do_level; + +/* Vector of gfc_expr * to keep track of DO loops. */ + +struct my_struct *evec; + +/* Entry point - run all passes for a namespace. */ + void gfc_run_passes (gfc_namespace *ns) { + + /* Warn about dubious DO loops where the index might + change. */ + + do_size = 20; + do_list = XNEWVEC(gfc_code *, do_size); + do_warn (ns); + XDELETEVEC (do_list); + if (gfc_option.flag_frontend_optimize) { expr_size = 20; @@ -605,6 +623,7 @@ optimize_namespace (gfc_namespace *ns) current_ns = ns; forall_level = 0; iterator_level = 0; + do_level = 0; in_omp_workshare = false; gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL); @@ -1225,6 +1244,157 @@ optimize_minmaxloc (gfc_expr **e) mpz_set_ui (a->expr->value.integer, 1); } +static int +do_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_code *co; + int i; + gfc_formal_arglist *f; + gfc_actual_arglist *a; + + co = *c; + + switch (co->op) + { + case EXEC_DO: + if (do_level >= do_size) + { + do_size = 2 * do_size; + do_list = XRESIZEVEC (gfc_code *, do_list, do_size); + } + + if (co->ext.iterator && co->ext.iterator->var) + do_list[do_level] = co; + else + do_list[do_level] = NULL; + break; + + case EXEC_CALL: + a = co->ext.actual; + f = co->symtree->n.sym->formal; + + while (a) + { + for (i=0; i<do_level; i++) + { + if (do_list[i] == NULL) + break; + + gfc_symbol *do_sym = do_list[i]->ext.iterator->var->symtree->n.sym; + + if (a->expr && a->expr->symtree + && a->expr->symtree->n.sym == do_sym) + { + if (f) + { + if (f->sym->attr.intent == INTENT_OUT) + gfc_error_now("Variable '%s' at %L redefined inside loop " + "beginning at %L as INTENT(OUT) argument to " + "subroutine '%s'", do_sym->name, &a->expr->where, + &do_list[i]->loc, co->symtree->n.sym->name); + else if (f->sym->attr.intent == INTENT_INOUT) + gfc_warning_now("Variable '%s' at %L may redefined inside loop " + "beginning at %L as INTENT(INOUT) argument to " + "subroutine '%s'", do_sym->name, &a->expr->where, + &do_list[i]->loc, co->symtree->n.sym->name); + else if (f->sym->attr.intent == INTENT_UNKNOWN) + gfc_warning_now("Variable '%s' at %L may redefined inside loop " + "beginning at %L as argument to " + "subroutine '%s'", do_sym->name, &a->expr->where, + &do_list[i]->loc, co->symtree->n.sym->name); + } + else + gfc_warning_now("Variable '%s' at %L may redefined inside loop " + "beginning at %L as argument to " + "subroutine '%s'", do_sym->name, &a->expr->where, + &do_list[i]->loc, co->symtree->n.sym->name); + } + } + a = a->next; + if (f) + f = f->next; + } + break; + + default: + break; + } + return 0; +} + +static int +do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_formal_arglist *f; + gfc_actual_arglist *a; + gfc_expr *expr; + int i; + + expr = *e; + if (expr->expr_type != EXPR_FUNCTION) + return 0; + + /* Intrinsic functions don't modify their arguments. */ + + if (expr->value.function.isym) + return 0; + + a = expr->value.function.actual; + f = expr->symtree->n.sym->formal; + + while (a) + { + for (i=0; i<do_level; i++) + { + if (do_list[i] == NULL) + break; + + gfc_symbol *do_sym = do_list[i]->ext.iterator->var->symtree->n.sym; + + if (a->expr && a->expr->symtree + && a->expr->symtree->n.sym == do_sym) + { + if (f) + { + if (f->sym->attr.intent == INTENT_OUT) + gfc_error_now("Variable '%s' at %L redefined inside loop " + "beginning at %L as INTENT(OUT) argument to " + "function '%s'", do_sym->name, &a->expr->where, + &do_list[i]->loc, expr->symtree->n.sym->name); + else if (f->sym->attr.intent == INTENT_INOUT) + gfc_warning_now("Variable '%s' at %L may redefined inside loop " + "beginning at %L as INTENT(INOUT) argument to " + "function '%s'", do_sym->name, &a->expr->where, + &do_list[i]->loc, expr->symtree->n.sym->name); + else if (f->sym->attr.intent == INTENT_UNKNOWN) + gfc_warning_now("Variable '%s' at %L may redefined inside loop " + "beginning at %L as argument to " + "function '%s'", do_sym->name, &a->expr->where, + &do_list[i]->loc, expr->symtree->n.sym->name); + } + else + gfc_warning_now("Variable '%s' at %L may redefined inside loop " + "beginning at %L as argument to " + "function '%s'", do_sym->name, + &expr->where, &do_list[i]->loc, expr->symtree->n.sym->name); + } + } + a = a->next; + if (f) + f = f->next; + } + return 0; +} + +static void +do_warn (gfc_namespace *ns) +{ + gfc_code_walker (&ns->code, do_code, do_function, NULL); +} + + #define WALK_SUBEXPR(NODE) \ do \ { \ @@ -1383,6 +1553,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t code break; case EXEC_DO: + do_level ++; WALK_SUBEXPR (co->ext.iterator->var); WALK_SUBEXPR (co->ext.iterator->start); WALK_SUBEXPR (co->ext.iterator->end); @@ -1601,6 +1772,9 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t code if (co->op == EXEC_FORALL) forall_level --; + if (co->op == EXEC_DO) + do_level --; + in_omp_workshare = saved_in_omp_workshare; } }
module foo implicit none contains subroutine bar(i) integer, intent(out) :: i end subroutine bar subroutine baz(i) integer, intent(inout) :: i end subroutine baz subroutine bax(i) integer :: i end subroutine bax function froo(i, j, k) integer, intent(out) :: i integer, intent(inout) :: j integer :: k integer :: froo end function froo end module foo program main use foo implicit none integer :: i,j, k do k=1,2 do i=1,10 do j=1,10 call bar(i) call baz(j) call bax(i) call bux(i) print *,froo(i, j, k) read (*,*) i end do end do end do end program main