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

1 files changed, 60 insertions, 28 deletions

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.  */