Test procedure dummy arguments against global symbols, if available.

this fixes a rather old PR from 2005, where a subroutine
could be passed and called as a function.  This patch checks
for that, also for the reverse, and for wrong types of functions.

I expect that this will find a few bugs in dusty deck code...

gcc/fortran/ChangeLog:

	PR fortran/24878
	* interface.cc (compare_parameter): Check global subroutines
	passed as actual arguments for subroutine / function and
	function type.

gcc/testsuite/ChangeLog:

	PR fortran/24878
	* gfortran.dg/interface_51.f90: New test.

2 files changed, 97 insertions, 1 deletions

diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 145f710..49677f1 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -2423,6 +2423,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
   gfc_component *ppc;
   bool codimension = false;
   gfc_array_spec *formal_as;
+  const char *actual_name;
 
   /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
      procs c_f_pointer or c_f_procpointer, and we need to accept most
@@ -2487,6 +2488,51 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	  return false;
 	}
 
+      /* The actual symbol may disagree with a global symbol.  If so, issue an
+	 error, but only if no previous error has been reported on the formal
+	 argument.  */
+      actual_name = act_sym->name;
+      if (!formal->error && actual_name)
+	{
+	  gfc_gsymbol *gsym;
+	  gsym = gfc_find_gsymbol (gfc_gsym_root, actual_name);
+	  if (gsym != NULL)
+	    {
+	      if (gsym->type == GSYM_SUBROUTINE && formal->attr.function)
+		{
+		  gfc_error ("Passing global subroutine %qs declared at %L "
+			     "as function at %L", actual_name, &gsym->where,
+			     &actual->where);
+		  return false;
+		}
+	      if (gsym->type == GSYM_FUNCTION && formal->attr.subroutine)
+		{
+		  gfc_error ("Passing global function %qs declared at %L "
+			     "as subroutine at %L", actual_name, &gsym->where,
+			     &actual->where);
+		  return false;
+		}
+	      if (gsym->type == GSYM_FUNCTION)
+		{
+		  gfc_symbol *global_asym;
+		  gfc_find_symbol (actual_name, gsym->ns, 0, &global_asym);
+		  if (global_asym != NULL)
+		    {
+		      gcc_assert (formal->attr.function);
+		      if (!gfc_compare_types (&global_asym->ts, &formal->ts))
+			{
+			  gfc_error ("Type mismatch passing global function %qs "
+				     "declared at %L at %L (%s/%s)",
+				     actual_name, &gsym->where, &actual->where,
+				     gfc_typename (&global_asym->ts),
+				     gfc_dummy_typename (&formal->ts));
+			  return false;
+			}
+		    }
+		}
+	    }
+	}
+
       if (formal->attr.function && !act_sym->attr.function)
 	{
 	  gfc_add_function (&act_sym->attr, act_sym->name,
@@ -2501,7 +2547,6 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 
       return true;
     }
-
   ppc = gfc_get_proc_ptr_comp (actual);
   if (ppc && ppc->ts.interface)
     {
diff --git a/gcc/testsuite/gfortran.dg/interface_51.f90 b/gcc/testsuite/gfortran.dg/interface_51.f90
new file mode 100644
index 0000000..c8371e8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_51.f90
@@ -0,0 +1,51 @@
+! { dg-do compile }
+
+! PR 24878 - passing a global subroutine as a function, or vice versa,
+! was not caught, nor were type mismatches.  Original test case by
+! Uttam Pawar.
+
+program memain
+  implicit none
+  integer subr
+  external subr
+  external i4
+  external r4
+  integer r4
+  
+  call foo(subr) ! { dg-error "Passing global subroutine" }
+  call bar(i4)   ! { dg-error "Passing global function" }
+  call baz(r4)   ! { dg-error "Type mismatch passing global function" }
+end program memain
+
+subroutine foo(ifun)
+  integer(kind=4) ifun
+  external ifun
+  integer y
+!---FNC is not a Function subprogram so calling it
+!   as a function is an error.
+  Y=ifun(32)
+end subroutine foo
+
+subroutine bar(sub)
+  call sub
+end subroutine bar
+
+subroutine subr(X) ! { dg-error "Passing global subroutine" }
+  integer x
+  x = 12345
+end subroutine subr
+
+integer(kind=4) function i4() ! { dg-error "Passing global function" }
+  i4 = 42
+end function i4
+
+real(kind=4) function r4() ! { dg-error "Type mismatch passing global function" }
+  r4 = 1.0
+end function r4
+  
+subroutine baz(ifun)
+  integer(kind=4) ifun
+  external ifun
+  integer y
+  y = ifun(32)
+end subroutine baz