https://gcc.gnu.org/g:0abc77da9d704bba55a376bb5c162a54826ab94a
commit r16-329-g0abc77da9d704bba55a376bb5c162a54826ab94a
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Thu May 1 15:22:54 2025 +0100
Fortran: Source allocation of pure function result rejected [PR119948]
2025-05-01 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran
PR fortran/119948
* resolve.cc (gfc_impure_variable): The result of a module
procedure with an interface declaration is not impure even if
the current namespace is not the same as the symbol's.
gcc/testsuite/
PR fortran/119948
* gfortran.dg/pr119948.f90: New test.
Diff:
---
gcc/fortran/resolve.cc | 10 +++++++
gcc/testsuite/gfortran.dg/pr119948.f90 | 50 ++++++++++++++++++++++++++++++++++
2 files changed, 60 insertions(+)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index e51f83b6618b..1e62e94788b1 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -18549,6 +18549,16 @@ gfc_impure_variable (gfc_symbol *sym)
if (sym->attr.use_assoc || sym->attr.in_common)
return 1;
+ /* The namespace of a module procedure interface holds the arguments and
+ symbols, and so the symbol namespace can be different to that of the
+ procedure. */
+ if (sym->ns != gfc_current_ns
+ && gfc_current_ns->proc_name->abr_modproc_decl
+ && sym->ns->proc_name->attr.function
+ && sym->attr.result
+ && !strcmp (sym->ns->proc_name->name, gfc_current_ns->proc_name->name))
+ return 0;
+
/* Check if the symbol's ns is inside the pure procedure. */
for (ns = gfc_current_ns; ns; ns = ns->parent)
{
diff --git a/gcc/testsuite/gfortran.dg/pr119948.f90
b/gcc/testsuite/gfortran.dg/pr119948.f90
new file mode 100644
index 000000000000..9ecb08095613
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr119948.f90
@@ -0,0 +1,50 @@
+! { dg-do compile }
+!
+! Test the fix for PR119948, which used to fail as indicated below with,
+! "Error: Bad allocate-object at (1) for a PURE procedure"
+!
+! Contributed by Damian Rouson <damian@archaeologic.codes>
+!
+module test_m
+ implicit none
+
+ type test_t
+ integer, allocatable :: i
+ end type
+
+ interface
+ pure module function construct_test(arg) result(test)
+ implicit none
+ type(test_t) :: test
+ type(test_t), intent(in) :: arg
+ end function
+ pure module function construct_test_sub(arg) result(test)
+ implicit none
+ type(test_t) :: test
+ type(test_t), intent(in) :: arg
+ end function
+ end interface
+
+contains
+ module procedure construct_test
+ allocate(test%i, source = arg%i) ! Used to fail here
+ end procedure
+end module
+
+submodule (test_m)test_s
+contains
+ module procedure construct_test_sub
+ allocate(test%i, source = arg%i) ! This was OK.
+ end procedure
+end submodule
+
+ use test_m
+ type(test_t) :: res, dummy
+ dummy%i = 42
+ res = construct_test (dummy)
+ if (res%i /= dummy%i) stop 1
+ dummy%i = -42
+ res = construct_test_sub (dummy)
+ if (res%i /= dummy%i) stop 2
+ deallocate (res%i, dummy%i)
+end
