]> git.ipfire.org Git - thirdparty/gcc.git/commitdiff
Fortran: pure subroutine with pure procedure as dummy [PR106948]
authorHarald Anlauf <anlauf@gmx.de>
Tue, 15 Apr 2025 18:43:05 +0000 (20:43 +0200)
committerHarald Anlauf <anlauf@gmx.de>
Wed, 16 Apr 2025 17:05:59 +0000 (19:05 +0200)
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
gcc/testsuite/gfortran.dg/pure_formal_proc_4.f90 [new file with mode: 0644]

index cdf043b64115772d646a093929f83a4ba2870bd7..2ecbd50fa69915fbc9109dfa35b661d195245f85 100644 (file)
@@ -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 (file)
index 0000000..92640e2
--- /dev/null
@@ -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