OpenACC/Fortran: permit 'routine' inside PURE

gcc/fortran/ChangeLog

	* parse.c (decode_oacc_directive): Permit 'acc routine' also
	inside pure procedures.
	* openmp.c (gfc_match_oacc_routine): Inside pure procedures
	do not permit gang, worker or vector clauses.

libgomp/ChangeLog:

	* testsuite/libgomp.oacc-fortran/routine-10.f90: New test.

gcc/testsuite/ChangeLog:

	* gfortran.dg/goacc/pure-elemental-procedures-2.f90: New test.

Reviewed-by: Thomas Schwinge <thomas@codesourcery.com>

gcc/fortran/openmp.c

@@ -2525,6 +2525,14 @@ gfc_match_oacc_routine (void)
     /* Something has gone wrong, possibly a syntax error.  */
     goto cleanup;
 
+  if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
+    {
+      gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
+		 "permitted in PURE procedure at %C");
+      goto cleanup;
+    }
+
+
   if (n)
     n->clauses = c;
   else if (gfc_current_ns->oacc_routine)

gcc/fortran/parse.c

@@ -639,20 +639,10 @@ decode_oacc_directive (void)
 
   gfc_matching_function = false;
 
-  if (gfc_pure (NULL))
-    {
-      gfc_error_now ("OpenACC directives at %C may not appear in PURE "
-		     "procedures");
-      gfc_error_recovery ();
-      return ST_NONE;
-    }
-
   if (gfc_current_state () == COMP_FUNCTION
       && gfc_current_block ()->result->ts.kind == -1)
     spec_only = true;
 
-  gfc_unset_implicit_pure (NULL);
-
   old_locus = gfc_current_locus;
 
   /* General OpenACC directive matching: Instead of testing every possible
@@ -661,6 +651,21 @@ decode_oacc_directive (void)
 
   c = gfc_peek_ascii_char ();
 
+  switch (c)
+    {
+    case 'r':
+      matcha ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE);
+      break;
+    }
+
+  gfc_unset_implicit_pure (NULL);
+  if (gfc_pure (NULL))
+    {
+      gfc_error_now ("OpenACC directives other than ROUTINE may not appear in PURE "
+		     "procedures at %C");
+      goto error_handling;
+    }
+
   switch (c)
     {
     case 'a':
@@ -705,9 +710,6 @@ decode_oacc_directive (void)
     case 'l':
       matcha ("loop", gfc_match_oacc_loop, ST_OACC_LOOP);
       break;
-    case 'r':
-      match ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE);
-      break;
     case 's':
       matcha ("serial loop", gfc_match_oacc_serial_loop, ST_OACC_SERIAL_LOOP);
       matcha ("serial", gfc_match_oacc_serial, ST_OACC_SERIAL);

gcc/testsuite/gfortran.dg/goacc/pure-elemental-procedures-2.f90

@@ -0,0 +1,27 @@
+pure elemental subroutine foo()
+!$acc routine vector  ! { dg-error "ROUTINE with GANG, WORKER, or VECTOR clause is not permitted in PURE procedure" }
+end
+
+elemental subroutine foo2()
+!$acc routine (myfoo2) gang  ! { dg-error "Invalid NAME 'myfoo2' in" }
+end
+
+elemental subroutine foo2a()
+!$acc routine gang  ! { dg-error "ROUTINE with GANG, WORKER, or VECTOR clause is not permitted in PURE procedure" }
+end
+
+pure subroutine foo3()
+!$acc routine vector ! { dg-error "ROUTINE with GANG, WORKER, or VECTOR clause is not permitted in PURE procedure" }
+end
+
+elemental impure subroutine foo4()
+!$acc routine vector ! OK: impure
+end
+
+pure subroutine foo5()
+!$acc routine seq ! OK: seq
+end
+
+pure subroutine foo6()
+!$acc routine ! OK (implied 'seq')
+end

libgomp/testsuite/libgomp.oacc-fortran/routine-10.f90

@@ -0,0 +1,52 @@
+! { dg-do run }
+!
+module m
+  implicit none
+contains
+  pure subroutine add_ps_routine(a, b, c)
+    implicit none
+    !$acc routine seq
+    integer, intent(in)  :: a, b
+    integer, intent(out) :: c
+    integer, parameter :: n = 10
+    integer :: i
+
+    do i = 1, n
+       if (i .eq. 5) then
+          c = a + b
+       end if
+    end do
+  end subroutine add_ps_routine
+
+  elemental impure function add_ef(a, b) result(c)
+    implicit none
+    !$acc routine
+    integer, intent(in)  :: a, b
+    integer :: c
+
+    call add_ps_routine(a, b, c)
+  end function add_ef
+end module m
+
+program main
+  use m
+  implicit none
+  integer, parameter :: n = 10
+  integer, dimension(n) :: a_a
+  integer, dimension(n) :: b_a
+  integer, dimension(n) :: c_a
+  integer :: i
+
+  a_a = [(3 * i, i = 1, n)]
+  b_a = [(-2 * i, i = 1, n)]
+  !$acc parallel copyin(a_a, b_a) copyout(c_a)
+  !$acc loop gang
+  do i = 1, n
+     if (i .eq. 4) then
+        c_a = add_ef(a_a, b_a)
+     end if
+  end do
+  !$acc end parallel
+  if (any (c_a /= [(i, i=1, 10)])) stop 1
+  !print *, a
+end program main