Hi all,
the attached patch fixes a rather strange 12/13/14/15 regression.
When walking through the list of procedures in an interface to
find the matching one, the code could remember an inferred type
from a false module procedure within the same interface if and
only if optional arguments were in the procedure declarations,
and the procedure call did not provide an actual argument for
an optional one. An inferred type could then leak into
gfc_conv_procedure_call and pretend a wrong type for the dummy.
(This bug appears to be related to a code refactoring during
12-development and is not present in 11-releases.)
The simple and obvious solution is to use the type of the formal,
as inferred types are only relevant when there is no explicit
interface.
Regtested on x86_64-pc-linux-gnu. OK for mainline?
As this is a regression, I would like to backport this as
appropriate.
Thanks,
Harald
From 468ca59fd29ad629198dc2ada0d73e7898588edc Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Tue, 8 Apr 2025 22:30:15 +0200
Subject: [PATCH] Fortran: fix issue with impure elemental subroutine and
interface [PR119656]
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.
---
gcc/fortran/interface.cc | 6 ++-
gcc/fortran/trans-expr.cc | 18 ++++---
.../gfortran.dg/optional_absent_13.f90 | 48 +++++++++++++++++++
3 files changed, 65 insertions(+), 7 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/optional_absent_13.f90
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 6258a41cb59..c702239d64d 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -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)
{
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 4b90b06fa0a..28c20d89f23 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6931,10 +6931,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);
}
@@ -6960,9 +6968,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
diff --git a/gcc/testsuite/gfortran.dg/optional_absent_13.f90 b/gcc/testsuite/gfortran.dg/optional_absent_13.f90
new file mode 100644
index 00000000000..9c2039bfb3f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_absent_13.f90
@@ -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
--
2.43.0
