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 --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 2ecbd50fa69915fbc9109dfa35b661d195245f85..f03708efef78f0a15f4a1564c4b0f193a09c8f88 100644 (file)
--- 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 0c8a6adcabd701cffd251b10feba2b655cb37b8e..a7fa7c31e413faa5e45573d43a815729cb66a5e2 100644 (file)
--- 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 (file)
index 0000000..984e2d0
--- /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 (file)
index 0000000..5e2d0c9
--- /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 (file)
index 0000000..69a5fcf
--- /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 (file)
index 0000000..dc6f72b
--- /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