https://gcc.gnu.org/g:e7a2b8b76ae0c8f1e49c780aa82ebb5f0325f515
commit r16-423-ge7a2b8b76ae0c8f1e49c780aa82ebb5f0325f515
Author: Thomas Koenig <tkoe...@gcc.gnu.org>
Date: Tue May 6 18:05:41 2025 +0200
Fix PR 119928, formal arguments used to wrongly inferred for CLASS.
The problem was indeed that generating a formal from an actual
arglist is a bad idea when classes are involved. Fixed in the
attached patch. I think it still makes sense to remove the checks
when the other attributes are present (or PR96073 may come back
in different guise, even if I have to test case at present).
I have also converted the test to a run-time check.
gcc/fortran/ChangeLog:
PR fortran/119928
* interface.cc (gfc_check_dummy_characteristics): Do not issue
error if one dummy symbol has been generated from an actual
argument and the other one has OPTIONAL, INTENT, ALLOCATABLE,
POINTER, TARGET, VALUE, ASYNCHRONOUS or CONTIGUOUS.
(gfc_get_formal_from_actual_arglist): Do nothing if symbol
is a class.
gcc/testsuite/ChangeLog:
PR fortran/119928
* gfortran.dg/interface_60.f90: New test.
Diff:
---
gcc/fortran/interface.cc | 135 ++++++++++++++++-------------
gcc/testsuite/gfortran.dg/interface_60.f90 | 70 +++++++++++++++
2 files changed, 143 insertions(+), 62 deletions(-)
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 1e552a3df861..753f589ff677 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -1403,77 +1403,82 @@ gfc_check_dummy_characteristics (gfc_symbol *s1,
gfc_symbol *s2,
}
}
- /* Check INTENT. */
- if (s1->attr.intent != s2->attr.intent && !s1->attr.artificial
- && !s2->attr.artificial)
- {
- snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* A lot of information is missing for artificially generated
+ formal arguments, let's not look into that. */
- /* Check OPTIONAL attribute. */
- if (s1->attr.optional != s2->attr.optional)
+ if (!s1->attr.artificial && !s2->attr.artificial)
{
- snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* Check INTENT. */
+ if (s1->attr.intent != s2->attr.intent)
+ {
+ snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
- /* Check ALLOCATABLE attribute. */
- if (s1->attr.allocatable != s2->attr.allocatable)
- {
- snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* Check OPTIONAL attribute. */
+ if (s1->attr.optional != s2->attr.optional)
+ {
+ snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
- /* Check POINTER attribute. */
- if (s1->attr.pointer != s2->attr.pointer)
- {
- snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* Check ALLOCATABLE attribute. */
+ if (s1->attr.allocatable != s2->attr.allocatable)
+ {
+ snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
- /* Check TARGET attribute. */
- if (s1->attr.target != s2->attr.target)
- {
- snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* Check POINTER attribute. */
+ if (s1->attr.pointer != s2->attr.pointer)
+ {
+ snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
- /* Check ASYNCHRONOUS attribute. */
- if (s1->attr.asynchronous != s2->attr.asynchronous)
- {
- snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* Check TARGET attribute. */
+ if (s1->attr.target != s2->attr.target)
+ {
+ snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
- /* Check CONTIGUOUS attribute. */
- if (s1->attr.contiguous != s2->attr.contiguous)
- {
- snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* Check ASYNCHRONOUS attribute. */
+ if (s1->attr.asynchronous != s2->attr.asynchronous)
+ {
+ snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
- /* Check VALUE attribute. */
- if (s1->attr.value != s2->attr.value)
- {
- snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* Check CONTIGUOUS attribute. */
+ if (s1->attr.contiguous != s2->attr.contiguous)
+ {
+ snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
- /* Check VOLATILE attribute. */
- if (s1->attr.volatile_ != s2->attr.volatile_)
- {
- snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'",
- s1->name);
- return false;
+ /* Check VALUE attribute. */
+ if (s1->attr.value != s2->attr.value)
+ {
+ snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
+
+ /* Check VOLATILE attribute. */
+ if (s1->attr.volatile_ != s2->attr.volatile_)
+ {
+ snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
}
/* Check interface of dummy procedures. */
@@ -5849,6 +5854,12 @@ gfc_get_formal_from_actual_arglist (gfc_symbol *sym,
char name[GFC_MAX_SYMBOL_LEN + 1];
static int var_num;
+ /* Do not infer the formal from actual arguments if we are dealing with
+ classes. */
+
+ if (sym->ts.type == BT_CLASS)
+ return;
+
f = &sym->formal;
for (a = actual_args; a != NULL; a = a->next)
{
diff --git a/gcc/testsuite/gfortran.dg/interface_60.f90
b/gcc/testsuite/gfortran.dg/interface_60.f90
new file mode 100644
index 000000000000..a7701f602d7a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_60.f90
@@ -0,0 +1,70 @@
+! { dg-do run }
+! { dg-options "-Wexternal-argument-mismatch" }
+! Originally proc_ptr_52.f90, this gave an error with the warning above.
+
+module cs
+
+implicit none
+
+integer, target :: integer_target
+
+abstract interface
+ function classStar_map_ifc(x) result(y)
+ class(*), pointer :: y
+ class(*), target, intent(in) :: x
+ end function classStar_map_ifc
+end interface
+
+contains
+
+ function fun(x) result(y)
+ class(*), pointer :: y
+ class(*), target, intent(in) :: x
+ select type (x)
+ type is (integer)
+ integer_target = x ! Deals with dangling target.
+ y => integer_target
+ class default
+ y => null()
+ end select
+ end function fun
+
+ function apply(fap, x) result(y)
+ procedure(classStar_map_ifc) :: fap
+ integer, intent(in) :: x
+ integer :: y
+ class(*), pointer :: p
+ y = 0 ! Get rid of 'y' undefined warning
+ p => fap (x)
+ select type (p)
+ type is (integer)
+ y = p
+ end select
+ end function apply
+
+ function selector() result(fsel)
+ procedure(classStar_map_ifc), pointer :: fsel
+ fsel => fun
+ end function selector
+
+end module cs
+
+
+program classStar_map
+
+use cs
+implicit none
+
+integer :: x, y
+procedure(classStar_map_ifc), pointer :: fm
+
+x = 123654
+fm => selector () ! Fixed by second chunk in patch
+y = apply (fm, x) ! Fixed by first chunk in patch
+if (x .ne. y) stop 1
+
+x = 2 * x
+y = apply (fun, x) ! PR93925; fixed as above
+if (x .ne. y) stop 2
+
+end program classStar_map
