re PR fortran/91390 (treatment of extra parameter in a subroutine call)

2019-08-24  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/91390
	PR fortran/91519
	* frontend-passes.c (check_externals_procedure): New
	function. If a procedure is not in the translation unit, create
	an "interface" for it, including its formal arguments.
	(check_externals_code): Use check_externals_procedure for common
	code with check_externals_expr.
	(check_externals_expr): Vice versa.
	* gfortran.h (gfc_get_formal_from_actual-arglist): New prototype.
	(gfc_compare_actual_formal): New prototype.
	* interface.c (compare_actual_formal): Rename to
	(gfc_compare_actual_formal): New function, make global.
	(gfc_get_formal_from_actual_arglist): Make global, and move here from
	* trans-types.c (get_formal_from_actual_arglist): Remove here.
	(gfc_get_function_type): Use gfc_get_formal_from_actual_arglist.

2019-08-24  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/91390
	PR fortran/91519
	* gfortran.dg/bessel_3.f90: Add type mismatch errors.
	* gfortran.dg/coarray_7.f90: Rename subroutines to avoid
	additional errors.
	* gfortran.dg/g77/20010519-1.f: Add -std=legacy. Remove
	warnings for ASSIGN. Add warnings for type mismatch.
	* gfortran.dg/goacc/acc_on_device-1.f95: Add -std=legacy.
	Add catch-all warning.
	* gfortran.dg/internal_pack_9.f90: Rename subroutine to
	avoid type error.
	* gfortran.dg/internal_pack_9.f90: Add -std=legacy. Add
	warnings for type mismatch.
	* gfortran.dg/pr39937.f: Add -std=legacy and type warnings. Move
	here from
	* gfortran.fortran-torture/compile/pr39937.f: Move to
	gfortran.dg.

From-SVN: r274902

5 files changed, 153 insertions, 98 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4bd9291..abdf9e6 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,21 @@
+2019-08-24  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/91390
+	PR fortran/91519
+	* frontend-passes.c (check_externals_procedure): New
+	function. If a procedure is not in the translation unit, create
+	an "interface" for it, including its formal arguments.
+	(check_externals_code): Use check_externals_procedure for common
+	code with check_externals_expr.
+	(check_externals_expr): Vice versa.
+	* gfortran.h (gfc_get_formal_from_actual-arglist): New prototype.
+	(gfc_compare_actual_formal): New prototype.
+	* interface.c (compare_actual_formal): Rename to
+	(gfc_compare_actual_formal): New function, make global.
+	(gfc_get_formal_from_actual_arglist): Make global, and move here from
+	* trans-types.c (get_formal_from_actual_arglist): Remove here.
+	(gfc_get_function_type): Use gfc_get_formal_from_actual_arglist.
+
 2019-08-23  Mark Eggleston  <mark.eggleston@codethink.com>
 
 	* intrinsics.text: References in 'See also:' are now on
@@ -14,7 +32,7 @@
 
 2019-08-23  Mark Eggleston  <mark.eggleston@codethink.com>
 
-	* intrinsics.text: Removed empty sections. The order of 
+	* intrinsics.text: Removed empty sections. The order of
 	sections for each intrinsic is now consistent throughout.
 	Stray words removed. Text in the wrong section moved.
 	Missing standard statement inserted.
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index dd82089..fa41667 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -5369,72 +5369,104 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
    We do this by looping over the code (and expressions). The first call
    we happen to find is assumed to be canonical.  */
 
-/* Callback for external functions.  */
+
+/* Common tests for argument checking for both functions and subroutines.  */
 
 static int
-check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
-		      void *data ATTRIBUTE_UNUSED)
+check_externals_procedure (gfc_symbol *sym, locus *loc, gfc_actual_arglist *actual)
 {
-  gfc_expr *e = *ep;
-  gfc_symbol *sym, *def_sym;
   gfc_gsymbol *gsym;
+  gfc_symbol *def_sym = NULL;
 
-  if (e->expr_type != EXPR_FUNCTION)
+ if (sym == NULL || sym->attr.is_bind_c)
     return 0;
 
-  sym = e->value.function.esym;
-
-  if (sym == NULL || sym->attr.is_bind_c)
+  if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
     return 0;
 
-  if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
+  if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
     return 0;
 
   gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
   if (gsym == NULL)
     return 0;
 
-  gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
+  if (gsym->ns)
+    gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
 
-  if (sym && def_sym)
-    gfc_procedure_use (def_sym, &e->value.function.actual, &e->where);
+  if (def_sym)
+    {
+      gfc_procedure_use (def_sym, &actual, loc);
+      return 0;
+    }
+
+  /* First time we have seen this procedure called. Let's create an
+     "interface" from the call and put it into a new namespace.  */
+  gfc_namespace *save_ns;
+  gfc_symbol *new_sym;
+
+  gsym->where = *loc;
+  save_ns = gfc_current_ns;
+  gsym->ns = gfc_get_namespace (gfc_current_ns, 0);
+  gsym->ns->proc_name = sym;
+
+  gfc_get_symbol (sym->name, gsym->ns, &new_sym);
+  gcc_assert (new_sym);
+  new_sym->attr = sym->attr;
+  new_sym->attr.if_source = IFSRC_DECL;
+  gfc_current_ns = gsym->ns;
+
+  gfc_get_formal_from_actual_arglist (new_sym, actual);
+  gfc_current_ns = save_ns;
 
   return 0;
+
 }
 
-/* Callback for external code.  */
+/* Callback for calls of external routines.  */
 
 static int
 check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
 		      void *data ATTRIBUTE_UNUSED)
 {
   gfc_code *co = *c;
-  gfc_symbol *sym, *def_sym;
-  gfc_gsymbol *gsym;
+  gfc_symbol *sym;
+  locus *loc;
+  gfc_actual_arglist *actual;
 
   if (co->op != EXEC_CALL)
     return 0;
 
   sym = co->resolved_sym;
-  if (sym == NULL || sym->attr.is_bind_c)
-    return 0;
+  loc = &co->loc;
+  actual = co->ext.actual;
 
-  if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
-    return 0;
+  return check_externals_procedure (sym, loc, actual);
 
-  if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
-    return 0;
+}
 
-  gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
-  if (gsym == NULL)
+/* Callback for external functions.  */
+
+static int
+check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
+		      void *data ATTRIBUTE_UNUSED)
+{
+  gfc_expr *e = *ep;
+  gfc_symbol *sym;
+  locus *loc;
+  gfc_actual_arglist *actual;
+
+  if (e->expr_type != EXPR_FUNCTION)
     return 0;
 
-  gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
+  sym = e->value.function.esym;
+  if (sym == NULL)
+    return 0;
 
-  if (sym && def_sym)
-    gfc_procedure_use (def_sym, &co->ext.actual, &co->loc);
+  loc = &e->where;
+  actual = e->value.function.actual;
 
-  return 0;
+  return check_externals_procedure (sym, loc, actual);
 }
 
 /* Called routine.  */
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6a491ab..7f54897 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3421,6 +3421,9 @@ bool gfc_check_typebound_override (gfc_symtree*, gfc_symtree*);
 void gfc_check_dtio_interfaces (gfc_symbol*);
 gfc_symtree* gfc_find_typebound_dtio_proc (gfc_symbol *, bool, bool);
 gfc_symbol* gfc_find_specific_dtio_proc (gfc_symbol*, bool, bool);
+void gfc_get_formal_from_actual_arglist (gfc_symbol *, gfc_actual_arglist *);
+bool gfc_compare_actual_formal (gfc_actual_arglist **, gfc_formal_arglist *,
+				int, int, bool, locus *);
 
 
 /* io.c */
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index d6f6cce..43d7cd5 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2878,10 +2878,10 @@ lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments)
    errors when things don't match instead of just returning the status
    code.  */
 
-static bool
-compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
-	 	       int ranks_must_agree, int is_elemental,
-		       bool in_statement_function, locus *where)
+bool
+gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
+			   int ranks_must_agree, int is_elemental,
+			   bool in_statement_function, locus *where)
 {
   gfc_actual_arglist **new_arg, *a, *actual;
   gfc_formal_arglist *f;
@@ -3805,8 +3805,8 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 
   /* For a statement function, check that types and type parameters of actual
      arguments and dummy arguments match.  */
-  if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental,
-			      sym->attr.proc == PROC_ST_FUNCTION, where))
+  if (!gfc_compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental,
+				  sym->attr.proc == PROC_ST_FUNCTION, where))
     return false;
  
   if (!check_intents (dummy_args, *ap))
@@ -3854,7 +3854,7 @@ gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
       return;
     }
 
-  if (!compare_actual_formal (ap, comp->ts.interface->formal, 0,
+  if (!gfc_compare_actual_formal (ap, comp->ts.interface->formal, 0,
 			      comp->attr.elemental, false, where))
     return;
 
@@ -3880,7 +3880,7 @@ gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
   dummy_args = gfc_sym_get_dummy_args (sym);
 
   r = !sym->attr.elemental;
-  if (compare_actual_formal (args, dummy_args, r, !r, false, NULL))
+  if (gfc_compare_actual_formal (args, dummy_args, r, !r, false, NULL))
     {
       check_intents (dummy_args, *args);
       if (warn_aliasing)
@@ -5131,3 +5131,65 @@ finish:
 
   return dtio_sub;
 }
+
+/* Helper function - if we do not find an interface for a procedure,
+   construct it from the actual arglist.  Luckily, this can only
+   happen for call by reference, so the information we actually need
+   to provide (and which would be impossible to guess from the call
+   itself) is not actually needed.  */
+
+void
+gfc_get_formal_from_actual_arglist (gfc_symbol *sym,
+				    gfc_actual_arglist *actual_args)
+{
+  gfc_actual_arglist *a;
+  gfc_formal_arglist **f;
+  gfc_symbol *s;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  static int var_num;
+
+  f = &sym->formal;
+  for (a = actual_args; a != NULL; a = a->next)
+    {
+      (*f) = gfc_get_formal_arglist ();
+      if (a->expr)
+	{
+	  snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++);
+	  gfc_get_symbol (name, gfc_current_ns, &s);
+	  if (a->expr->ts.type == BT_PROCEDURE)
+	    {
+	      s->attr.flavor = FL_PROCEDURE;
+	    }
+	  else
+	    {
+	      s->ts = a->expr->ts;
+
+	      if (s->ts.type == BT_CHARACTER)
+		s->ts.u.cl = gfc_get_charlen ();
+
+	      s->ts.deferred = 0;
+	      s->ts.is_iso_c = 0;
+	      s->ts.is_c_interop = 0;
+	      s->attr.flavor = FL_VARIABLE;
+	      s->attr.artificial = 1;
+	      if (a->expr->rank > 0)
+		{
+		  s->attr.dimension = 1;
+		  s->as = gfc_get_array_spec ();
+		  s->as->rank = 1;
+		  s->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
+						      &a->expr->where, 1);
+		  s->as->upper[0] = NULL;
+		  s->as->type = AS_ASSUMED_SIZE;
+		}
+	    }
+	  s->attr.dummy = 1;
+	  s->attr.intent = INTENT_UNKNOWN;
+	  (*f)->sym = s;
+	}
+      else  /* If a->expr is NULL, this is an alternate rerturn.  */
+	(*f)->sym = NULL;
+
+      f = &((*f)->next);
+    }
+}
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index e1033b3..82666c4 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2975,66 +2975,6 @@ create_fn_spec (gfc_symbol *sym, tree fntype)
   return build_type_attribute_variant (fntype, tmp);
 }
 
-/* Helper function - if we do not find an interface for a procedure,
-   construct it from the actual arglist.  Luckily, this can only
-   happen for call by reference, so the information we actually need
-   to provide (and which would be impossible to guess from the call
-   itself) is not actually needed.  */
-
-static void
-get_formal_from_actual_arglist (gfc_symbol *sym, gfc_actual_arglist *actual_args)
-{
-  gfc_actual_arglist *a;
-  gfc_formal_arglist **f;
-  gfc_symbol *s;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
-  static int var_num;
-
-  f = &sym->formal;
-  for (a = actual_args; a != NULL; a = a->next)
-    {
-      (*f) = gfc_get_formal_arglist ();
-      if (a->expr)
-	{
-	  snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++);
-	  gfc_get_symbol (name, gfc_current_ns, &s);
-	  if (a->expr->ts.type == BT_PROCEDURE)
-	    {
-	      s->attr.flavor = FL_PROCEDURE;
-	    }
-	  else
-	    {
-	      s->ts = a->expr->ts;
-
-	      if (s->ts.type == BT_CHARACTER)
-		  s->ts.u.cl = gfc_get_charlen ();
-
-	      s->ts.deferred = 0;
-	      s->ts.is_iso_c = 0;
-	      s->ts.is_c_interop = 0;
-	      s->attr.flavor = FL_VARIABLE;
-	      if (a->expr->rank > 0)
-		{
-		  s->attr.dimension = 1;
-		  s->as = gfc_get_array_spec ();
-		  s->as->rank = 1;
-		  s->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
-						      &a->expr->where, 1);
-		  s->as->upper[0] = NULL;
-		  s->as->type = AS_ASSUMED_SIZE;
-		}
-	    }
-	  s->attr.dummy = 1;
-	  s->attr.intent = INTENT_UNKNOWN;
-	  (*f)->sym = s;
-	}
-      else  /* If a->expr is NULL, this is an alternate rerturn.  */
-	(*f)->sym = NULL;
-
-      f = &((*f)->next);
-    }
-}
-
 tree
 gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args)
 {
@@ -3097,7 +3037,7 @@ gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args)
   if (sym->backend_decl == error_mark_node && actual_args != NULL
       && sym->formal == NULL && (sym->attr.proc == PROC_EXTERNAL
 				 || sym->attr.proc == PROC_UNKNOWN))
-    get_formal_from_actual_arglist (sym, actual_args);
+    gfc_get_formal_from_actual_arglist (sym, actual_args);
 
   /* Build the argument types for the function.  */
   for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)