Hello world,
after the dicsussion on c.l.f, it become clear that passing a DO loop
variable to an INTENT(OUT) or INTENT(INOUT) dummy argument is an error.
The attached patch throws an error for both cases.
I chose to issue the errors as a front-end pass because we cannot check
for formal arguments during parsing (where the other checks are
implemented).
Regression-tested. OK for trunk?
Thomas
2012-11-01 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/30146
* frontend-passes.c (do_warn): New function.
(do_list): New static variable.
(do_size): New static variable.
(do_list): New static variable.
(gfc_run_passes): Call do_warn.
(do_code): New function.
(do_function): New function.
(gfc_code_walker): Keep track fo DO level.
2012-11-01 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/30146
* gfortran.dg/do_check_6.f90: New test.
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,30 @@ 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_level = 0;
+ do_list = XNEWVEC(gfc_code *, do_size);
+ do_warn (ns);
+ XDELETEVEC (do_list);
+
if (gfc_option.flag_frontend_optimize)
{
expr_size = 20;
@@ -1225,6 +1244,160 @@ optimize_minmaxloc (gfc_expr **e)
mpz_set_ui (a->expr->value.integer, 1);
}
+/* Callback function for code checking that we do not pass a DO variable to an
+ INTENT(OUT) or INTENT(INOUT) dummy variable. */
+
+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:
+
+ /* Grow the temporary storage if necessary. */
+ if (do_level >= do_size)
+ {
+ do_size = 2 * do_size;
+ do_list = XRESIZEVEC (gfc_code *, do_list, do_size);
+ }
+
+ /* Mark the DO loop variable if there is one. */
+ if (co->ext.iterator && co->ext.iterator->var)
+ do_list[do_level] = co;
+ else
+ do_list[do_level] = NULL;
+ break;
+
+ case EXEC_CALL:
+ f = co->symtree->n.sym->formal;
+
+ /* Withot a formal arglist, there is only unknown INTENT,
+ which we don't check for. */
+ if (f == NULL)
+ break;
+
+ a = co->ext.actual;
+
+ while (a && f)
+ {
+ for (i=0; i<do_level; i++)
+ {
+ gfc_symbol *do_sym;
+
+ if (do_list[i] == NULL)
+ break;
+
+ 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->sym->attr.intent == INTENT_OUT)
+ gfc_error_now("Variable '%s' at %L set to undefined value "
+ "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_error_now("Variable '%s' at %L not definable 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);
+ }
+ }
+ a = a->next;
+ f = f->next;
+ }
+ break;
+
+ default:
+ break;
+ }
+ return 0;
+}
+
+/* Callback function for functions checking that we do not pass a DO variable
+ to an INTENt(OUT) or INTENT(INOUT) dummy variable. */
+
+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;
+
+ f = expr->symtree->n.sym->formal;
+
+ /* Withot a formal arglist, there is only unknown INTENT,
+ which we don't check for. */
+ if (f == NULL)
+ return 0;
+
+ a = expr->value.function.actual;
+
+ while (a && f)
+ {
+ for (i=0; i<do_level; i++)
+ {
+ gfc_symbol *do_sym;
+
+
+ if (do_list[i] == NULL)
+ break;
+
+ 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->sym->attr.intent == INTENT_OUT)
+ gfc_error_now("Variable '%s' at %L set to undefined value "
+ "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_error_now("Variable '%s' at %L not definable 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);
+ }
+ }
+ a = a->next;
+ 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 +1556,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 +1775,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;
}
}
! { dg-do compile }
! PR 30146 - warn about DO variables as argument to INTENT(IN) and
! INTENT(INOUT) dummy arguments
program main
implicit none
integer :: i,j, k, l
do k=1,2 ! { dg-error "undefined value" }
do i=1,10 ! { dg-error "definable" }
do j=1,10 ! { dg-error "undefined value" }
do l=1,10 ! { dg-error "definable" }
call s_out(k) ! { dg-error "undefined" }
call s_inout(i) ! { dg-error "definable" }
print *,f_out(j) ! { dg-error "undefined" }
print *,f_inout(l) ! { dg-error "definable" }
end do
end do
end do
end do
contains
subroutine s_out(i_arg)
integer, intent(out) :: i_arg
end subroutine s_out
subroutine s_inout(i_arg)
integer, intent(inout) :: i_arg
end subroutine s_inout
function f_out(i_arg)
integer, intent(out) :: i_arg
integer :: f_out
f_out = i_arg
end function f_out
function f_inout(i_arg)
integer, intent(inout) :: i_arg
integer :: f_inout
f_inout = i_arg
end function f_inout
end program main
