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

Fortran: fix issue with impure elemental subroutine and interface [PR119656]

Browse source 
PR fortran/119656

gcc/fortran/ChangeLog:

	* interface.cc (gfc_compare_actual_formal): Fix front-end memleak
	when searching for matching interfaces.
	* trans-expr.cc (gfc_conv_procedure_call): If there is a formal
	dummy corresponding to an absent argument, use its type, and only
	fall back to inferred type otherwise.

gcc/testsuite/ChangeLog:

	* gfortran.dg/optional_absent_13.f90: New test.
This commit is contained in:
Harald Anlauf 2025-04-08 22:30:15 +02:00
parent 4645d09296
commit 334545194d
3 changed files with 65 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
gcc/fortran/interface.cc
View file

@ -3382,7 +3382,11 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
return false;
}
else
a->associated_dummy = get_nonintrinsic_dummy_arg (f);
{
if (a->associated_dummy)
free (a->associated_dummy);
a->associated_dummy = get_nonintrinsic_dummy_arg (f);
}
if (a->expr == NULL)
{

18
gcc/fortran/trans-expr.cc
View file

@ -6925,10 +6925,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
/* Pass a NULL pointer for an absent arg. */
parmse.expr = null_pointer_node;
/* Is it an absent character dummy? */
bool absent_char = false;
gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
if (dummy_arg
&& gfc_dummy_arg_get_typespec (*dummy_arg).type
== BT_CHARACTER)
/* Fall back to inferred type only if no formal. */
if (fsym)
absent_char = (fsym->ts.type == BT_CHARACTER);
else if (dummy_arg)
absent_char = (gfc_dummy_arg_get_typespec (*dummy_arg).type
== BT_CHARACTER);
if (absent_char)
parmse.string_length = build_int_cst (gfc_charlen_type_node,
0);
}
@ -6954,9 +6962,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
|| !CLASS_DATA (fsym)->attr.allocatable));
gfc_init_se (&parmse, NULL);
parmse.expr = null_pointer_node;
if (arg->associated_dummy
&& gfc_dummy_arg_get_typespec (*arg->associated_dummy).type
== BT_CHARACTER)
if (fsym->ts.type == BT_CHARACTER)
parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
}
else if (fsym && fsym->ts.type == BT_CLASS

48
gcc/testsuite/gfortran.dg/optional_absent_13.f90 Normal file
View file

@ -0,0 +1,48 @@
! { dg-do run }
! PR fortran/119656 - wrong code with impure elemental subroutine and interface
!
! Derived from testcase at:
! https://fortran-lang.discourse.group/t/
! problem-with-impure-elemental-subroutine-in-interface-with-gfortran/9545
module m2
implicit none
interface foo
module procedure foo_mat
module procedure foo_df
module procedure foo_cmat
end interface foo
contains
subroutine foo_mat(x, nacf, label)
real, intent(in) :: x(:,:)
integer, intent(in) :: nacf
character(len=*), intent(in), optional :: label
end subroutine foo_mat
impure elemental subroutine foo_df(nacf, outu, xstr)
integer , intent(in) :: nacf
integer , intent(in), optional :: outu
character(len=*), intent(in), optional :: xstr
if (present(xstr)) then
if (len (xstr) /= 2) then
print *,"nacf, len(xstr) =", nacf, len(xstr)
stop nacf
end if
end if
end subroutine foo_df
subroutine foo_cmat(x, nacf, label)
complex, intent(in) :: x(:,:)
integer, intent(in) :: nacf
character(len=*), intent(in), optional :: label
end subroutine foo_cmat
end module m2
program main
use m2, only: foo, foo_df
implicit none
call foo_df(nacf = 1, xstr="ab")
call foo (nacf = 2, xstr="ab")
end program main