[patch, fortran] PR117765 Impure function within a BLOCK construct within a DO CONCURRENT

[Jerry D]

I would like to commit the attached patch for Steve.

Regression tested on x86-64-linux-gnu.

OK for trunk?

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 too
            see if there in a nested BLOCK and, if that block is in
            a DO_CONCURRENT, issue an error.

    gcc/testsuite/ChangeLog:

            * gfortran.dg/impure_fcn_do_concurrent.f90: New test.

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index b8c908b51e9..1b98be205b4 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -3228,6 +3228,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 00000000000..07b5a37f978
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/impure_fcn_do_concurrent.f90
@@ -0,0 +1,31 @@
+!
+! { 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