Fix ICE in compare_parameter.

This patch fixes an ICE by setting the typespec of a dummy argument
from a global function if known. plus setting the correct flag.
This also removes the corresponding assert.  I'm not quite sure
that the code with the subroutine attribute can be reached, but
I thought better safe than sorry.

gcc/fortran/ChangeLog:

	PR fortran/119669
	* interface.cc (compare_parameter): Error when mismatch between
	formal argument as subroutine and function.  If the dummy
	argument is a known function, set its typespec.

gcc/testsuite/ChangeLog:

	PR fortran/119669
	* gfortran.dg/interface_59.f90: New test.
This commit is contained in:
Thomas Koenig 2025-04-13 10:22:07 +02:00
parent 1fda2deeea
commit 64319b2cca
2 changed files with 39 additions and 7 deletions

View file

@ -2534,16 +2534,33 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
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))
if (formal->attr.subroutine)
{
gfc_error ("Type mismatch at %L passing global "
"function %qs declared at %L (%s/%s)",
&actual->where, actual_name, &gsym->where,
gfc_typename (&global_asym->ts),
gfc_dummy_typename (&formal->ts));
gfc_error ("Mismatch between subroutine and "
"function at %L", &actual->where);
return false;
}
else if (formal->attr.function)
{
if (!gfc_compare_types (&global_asym->ts,
&formal->ts))
{
gfc_error ("Type mismatch at %L passing global "
"function %qs declared at %L (%s/%s)",
&actual->where, actual_name,
&gsym->where,
gfc_typename (&global_asym->ts),
gfc_dummy_typename (&formal->ts));
return false;
}
}
else
{
/* The global symbol is a function. Set the formal
argument acordingly. */
formal->attr.function = 1;
formal->ts = global_asym->ts;
}
}
}
}

View file

@ -0,0 +1,15 @@
! { dg-do compile }
! PR fortran/119669 - this used to generate an ICE.
program a
implicit real(a-h,o-z)
external abstract_caller, caller, func
! real func
call abstract_caller (caller, func, 1.5)
call abstract_caller (caller, func, 1.5)
end program a
function func (x)
real func, x
func = x * x - 1.
end