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

2025-05-07  Paul Thomas  <pault@gcc.gnu.org>
	    and Steven G. Kargl  <kargl@gcc.gnu.org>

gcc/fortran
	PR fortran/119948
	* 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: Update to incorporate failing test,
	where module procedure is the result. Test submodule cases.

2 files changed, 43 insertions, 10 deletions

diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 72ecc7c..ec4e135 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -4396,7 +4396,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/testsuite/gfortran.dg/pr119948.f90 b/gcc/testsuite/gfortran.dg/pr119948.f90
index 9ecb080..2e36fae 100644
--- a/gcc/testsuite/gfortran.dg/pr119948.f90
+++ b/gcc/testsuite/gfortran.dg/pr119948.f90
@@ -1,7 +1,8 @@
-! { dg-do compile }
+! { dg-do run }
 !
-! Test the fix for PR119948, which used to fail as indicated below with,
-! "Error: Bad allocate-object at (1) for a PURE procedure"
+! 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>
 !
@@ -18,33 +19,65 @@ module test_m
       type(test_t) :: test
       type(test_t), intent(in) :: arg
     end function
-    pure module function construct_test_sub(arg) result(test)
+
+    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) ! Used to fail here
+    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_sub
+  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 = 42
+!
+  dummy%i = int (rand () * 1e6)
   res = construct_test (dummy)
   if (res%i /= dummy%i) stop 1
-  dummy%i = -42
-  res = construct_test_sub (dummy)
+!
+  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