From: Paul Thomas <pault@gcc.gnu.org>
Date: Thu, 1 May 2025 14:22:54 +0000 (+0100)
Subject: Fortran: Source allocation of pure function result rejected [PR119948]
X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=0abc77da9d704bba55a376bb5c162a54826ab94a;p=thirdparty%2Fgcc.git

Fortran: Source allocation of pure function result rejected [PR119948]

2025-05-01  Paul Thomas  <pault@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 --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index e51f83b6618..1e62e94788b 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 00000000000..9ecb0809561
--- /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