https://gcc.gnu.org/g:7d92901c878c6c00ada7f9cee8825f03ad4722f1
commit r15-5654-g7d92901c878c6c00ada7f9cee8825f03ad4722f1
Author: Steve Kargl <kar...@comcast.net>
Date: Sun Nov 24 18:26:03 2024 -0800
Fortran: Check IMPURE in BLOCK inside DO CONCURRENT.
PR fortran/117765
gcc/fortran/ChangeLog:
* resolve.cc (check_pure_function): Check the stack to
see if the function is in a nested BLOCK and, if that
block is inside a DO_CONCURRENT, issue an error.
gcc/testsuite/ChangeLog:
* gfortran.dg/impure_fcn_do_concurrent.f90: New test.
Diff:
---
gcc/fortran/resolve.cc | 18 +++++++++++++
.../gfortran.dg/impure_fcn_do_concurrent.f90 | 30 ++++++++++++++++++++++
2 files changed, 48 insertions(+)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index b1740cec3881..0d3845f9ce35 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -3227,6 +3227,24 @@ pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
static bool check_pure_function (gfc_expr *e)
{
const char *name = NULL;
+ code_stack *stack;
+ bool saw_block = false;
+
+ /* A BLOCK construct within a DO CONCURRENT construct leads to
+ 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_DO_CONCURRENT)
+ {
+ gfc_error ("Reference to impure function at %L inside a "
+ "DO CONCURRENT", &e->where);
+ return false;
+ }
+ }
+
if (!gfc_pure_function (e, &name) && name)
{
if (forall_flag)
diff --git a/gcc/testsuite/gfortran.dg/impure_fcn_do_concurrent.f90
b/gcc/testsuite/gfortran.dg/impure_fcn_do_concurrent.f90
new file mode 100644
index 000000000000..af524ae83f3c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/impure_fcn_do_concurrent.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+!
+program foo
+
+ implicit none
+
+ integer i
+ integer :: j = 0
+ real y(4)
+
+ do concurrent(i=1:4)
+ y(i) = bar(i) ! { dg-error "Reference to impure function" }
+ end do
+
+ do concurrent(i=1:4)
+ block
+ y(i) = bar(i) ! { dg-error "Reference to impure function" }
+ end block
+ end do
+
+ contains
+
+ impure function bar(i)
+ real bar
+ integer, intent(in) :: i
+ j = j + i
+ bar = j
+ end function bar
+
+end program foo
