Hello world,
This patch fixes a case where too much was being checked with
-Wexternal-arguments-mismatch with a procedure pointer with an
unlimited polymorphic and an INTEGER argument which was inferred from
an actual argument.I also found some checks which can trigger false
positives, which this patch also excludes from testing.
Regression-tested.
OK for trunk and backport to gcc-15?
Best regards
Thomas
gcc/fortran/ChangeLog:
PR fortran/119928
* interface.cc (gfc_check_dummy_characteristics): Do not issue
error for type if one argument is an unlimited polymorphic entity
and the other one has been generated from an actual argument.
Do not check OPTIONAL, INTENT, ALLOCATABLE, POINTER, TARGET, VALUE,
ASYNCHRONOUS or CONTIGUOUS if one of the arguments has been
generated from an actual argument.
gcc/testsuite/ChangeLog:
PR fortran/119928
* gfortran.dg/interface_60.f90: New test.
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 1e552a3df86..af955fd2ff9 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -1387,8 +1387,10 @@ gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
/* Check type and rank. */
if (type_must_agree)
{
- if (!compare_type_characteristics (s1, s2)
- || !compare_type_characteristics (s2, s1))
+ if ((!compare_type_characteristics (s1, s2)
+ || !compare_type_characteristics (s2, s1))
+ && !((s1->attr.artificial && UNLIMITED_POLY(s2))
+ || (s2->attr.artificial && UNLIMITED_POLY(s1))))
{
snprintf (errmsg, err_len, "Type mismatch in argument '%s' (%s/%s)",
s1->name, gfc_dummy_typename (&s1->ts),
@@ -1403,77 +1405,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. */
diff --git a/gcc/testsuite/gfortran.dg/interface_60.f90 b/gcc/testsuite/gfortran.dg/interface_60.f90
new file mode 100644
index 00000000000..9cceb3f8e19
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_60.f90
@@ -0,0 +1,70 @@
+! { dg-do compile }
+! { 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
