[patch, RFC] PR 30146, warning/errors for potentially changing values in DO loops

[Thomas Koenig <tkoenig at netcologne dot de>]

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