https://gcc.gnu.org/g:a8d0a2dd6565ea15ce79d8af90f2671cbf9359c7
commit r15-7449-ga8d0a2dd6565ea15ce79d8af90f2671cbf9359c7
Author: Thomas Koenig <tkoe...@gcc.gnu.org>
Date: Sat Feb 8 15:18:21 2025 +0100
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:
---
gcc/fortran/interface.cc | 47 ++++++++++++++++++++++++++-
gcc/testsuite/gfortran.dg/interface_51.f90 | 51 ++++++++++++++++++++++++++++++
2 files changed, 97 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 145f710563a5..49677f15f13c 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 000000000000..c8371e81ec90
--- /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
