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 --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 304bf208d1a91c5857f1f02d0d61d9f3b473a696..f892d809d209318512ae56b185521844f2c83395 100644 (file)
--- 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 af524ae83f3cceb86fd2bbd36ea8ab25875915f0..5846f8c68aab48468c6bda751d60814e6974a5e3 100644 (file)
--- 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