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, 70 insertions, 8 deletions

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);
+    }
+}