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.

diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 145f710563a556936883bf530514300168c69e15..49677f15f13cdb47c1bc2d68717118d18d8b4237 100644 (file)
--- 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 (file)
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