https://gcc.gnu.org/g:30078cb0cc5e19d3de55d218ae500d59a21e7537
commit r15-5767-g30078cb0cc5e19d3de55d218ae500d59a21e7537
Author: Steven G. Kargl <kar...@comcast.net>
Date: Thu Nov 28 13:37:02 2024 -0800
Fortran: Check for impure subroutine.
PR fortran/117765
gcc/fortran/ChangeLog:
* resolve.cc (pure_subroutine): Check for an impure subroutine
call in a BLOCK construct nested within a DO CONCURRENT block.
gcc/testsuite/ChangeLog:
* gfortran.dg/impure_fcn_do_concurrent.f90: Update test to catch
calls to an impure subroutine.
Diff:
---
gcc/fortran/resolve.cc | 18 ++++++++++++++++++
gcc/testsuite/gfortran.dg/impure_fcn_do_concurrent.f90 | 9 ++++++++-
2 files changed, 26 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 304bf208d1a9..f892d809d209 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -3603,9 +3603,27 @@ resolve_function (gfc_expr *expr)
static bool
pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
{
+ code_stack *stack;
+ bool saw_block = false;
+
if (gfc_pure (sym))
return true;
+ /* 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. */
+ for (stack = cs_base; stack; stack = stack->prev)
+ {
+ if (stack->current->op == EXEC_BLOCK) saw_block = true;
+ 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;
+ }
+ }
+
if (forall_flag)
{
gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
diff --git a/gcc/testsuite/gfortran.dg/impure_fcn_do_concurrent.f90
b/gcc/testsuite/gfortran.dg/impure_fcn_do_concurrent.f90
index af524ae83f3c..5846f8c68aab 100644
--- a/gcc/testsuite/gfortran.dg/impure_fcn_do_concurrent.f90
+++ b/gcc/testsuite/gfortran.dg/impure_fcn_do_concurrent.f90
@@ -10,12 +10,14 @@ program foo
do concurrent(i=1:4)
y(i) = bar(i) ! { dg-error "Reference to impure function" }
+ call bla(i) ! { dg-error "Subroutine call to" }
end do
do concurrent(i=1:4)
block
y(i) = bar(i) ! { dg-error "Reference to impure function" }
- end block
+ call bla(i) ! { dg-error "Subroutine call at" }
+ end block
end do
contains
@@ -27,4 +29,9 @@ program foo
bar = j
end function bar
+ impure subroutine bla (i)
+ integer, intent(in) :: i
+ j = j + i
+ end subroutine bla
+
end program foo
