From 4e3060ee17e6eb8bab718d320199f713533dbbd6 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Tue, 15 Apr 2025 20:43:05 +0200
Subject: [PATCH] Fortran: pure subroutine with pure procedure as dummy
 [PR106948]

	PR fortran/106948

gcc/fortran/ChangeLog:

	* resolve.cc (gfc_pure_function): If a function has been resolved,
	but esym is not yet set, look at its attributes to see whether it
	is pure or elemental.

gcc/testsuite/ChangeLog:

	* gfortran.dg/pure_formal_proc_4.f90: New test.
---
 gcc/fortran/resolve.cc                        |  7 +++
 .../gfortran.dg/pure_formal_proc_4.f90        | 49 +++++++++++++++++++
 2 files changed, 56 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/pure_formal_proc_4.f90

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index cdf043b6411..2ecbd50fa69 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -3190,6 +3190,13 @@ gfc_pure_function (gfc_expr *e, const char **name)
 	     || e->value.function.isym->elemental;
       *name = e->value.function.isym->name;
     }
+  else if (e->symtree && e->symtree->n.sym && e->symtree->n.sym->attr.dummy)
+    {
+      /* The function has been resolved, but esym is not yet set.
+	 This can happen with functions as dummy argument.  */
+      pure = e->symtree->n.sym->attr.pure;
+      *name = e->symtree->n.sym->name;
+    }
   else
     {
       /* Implicit functions are not pure.  */
diff --git a/gcc/testsuite/gfortran.dg/pure_formal_proc_4.f90 b/gcc/testsuite/gfortran.dg/pure_formal_proc_4.f90
new file mode 100644
index 00000000000..92640e2d2f4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pure_formal_proc_4.f90
@@ -0,0 +1,49 @@
+! { dg-do compile }
+! PR fortran/106948 - check that passing of PURE procedures works
+!
+! Contributed by Jim Feng
+
+module a
+  implicit none
+
+  interface new
+    pure module subroutine b(x, f)
+      integer, intent(inout) :: x
+      interface
+        pure function f(x) result(r)
+          real, intent(in) :: x
+          real :: r
+        end function f
+      end interface
+    end subroutine b
+  end interface new
+end module a
+
+submodule(a) a_b
+  implicit none
+
+contains
+  module procedure b
+    x = int(f(real(x)) * 0.15)
+  end procedure b
+end submodule a_b
+
+program test
+  use a
+  implicit none
+
+  integer :: x
+
+  x = 100
+  call new(x, g)
+  print *, x
+
+contains
+
+  pure function g(y) result(r)
+    real, intent(in) :: y
+    real :: r
+
+    r = sqrt(y)
+  end function g
+end program test