https://gcc.gnu.org/g:625b805544101ae90fbe789a5eeba44cd14e89fb
commit r16-434-g625b805544101ae90fbe789a5eeba44cd14e89fb
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Wed May 7 08:52:52 2025 +0100
Fortran: Source allocation of pure module function rejected [PR119948]
2025-05-07 Paul Thomas <pa...@gcc.gnu.org>
and Steven G. Kargl <ka...@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.
Diff:
---
gcc/fortran/primary.cc | 2 +-
gcc/testsuite/gfortran.dg/pr119948.f90 | 51 ++++++++++++++++++++++++++++------
2 files changed, 43 insertions(+), 10 deletions(-)
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 72ecc7ccf934..ec4e13548c4c 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 9ecb08095613..2e36fae5a9de 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
