1 files changed, 386 insertions, 7 deletions

diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index d5d71b5..83f6fd8 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -2305,6 +2305,213 @@ optimize_minmaxloc (gfc_expr **e)
   mpz_set_ui (a->expr->value.integer, 1);
 }
 
+/* Data package to hand down for DO loop checks in a contained
+   procedure.  */
+typedef struct contained_info
+{
+  gfc_symbol *do_var;
+  gfc_symbol *procedure;
+  locus where_do;
+} contained_info;
+
+static enum gfc_exec_op last_io_op;
+
+/* Callback function to check for INTENT(OUT) and INTENT(INOUT) in a
+   contained function call.  */
+
+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
+      || expr->value.function.esym == NULL)
+    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;
+}
+
+/* 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 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 +2596,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 +2665,7 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
 	  a = a->next;
 	  f = f->next;
 	}
+
       break;
 
     default:
@@ -2737,6 +2967,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 +2978,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.  */
@@ -5441,6 +5696,7 @@ check_externals_procedure (gfc_symbol *sym, locus *loc,
   gfc_current_ns = gsym->ns;
 
   gfc_get_formal_from_actual_arglist (new_sym, actual);
+  new_sym->declared_at = *loc;
   gfc_current_ns = save_ns;
 
   return 0;
@@ -5493,12 +5749,66 @@ check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
   return check_externals_procedure (sym, loc, actual);
 }
 
+/* Function to check if any interface clashes with a global
+   identifier, to be invoked via gfc_traverse_ns.  */
+
+static void
+check_against_globals (gfc_symbol *sym)
+{
+  gfc_gsymbol *gsym;
+  gfc_symbol *def_sym = NULL;
+  const char *sym_name;
+  char buf  [200];
+
+  if (sym->attr.if_source != IFSRC_IFBODY || sym->attr.flavor != FL_PROCEDURE
+      || sym->attr.generic || sym->error)
+    return;
+
+  if (sym->binding_label)
+    sym_name = sym->binding_label;
+  else
+    sym_name = sym->name;
+
+  gsym = gfc_find_gsymbol (gfc_gsym_root, sym_name);
+  if (gsym && gsym->ns)
+    gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
+
+  if (!def_sym || def_sym->error || def_sym->attr.generic)
+    return;
+
+  buf[0] = 0;
+  gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, buf, sizeof(buf),
+			  NULL, NULL, NULL);
+  if (buf[0] != 0)
+    {
+      gfc_warning (0, "%s between %L and %L", buf, &def_sym->declared_at,
+		   &sym->declared_at);
+      sym->error = 1;
+      def_sym->error = 1;
+    }
+
+}
+
+/* Do the code-walkling part for gfc_check_externals.  */
+
+static void
+gfc_check_externals0 (gfc_namespace *ns)
+{
+  gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL);
+
+  for (ns = ns->contained; ns; ns = ns->sibling)
+    {
+      if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+	gfc_check_externals0 (ns);
+    }
+
+}
+
 /* Called routine.  */
 
 void
 gfc_check_externals (gfc_namespace *ns)
 {
-
   gfc_clear_error ();
 
   /* Turn errors into warnings if the user indicated this.  */
@@ -5506,13 +5816,82 @@ gfc_check_externals (gfc_namespace *ns)
   if (!pedantic && flag_allow_argument_mismatch)
     gfc_errors_to_warnings (true);
 
-  gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL);
+  gfc_check_externals0 (ns);
+  gfc_traverse_ns (ns, check_against_globals);
+
+  gfc_errors_to_warnings (false);
+}
+
+/* Callback function. If there is a call to a subroutine which is
+   neither pure nor implicit_pure, unset the implicit_pure flag for
+   the caller and return -1.  */
+
+static int
+implicit_pure_call (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+		    void *sym_data)
+{
+  gfc_code *co = *c;
+  gfc_symbol *caller_sym;
+  symbol_attribute *a;
+
+  if (co->op != EXEC_CALL || co->resolved_sym == NULL)
+    return 0;
+
+  a = &co->resolved_sym->attr;
+  if (a->intrinsic || a->pure || a->implicit_pure)
+    return 0;
+
+  caller_sym = (gfc_symbol *) sym_data;
+  gfc_unset_implicit_pure (caller_sym);
+  return 1;
+}
+
+/* Callback function. If there is a call to a function which is
+   neither pure nor implicit_pure, unset the implicit_pure flag for
+   the caller and return 1.  */
+
+static int
+implicit_pure_expr (gfc_expr **e, int *walk ATTRIBUTE_UNUSED, void *sym_data)
+{
+  gfc_expr *expr = *e;
+  gfc_symbol *caller_sym;
+  gfc_symbol *sym;
+  symbol_attribute *a;
+
+  if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym)
+    return 0;
+
+  sym = expr->symtree->n.sym;
+  a = &sym->attr;
+  if (a->pure || a->implicit_pure)
+    return 0;
+
+  caller_sym = (gfc_symbol *) sym_data;
+  gfc_unset_implicit_pure (caller_sym);
+  return 1;
+}
+
+/* Go through all procedures in the namespace and unset the
+   implicit_pure attribute for any procedure that calls something not
+   pure or implicit pure.  */
+
+bool
+gfc_fix_implicit_pure (gfc_namespace *ns)
+{
+  bool changed = false;
+  gfc_symbol *proc = ns->proc_name;
+
+  if (proc && proc->attr.flavor == FL_PROCEDURE && proc->attr.implicit_pure
+      && ns->code
+      && gfc_code_walker (&ns->code, implicit_pure_call, implicit_pure_expr,
+			  (void *) ns->proc_name))
+    changed = true;
 
   for (ns = ns->contained; ns; ns = ns->sibling)
     {
-      if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
-	gfc_check_externals (ns);
+      if (gfc_fix_implicit_pure (ns))
+	changed = true;
     }
 
-  gfc_errors_to_warnings (false);
+  return changed;
 }