https://gcc.gnu.org/g:4e3060ee17e6eb8bab718d320199f713533dbbd6
commit r15-9528-g4e3060ee17e6eb8bab718d320199f713533dbbd6
Author: Harald Anlauf <anl...@gmx.de>
Date: Tue Apr 15 20:43:05 2025 +0200
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.
Diff:
---
gcc/fortran/resolve.cc | 7 ++++
gcc/testsuite/gfortran.dg/pure_formal_proc_4.f90 | 49 ++++++++++++++++++++++++
2 files changed, 56 insertions(+)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index cdf043b64115..2ecbd50fa699 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 000000000000..92640e2d2f4a
--- /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
