https://gcc.gnu.org/g:8422524f6f43263caca2c2ab8a0e890e92f5f114
commit r15-9861-g8422524f6f43263caca2c2ab8a0e890e92f5f114
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-07 Paul Thomas <pa...@gcc.gnu.org>
and Steven G. Kargl <ka...@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.
* primary.cc (match_variable): Module procedures with sym the
same as result can be treated as variables, although marked
external.
gcc/testsuite/
PR fortran/119948
* gfortran.dg/pr119948.f90: New test.
(cherry picked from commit 0abc77da9d704bba55a376bb5c162a54826ab94a)
Diff:
---
gcc/fortran/primary.cc | 2 +-
gcc/fortran/resolve.cc | 10 ++++
gcc/testsuite/gfortran.dg/pr119948.f90 | 83 ++++++++++++++++++++++++++++++++++
3 files changed, 94 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index b5dddde5481b..f0e1fef6812e 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -4448,7 +4448,7 @@ match_variable (gfc_expr **result, int equiv_flag, int
host_flag)
case FL_PROCEDURE:
/* Check for a nonrecursive function result variable. */
if (sym->attr.function
- && !sym->attr.external
+ && (!sym->attr.external || sym->abr_modproc_decl)
&& sym->result == sym
&& (gfc_is_function_return_value (sym, gfc_current_ns)
|| (sym->attr.entry
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index c5c10205dadf..ee5b22a728d4 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -18478,6 +18478,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..2e36fae5a9de
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr119948.f90
@@ -0,0 +1,83 @@
+! { dg-do run }
+!
+! Test the fix for PR119948, which used to fail as indicated below with:
+! (1) "Error: Bad allocate-object at (1) for a PURE procedure"
+! (2) "Error: ‘construct_test2 at (1) is not a variable"
+!
+! 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_test2(arg)
+ implicit none
+ type(test_t) construct_test2
+ type(test_t), intent(in) :: arg
+ end function
+
+ pure module function construct_test_3(arg) result(test)
+ implicit none
+ type(test_t) :: test
+ type(test_t), intent(in) :: arg
+ end function
+
+ pure module function construct_test_4(arg)
+ implicit none
+ type(test_t) :: construct_test_4
+ type(test_t), intent(in) :: arg
+ end function
+ end interface
+
+contains
+ module procedure construct_test
+ allocate(test%i, source = arg%i) ! Fail #1
+ end procedure
+
+ module procedure construct_test2
+ allocate(construct_test2%i, source = arg%i) ! Fail #2
+ end procedure
+end module
+
+submodule (test_m)test_s
+contains
+ module procedure construct_test_3
+ allocate(test%i, source = arg%i) ! This was OK.
+ end procedure
+
+ module procedure construct_test_4
+ allocate(construct_test_4%i, source = arg%i) ! This was OK.
+ end procedure
+end submodule
+
+ use test_m
+ type(test_t) :: res, dummy
+!
+ dummy%i = int (rand () * 1e6)
+ res = construct_test (dummy)
+ if (res%i /= dummy%i) stop 1
+!
+ dummy%i = int (rand () * 1e6)
+ res = construct_test2 (dummy)
+ if (res%i /= dummy%i) stop 2
+!
+ dummy%i = int (rand () * 1e6)
+ res = construct_test_3 (dummy)
+ if (res%i /= dummy%i) stop 3
+
+ dummy%i = int (rand () * 1e6)
+ res = construct_test_4 (dummy)
+ if (res%i /= dummy%i) stop 4
+
+ deallocate (res%i, dummy%i)
+end
