diff mbox series

[fortran] Compile-time check for change in DO variable in contained procedures

Message ID 8cb915f9-f02d-81c5-71b2-8dddddadbe1e@netcologne.de
State New
Headers show
Series [fortran] Compile-time check for change in DO variable in contained procedures | expand

Commit Message

Thomas Koenig Aug. 4, 2020, 7:01 p.m. UTC 
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.

Comments

Paul Richard Thomas Aug. 5, 2020, 3:17 p.m. UTC | #1 
Hi Thomas,

This is OK by me.

Is it worth testing the INTENT variants?

Cheers

Paul


On Tue, 4 Aug 2020 at 20:03, Thomas Koenig via Fortran <fortran@gcc.gnu.org>
wrote:

> 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.
>
Thomas Koenig Aug. 5, 2020, 4:41 p.m. UTC | #2 
Hi Paul,

> This is OK by me.

Committed (or should I say "pushed"?), thanks!

> Is it worth testing the INTENT variants?

I added a test for INTENT(INOUT), here's the version of the
test case that was committed.

Best regards

	Thomas
Paul Richard Thomas Aug. 5, 2020, 4:50 p.m. UTC | #3 
I must say that I was thinking rather more of the INTENT(IN) case to make
sure that it is accepted.

Paul


On Wed, 5 Aug 2020 at 17:41, Thomas Koenig <tkoenig@netcologne.de> wrote:

> Hi Paul,
>
> > This is OK by me.
>
> Committed (or should I say "pushed"?), thanks!
>
> > Is it worth testing the INTENT variants?
>
> I added a test for INTENT(INOUT), here's the version of the
> test case that was committed.
>
> Best regards
>
>         Thomas
>
Thomas Koenig Aug. 5, 2020, 6:58 p.m. UTC | #4 
Hi Paul,

> I must say that I was thinking rather more of the INTENT(IN) case to make
> sure that it is accepted.

Ah, I misunderstood that.  You're right - also check legal code :-)

I've committed the attached test case as obvious (after verifying that
it passes. It checks against functions and subrotuines with
INTENT(IN) and unspecified intent.

Best regards

	Thomas

Added test case to make sure that legal cases still pass.

gcc/testsuite/ChangeLog:

	PR fortran/96469
	* gfortran.dg/do_check_14.f90: New test.
diff mbox series

Patch

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" }