Hello world,
the attached patch issues an error for something that I am sure most
people did at least once (I know I did), something like
do i=1,10
call foo
end do
...
contains
subroutine foo
do i=1,5
...
end do
which is, of course, illegal, but the programmer's fault. We issue an
error with -fcheck=all, but a compile-time is better, of course.
As you can see from the modification of do_check_4.f90, you have to go
to some lengths to fool the compiler with this patch.
As an aside, I could really have used three places for the error
message here. As is, I settled for the place of the call from
the DO loop checked, and the place where it is modified. With
the name of the variable, the user should be able to figure out
what's wrong.
Regression-tested. OK for trunk?
Best regards
Thomas
Static analysis for definition of DO index variables in contained
procedures.
When encountering a procedure call in a DO loop, this patch checks if
the call is to a contained procedure, and if it is, check for
changes in the index variable.
gcc/fortran/ChangeLog:
PR fortran/96469
* frontend-passes.c (doloop_contained_function_call): New
function.
(doloop_contained_procedure_code): New function.
(CHECK_INQ): Macro for inquire checks.
(doloop_code): Invoke doloop_contained_procedure_code and
doloop_contained_function_call if appropriate.
(do_intent): Likewise.
gcc/testsuite/ChangeLog:
PR fortran/96469
* gfortran.dg/do_check_4.f90: Hide change in index variable
from compile-time analysis.
* gfortran.dg/do_check_4.f90: New test.
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index cdeed8943b0..13390e33188 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -2305,6 +2305,208 @@ optimize_minmaxloc (gfc_expr **e)
mpz_set_ui (a->expr->value.integer, 1);
}
+typedef struct contained_info
+{
+ gfc_symbol *do_var;
+ gfc_symbol *procedure;
+ locus where_do;
+} contained_info;
+
+
+/* Callback function that goes through the code in a contained
+ procedure to make sure it does not change a variable in a DO
+ loop. */
+
+static enum gfc_exec_op last_io_op;
+
+static int
+doloop_contained_function_call (gfc_expr **e,
+ int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
+{
+ gfc_expr *expr = *e;
+ gfc_formal_arglist *f;
+ gfc_actual_arglist *a;
+ gfc_symbol *sym, *do_var;
+ contained_info *info;
+
+ if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym)
+ return 0;
+
+ sym = expr->value.function.esym;
+ f = gfc_sym_get_dummy_args (sym);
+ if (f == NULL)
+ return 0;
+
+ info = (contained_info *) data;
+ do_var = info->do_var;
+ a = expr->value.function.actual;
+
+ while (a && f)
+ {
+ if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
+ {
+ if (f->sym->attr.intent == INTENT_OUT)
+ {
+ gfc_error_now ("Index variable %qs set to undefined as "
+ "INTENT(OUT) argument at %L in procedure %qs "
+ "called from within DO loop at %L", do_var->name,
+ &a->expr->where, info->procedure->name,
+ &info->where_do);
+ return 1;
+ }
+ else if (f->sym->attr.intent == INTENT_INOUT)
+ {
+ gfc_error_now ("Index variable %qs not definable as "
+ "INTENT(INOUT) argument at %L in procedure %qs "
+ "called from within DO loop at %L", do_var->name,
+ &a->expr->where, info->procedure->name,
+ &info->where_do);
+ return 1;
+ }
+ }
+ a = a->next;
+ f = f->next;
+ }
+ return 0;
+}
+
+static int
+doloop_contained_procedure_code (gfc_code **c,
+ int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data)
+{
+ gfc_code *co = *c;
+ contained_info *info = (contained_info *) data;
+ gfc_symbol *do_var = info->do_var;
+ const char *errmsg = _("Index variable %qs redefined at %L in procedure %qs "
+ "called from within DO loop at %L");
+ static enum gfc_exec_op saved_io_op;
+
+ switch (co->op)
+ {
+ case EXEC_ASSIGN:
+ if (co->expr1->symtree->n.sym == do_var)
+ gfc_error_now (errmsg, do_var->name, &co->loc, info->procedure->name,
+ &info->where_do);
+ break;
+
+ case EXEC_DO:
+ if (co->ext.iterator && co->ext.iterator->var
+ && co->ext.iterator->var->symtree->n.sym == do_var)
+ gfc_error (errmsg, do_var->name, &co->loc, info->procedure->name,
+ &info->where_do);
+ break;
+
+ case EXEC_READ:
+ case EXEC_WRITE:
+ case EXEC_INQUIRE:
+ saved_io_op = last_io_op;
+ last_io_op = co->op;
+ break;
+
+ case EXEC_OPEN:
+ if (co->ext.open->iostat
+ && co->ext.open->iostat->symtree->n.sym == do_var)
+ gfc_error_now (errmsg, do_var->name, &co->ext.open->iostat->where,
+ info->procedure->name, &info->where_do);
+ break;
+
+ case EXEC_CLOSE:
+ if (co->ext.close->iostat
+ && co->ext.close->iostat->symtree->n.sym == do_var)
+ gfc_error_now (errmsg, do_var->name, &co->ext.close->iostat->where,
+ info->procedure->name, &info->where_do);
+ break;
+
+ case EXEC_TRANSFER:
+ switch (last_io_op)
+ {
+
+ case EXEC_INQUIRE:
+#define CHECK_INQ(a) do { if (co->ext.inquire->a && \
+ co->ext.inquire->a->symtree->n.sym == do_var) \
+ gfc_error_now (errmsg, do_var->name, \
+ &co->ext.inquire->a->where, \
+ info->procedure->name, \
+ &info->where_do); \
+ } while (0)
+
+ CHECK_INQ(iostat);
+ CHECK_INQ(number);
+ CHECK_INQ(position);
+ CHECK_INQ(recl);
+ CHECK_INQ(position);
+ CHECK_INQ(iolength);
+ CHECK_INQ(strm_pos);
+ break;
+#undef CHECK_INQ
+
+ case EXEC_READ:
+ if (co->expr1 && co->expr1->symtree->n.sym == do_var)
+ gfc_error_now (errmsg, do_var->name, &co->expr1->where,
+ info->procedure->name, &info->where_do);
+
+ /* Fallthrough. */
+
+ case EXEC_WRITE:
+ if (co->ext.dt->iostat
+ && co->ext.dt->iostat->symtree->n.sym == do_var)
+ gfc_error_now (errmsg, do_var->name, &co->ext.dt->iostat->where,
+ info->procedure->name, &info->where_do);
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ break;
+
+ case EXEC_DT_END:
+ last_io_op = saved_io_op;
+ break;
+
+ case EXEC_CALL:
+ gfc_formal_arglist *f;
+ gfc_actual_arglist *a;
+
+ f = gfc_sym_get_dummy_args (co->resolved_sym);
+ if (f == NULL)
+ break;
+ a = co->ext.actual;
+ /* Slightly different error message here. If there is an error,
+ return 1 to avoid an infinite loop. */
+ while (a && f)
+ {
+ if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
+ {
+ if (f->sym->attr.intent == INTENT_OUT)
+ {
+ gfc_error_now ("Index variable %qs set to undefined as "
+ "INTENT(OUT) argument at %L in subroutine %qs "
+ "called from within DO loop at %L",
+ do_var->name, &a->expr->where,
+ info->procedure->name, &info->where_do);
+ return 1;
+ }
+ else if (f->sym->attr.intent == INTENT_INOUT)
+ {
+ gfc_error_now ("Index variable %qs not definable as "
+ "INTENT(INOUT) argument at %L in subroutine %qs "
+ "called from within DO loop at %L", do_var->name,
+ &a->expr->where, info->procedure->name,
+ &info->where_do);
+ return 1;
+ }
+ }
+ a = a->next;
+ f = f->next;
+ }
+ break;
+ default:
+ break;
+ }
+ return 0;
+}
+
/* Callback function for code checking that we do not pass a DO variable to an
INTENT(OUT) or INTENT(INOUT) dummy variable. */
@@ -2389,10 +2591,32 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
break;
case EXEC_CALL:
-
if (co->resolved_sym == NULL)
break;
+ /* Test if somebody stealthily changes the DO variable from
+ under us by changing it in a host-associated procedure. */
+ if (co->resolved_sym->attr.contained)
+ {
+ FOR_EACH_VEC_ELT (doloop_list, i, lp)
+ {
+ gfc_symbol *sym = co->resolved_sym;
+ contained_info info;
+ gfc_namespace *ns;
+
+ cl = lp->c;
+ info.do_var = cl->ext.iterator->var->symtree->n.sym;
+ info.procedure = co->resolved_sym; /* sym? */
+ info.where_do = co->loc;
+ /* Look contained procedures under the namespace of the
+ variable. */
+ for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
+ if (ns->proc_name && ns->proc_name == sym)
+ gfc_code_walker (&ns->code, doloop_contained_procedure_code,
+ doloop_contained_function_call, &info);
+ }
+ }
+
f = gfc_sym_get_dummy_args (co->resolved_sym);
/* Withot a formal arglist, there is only unknown INTENT,
@@ -2436,6 +2660,7 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
a = a->next;
f = f->next;
}
+
break;
default:
@@ -2737,6 +2962,7 @@ do_intent (gfc_expr **e)
gfc_code *dl;
do_t *lp;
int i;
+ gfc_symbol *sym;
expr = *e;
if (expr->expr_type != EXPR_FUNCTION)
@@ -2747,7 +2973,31 @@ do_intent (gfc_expr **e)
if (expr->value.function.isym)
return 0;
- f = gfc_sym_get_dummy_args (expr->symtree->n.sym);
+ sym = expr->value.function.esym;
+ if (sym == NULL)
+ return 0;
+
+ if (sym->attr.contained)
+ {
+ FOR_EACH_VEC_ELT (doloop_list, i, lp)
+ {
+ contained_info info;
+ gfc_namespace *ns;
+
+ dl = lp->c;
+ info.do_var = dl->ext.iterator->var->symtree->n.sym;
+ info.procedure = sym;
+ info.where_do = expr->where;
+ /* Look contained procedures under the namespace of the
+ variable. */
+ for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
+ if (ns->proc_name && ns->proc_name == sym)
+ gfc_code_walker (&ns->code, doloop_contained_procedure_code,
+ dummy_expr_callback, &info);
+ }
+ }
+
+ f = gfc_sym_get_dummy_args (sym);
/* Without a formal arglist, there is only unknown INTENT,
which we don't check for. */
diff --git a/gcc/testsuite/gfortran.dg/do_check_4.f90 b/gcc/testsuite/gfortran.dg/do_check_4.f90
index 65bc92c7e1a..5b087e4dde3 100644
--- a/gcc/testsuite/gfortran.dg/do_check_4.f90
+++ b/gcc/testsuite/gfortran.dg/do_check_4.f90
@@ -5,17 +5,23 @@
! PR fortran/34656
! Run-time check for modifing loop variables
!
+
+module x
+ integer :: i
+contains
+ SUBROUTINE do_something()
+ IMPLICIT NONE
+ DO i=1,10
+ ENDDO
+ END SUBROUTINE do_something
+end module x
+
PROGRAM test
+ use x
IMPLICIT NONE
- INTEGER :: i
DO i=1,100
- CALL do_something()
+ CALL do_something()
ENDDO
-CONTAINS
- SUBROUTINE do_something()
- IMPLICIT NONE
- DO i=1,10
- ENDDO
- END SUBROUTINE do_something
-END PROGRAM test
+end PROGRAM test
+
! { dg-output "Fortran runtime error: Loop variable has been modified" }
