procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Test procedure dummy arguments against global symbols, if available.

Browse source 
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.
This commit is contained in:
Thomas Koenig 2025-02-08 15:18:21 +01:00
parent 9576353454
commit a8d0a2dd65
2 changed files with 97 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

47
gcc/fortran/interface.cc
View file

@ -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)
{

51
gcc/testsuite/gfortran.dg/interface_51.f90 Normal file
View file

@ -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