https://gcc.gnu.org/g:f9ea46d946887a05d7ecbca5aeeb99fd868f6e70
commit r16-32-gf9ea46d946887a05d7ecbca5aeeb99fd868f6e70
Author: Steven G. Kargl <ka...@gcc.gnu.org>
Date: Fri Apr 18 18:05:10 2025 -0700
Fortran: Fix checking for IMPURE in DO CONCURRENT.
PR fortran/119836
gcc/fortran/ChangeLog:
* resolve.cc (check_pure_function): Fix checking for
an impure subprogram within a DO CONCURRENT construct.
(pure_subroutine): Ditto.
gcc/testsuite/ChangeLog:
* gfortran.dg/do_concurrent_all_clauses.f90: Remove invalid
dg-error test.
* gfortran.dg/pr119836_1.f90: New test.
* gfortran.dg/pr119836_2.f90: New test.
* gfortran.dg/pr119836_3.f90: New test.
* gfortran.dg/pr119836_4.f90: New test.
Diff:
---
gcc/fortran/resolve.cc | 49 +++++++++++++++++-----
.../gfortran.dg/do_concurrent_all_clauses.f90 | 2 +-
gcc/testsuite/gfortran.dg/pr119836_1.f90 | 18 ++++++++
gcc/testsuite/gfortran.dg/pr119836_2.f90 | 21 ++++++++++
gcc/testsuite/gfortran.dg/pr119836_3.f90 | 30 +++++++++++++
gcc/testsuite/gfortran.dg/pr119836_4.f90 | 30 +++++++++++++
6 files changed, 139 insertions(+), 11 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 2ecbd50fa699..f03708efef78 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -3260,14 +3260,30 @@ static bool check_pure_function (gfc_expr *e)
gfc_do_concurrent_flag = 0 when the check for an impure function
occurs. Check the stack to see if the source code has a nested
BLOCK construct. */
+
for (stack = cs_base; stack; stack = stack->prev)
{
- if (stack->current->op == EXEC_BLOCK) saw_block = true;
+ if (!saw_block && stack->current->op == EXEC_BLOCK)
+ {
+ saw_block = true;
+ continue;
+ }
+
if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
{
- gfc_error ("Reference to impure function at %L inside a "
- "DO CONCURRENT", &e->where);
- return false;
+ bool is_pure;
+ is_pure = (e->value.function.isym
+ && (e->value.function.isym->pure
+ || e->value.function.isym->elemental))
+ || (e->value.function.esym
+ && (e->value.function.esym->attr.pure
+ || e->value.function.esym->attr.elemental));
+ if (!is_pure)
+ {
+ gfc_error ("Reference to impure function at %L inside a "
+ "DO CONCURRENT", &e->where);
+ return false;
+ }
}
}
@@ -3663,16 +3679,29 @@ pure_subroutine (gfc_symbol *sym, const char *name,
locus *loc)
/* A BLOCK construct within a DO CONCURRENT construct leads to
gfc_do_concurrent_flag = 0 when the check for an impure subroutine
- occurs. Check the stack to see if the source code has a nested
- BLOCK construct. */
+ occurs. Walk up the stack to see if the source code has a nested
+ construct. */
+
for (stack = cs_base; stack; stack = stack->prev)
{
- if (stack->current->op == EXEC_BLOCK) saw_block = true;
+ if (stack->current->op == EXEC_BLOCK)
+ {
+ saw_block = true;
+ continue;
+ }
+
if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
{
- gfc_error ("Subroutine call at %L in a DO CONCURRENT block "
- "is not PURE", loc);
- return false;
+
+ bool is_pure = true;
+ is_pure = sym->attr.pure || sym->attr.elemental;
+
+ if (!is_pure)
+ {
+ gfc_error ("Subroutine call at %L in a DO CONCURRENT block "
+ "is not PURE", loc);
+ return false;
+ }
}
}
diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90
b/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90
index 0c8a6adcabd7..a7fa7c31e413 100644
--- a/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90
@@ -18,7 +18,7 @@ program do_concurrent_all_clauses
squared = i * i
arr(i) = temp2 + squared
sum = sum + arr(i)
- max_val = max(max_val, arr(i)) ! { dg-error "Reference to impure
function" }
+ max_val = max(max_val, arr(i))
end block
end do
print *, arr, sum, max_val
diff --git a/gcc/testsuite/gfortran.dg/pr119836_1.f90
b/gcc/testsuite/gfortran.dg/pr119836_1.f90
new file mode 100644
index 000000000000..984e2d0a73c0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr119836_1.f90
@@ -0,0 +1,18 @@
+!
+! { dg-do run }
+!
+! PR fortran/119836
+!
+program p
+ implicit none
+ integer, parameter :: n = 4
+ integer :: i
+ integer :: y(n), x(n)
+ do concurrent (i=1:n)
+ x(i) = shiftl (i,1) ! accepted
+ block
+ y(i) = shiftl (i,1) ! wrongly rejected
+ end block
+ end do
+ if (any(x /= y)) stop 1
+end program p
diff --git a/gcc/testsuite/gfortran.dg/pr119836_2.f90
b/gcc/testsuite/gfortran.dg/pr119836_2.f90
new file mode 100644
index 000000000000..5e2d0c9392e0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr119836_2.f90
@@ -0,0 +1,21 @@
+!
+! { dg-do compile }
+!
+! PR fortran/119836
+!
+! Although intrinsic functions contained within the Fortran standard
+! are pure procedures, many of the additional intrinsic functions
+! supplied in libgfortran are impure. RAND() is one such function.
+!
+program foo
+ implicit none
+ integer i
+ real x(4)
+ do concurrent (i=1:4)
+ x = rand() ! { dg-error "Reference to impure function" }
+ block
+ x = rand() ! { dg-error "Reference to impure function" }
+ end block
+ end do
+ print *, x
+end program foo
diff --git a/gcc/testsuite/gfortran.dg/pr119836_3.f90
b/gcc/testsuite/gfortran.dg/pr119836_3.f90
new file mode 100644
index 000000000000..69a5fcf7d602
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr119836_3.f90
@@ -0,0 +1,30 @@
+!
+! { dg-do run }
+!
+! PR fortran/119836
+!
+program p
+ implicit none
+ integer, parameter :: n = 4
+ integer :: i
+ integer :: y(n), x(n)
+ x = [(i,i=1,n)]
+ do concurrent (i=1:n)
+ call bar(x, y)
+ end do
+ if (any(x /= y)) stop 1
+ x = 2 * x
+ do concurrent (i=1:n)
+ block
+ call bar(x, y)
+ end block
+ end do
+ if (any(x /= y)) stop 1
+
+ contains
+ elemental subroutine bar(x, y)
+ integer, intent(in) :: x
+ integer, intent(out) :: y
+ y = x
+ end subroutine
+end program p
diff --git a/gcc/testsuite/gfortran.dg/pr119836_4.f90
b/gcc/testsuite/gfortran.dg/pr119836_4.f90
new file mode 100644
index 000000000000..dc6f72b2c99a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr119836_4.f90
@@ -0,0 +1,30 @@
+!
+! { dg-do compile }
+!
+! PR fortran/119836
+!
+program p
+ implicit none
+ integer, parameter :: n = 4
+ integer :: i
+ integer :: y(n), x(n)
+ x = [(i,i=1,n)]
+ do concurrent (i=1:n)
+ call bar(x, y) ! { dg-error "Subroutine call" }
+ end do
+ if (any(x /= y)) stop 1
+ x = 2 * x
+ do concurrent (i=1:n)
+ block
+ call bar(x, y) ! { dg-error "Subroutine call" }
+ end block
+ end do
+ if (any(x /= y)) stop 1
+
+ contains
+ subroutine bar(x, y)
+ integer, intent(in) :: x(:)
+ integer, intent(out) :: y(:)
+ y = x
+ end subroutine
+end program p
