[PATCH] Fix PR125481 Wrong generic resolution between procedure pointer and variable actuals of same TKR

From 6192456e6c6d3ff41bd27e041ef2f140eba9827a Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Tue, 26 May 2026 12:00:33 -0700
Subject: [PATCH] fortran: fix wrong generic resolution when actual argument is
 a procedure pointer

When a generic interface has two specific procedures -- one with a
procedure-pointer dummy and one with a data-object (e.g. REAL) dummy --
gfortran incorrectly resolved calls where the actual argument was a
procedure pointer to the data-object specific, resulting in the pointer
address being interpreted as a numeric value (wrong code).

The root cause was a missing check in gfc_compare_actual_formal: the
two existing checks guard the case where the formal is a proc_pointer
or FL_PROCEDURE but the actual is not; however the reverse direction
(actual is a proc_pointer but formal is a plain data object) was not
checked.  F18:15.5.2.4 forbids this pairing.

Assisted by: Claude Sonnet 4.6

	PR fortran/125481

gcc/fortran/ChangeLog:

	* interface.cc (gfc_compare_actual_formal): Add missing check that
	rejects a procedure-pointer actual argument corresponding to a
	data-object dummy argument (F18:15.5.2.4).  Restrict to
	EXPR_VARIABLE to avoid false positives on calls through procedure
	pointer components.

gcc/testsuite/ChangeLog:

	* gfortran.dg/generic_37.f90: New test.
---
 gcc/fortran/interface.cc                 | 18 ++++++
 gcc/testsuite/gfortran.dg/generic_37.f90 | 70 ++++++++++++++++++++++++
 2 files changed, 88 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/generic_37.f90

diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 8ab2fade283..71e21343b66 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -3806,6 +3806,24 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  goto match;
 	}
 
+      /* F18:15.5.2.4: A procedure pointer actual argument cannot correspond
+	 to a data-object dummy argument (reverse of the two checks above).
+	 Only flag EXPR_VARIABLE to avoid false positives on function calls
+	 through procedure pointer components (e.g. o%f(args)).  */
+      if (!f->sym->attr.proc_pointer
+	  && f->sym->attr.flavor != FL_PROCEDURE
+	  && a->expr->expr_type == EXPR_VARIABLE
+	  && (a->expr->symtree->n.sym->attr.proc_pointer
+	      || gfc_is_proc_ptr_comp (a->expr)))
+	{
+	  if (where)
+	    gfc_error ("Procedure pointer actual argument at %L cannot "
+		       "be passed to data-object dummy argument %qs",
+		       &a->expr->where, f->sym->name);
+	  ok = false;
+	  goto match;
+	}
+
       /* Class array variables and expressions store array info in a
 	 different place from non-class objects; consolidate the logic
 	 to access it here instead of repeating it below.  Note that
diff --git a/gcc/testsuite/gfortran.dg/generic_37.f90 b/gcc/testsuite/gfortran.dg/generic_37.f90
new file mode 100644
index 00000000000..5aef23b6583
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/generic_37.f90
@@ -0,0 +1,70 @@
+! { dg-do run }
+!
+! PR fortran/125481
+!
+! Wrong generic resolution when actual argument is a procedure pointer and
+! the generic has two specific procedures -- one with a procedure-pointer
+! dummy argument and one with a REAL(8) dummy argument.  gfortran was
+! selecting the REAL(8) specific (F18:15.5.2.4 violation).
+
+module m
+  implicit none
+
+  abstract interface
+    pure function init_i (x) result (y)
+      real (8), intent (in) :: x(:)
+      real (8), allocatable :: y(:)
+    end function
+  end interface
+
+  type :: t
+    real (8), allocatable :: vals(:)
+  end type
+
+  interface make_t
+    module procedure make_t_from_func   ! first dummy: procedure pointer
+    module procedure make_t_constant    ! first dummy: real(8)
+  end interface
+
+contains
+
+  function make_t_from_func (f, n) result (r)
+    procedure (init_i), pointer :: f
+    integer, intent (in) :: n
+    type (t) :: r
+    integer :: i
+    r%vals = f ([(real (i, 8), i = 1, n)])
+  end function
+
+  function make_t_constant (c, n) result (r)
+    real (8), intent (in) :: c
+    integer, intent (in) :: n
+    type (t) :: r
+    integer :: i
+    r%vals = [(c, i = 1, n)]
+  end function
+
+  pure function identity (x) result (y)
+    real (8), intent (in) :: x(:)
+    real (8), allocatable :: y(:)
+    y = x
+  end function
+
+end module m
+
+program test
+  use m
+  implicit none
+  procedure (init_i), pointer :: f => identity
+  type (t) :: x
+  integer :: i
+
+  x = make_t (f, 4)
+  do i = 1, 4
+    if (abs (x%vals(i) - real (i, 8)) > epsilon (x%vals(i))) STOP 1
+  end do
+
+  x = make_t (42.0d0, 4)
+  if (any (abs (x%vals - 42.0d0) > epsilon (x%vals(1)))) stop 2
+
+end program test
-- 
2.54.0