[PR fortran/72741] Check clauses with intrinsic function specified in !$ACC ROUTINE ( NAME )

2018-XX-YY  Cesar Philippidis  <cesar@codesourcery.com>

	gcc/fortran/
	* openmp.c (gfc_match_oacc_routine): Check clauses of intrinsic
	functions.

	gcc/testsuite/
	* gfortran.dg/goacc/fixed-1.f: Update test.
	* gfortran.dg/goacc/pr72741-2.f: New test.
	* gfortran.dg/goacc/pr72741-intrinsic-1.f: New test.
	* gfortran.dg/goacc/pr72741-intrinsic-2.f: New test.
	* gfortran.dg/goacc/pr72741.f90: Update test.

	libgomp/
	* testsuite/libgomp.oacc-fortran/abort-1.f90: Update test.
	* testsuite/libgomp.oacc-fortran/acc_on_device-1-2.f: Update test.

(cherry picked from gomp-4_0-branch r239422)
(cherry picked from gomp-4_0-branch r239515, and r247954)
---
 gcc/fortran/openmp.c                          | 41 +++++++++++++++----
 gcc/testsuite/gfortran.dg/goacc/fixed-1.f     |  2 +
 gcc/testsuite/gfortran.dg/goacc/pr72741-2.f   | 39 ++++++++++++++++++
 .../gfortran.dg/goacc/pr72741-intrinsic-1.f   | 16 ++++++++
 .../gfortran.dg/goacc/pr72741-intrinsic-2.f   | 22 ++++++++++
 gcc/testsuite/gfortran.dg/goacc/pr72741.f90   | 20 +++++++--
 .../libgomp.oacc-fortran/abort-1.f90          |  1 +
 .../libgomp.oacc-fortran/acc_on_device-1-2.f  |  1 +
 8 files changed, 130 insertions(+), 12 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/goacc/pr72741-2.f
 create mode 100644 gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-1.f
 create mode 100644 gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-2.f

diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 60ecaf54523..58cbe0ae90c 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -2288,8 +2288,9 @@ match
 gfc_match_oacc_routine (void)
 {
   locus old_loc;
-  gfc_symbol *sym = NULL;
   match m;
+  gfc_intrinsic_sym *isym = NULL;
+  gfc_symbol *sym = NULL;
   gfc_omp_clauses *c = NULL;
   gfc_oacc_routine_name *n = NULL;
   oacc_function dims;
@@ -2311,12 +2312,14 @@ gfc_match_oacc_routine (void)
   if (m == MATCH_YES)
     {
       char buffer[GFC_MAX_SYMBOL_LEN + 1];
-      gfc_symtree *st;
+      gfc_symtree *st = NULL;
 
       m = gfc_match_name (buffer);
       if (m == MATCH_YES)
 	{
-	  st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
+	  if ((isym = gfc_find_function (buffer)) == NULL
+	      && (isym = gfc_find_subroutine (buffer)) == NULL)
+	    st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
 	  if (st)
 	    {
 	      sym = st->n.sym;
@@ -2325,7 +2328,7 @@ gfc_match_oacc_routine (void)
 	        sym = NULL;
 	    }
 
-	  if (st == NULL
+	  if ((isym == NULL && st == NULL)
 	      || (sym
 		  && !sym->attr.external
 		  && !sym->attr.function
@@ -2337,6 +2340,13 @@ gfc_match_oacc_routine (void)
 	      gfc_current_locus = old_loc;
 	      return MATCH_ERROR;
 	    }
+
+	  /* Set sym to NULL if it matches the current procedure's
+	     name.  This will simplify the check for duplicate ACC
+	     ROUTINE attributes.  */
+	  if (gfc_current_ns->proc_name
+	      && !strcmp (buffer, gfc_current_ns->proc_name->name))
+	    sym = NULL;
 	}
       else
         {
@@ -2357,15 +2367,30 @@ gfc_match_oacc_routine (void)
 	  != MATCH_YES))
     return MATCH_ERROR;
 
+  /* Scan for invalid routine geometry.  */
   dims = gfc_oacc_routine_dims (c);
   if (dims == OACC_FUNCTION_NONE)
     {
-      gfc_error ("Multiple loop axes specified for routine %C");
-      gfc_current_locus = old_loc;
-      return MATCH_ERROR;
+      gfc_error ("Multiple loop axes specified in !$ACC ROUTINE at %C");
+
+      /* Don't abort early, because it's important to let the user
+	 know of any potential duplicate routine directives.  */
+      seen_error = true;
     }
 
-  if (sym != NULL)
+  if (isym != NULL)
+    {
+      if (c && (c->gang || c->worker || c->vector))
+	{
+	  gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME ) "
+		     "at %C, with incompatible clauses specifying the level "
+		     "of parallelism");
+	  goto cleanup;
+	}
+      /* The intrinsic symbol has been marked with a SEQ, or with no clause at
+	 all, which is OK.  */
+    }
+  else if (sym != NULL)
     {
       bool needs_entry = true;
 
diff --git a/gcc/testsuite/gfortran.dg/goacc/fixed-1.f b/gcc/testsuite/gfortran.dg/goacc/fixed-1.f
index 974f2702260..3a900c5b4e6 100644
--- a/gcc/testsuite/gfortran.dg/goacc/fixed-1.f
+++ b/gcc/testsuite/gfortran.dg/goacc/fixed-1.f
@@ -1,3 +1,5 @@
+!$ACC ROUTINE(ABORT) SEQ
+
       INTEGER :: ARGC
       ARGC = COMMAND_ARGUMENT_COUNT ()
 
diff --git a/gcc/testsuite/gfortran.dg/goacc/pr72741-2.f b/gcc/testsuite/gfortran.dg/goacc/pr72741-2.f
new file mode 100644
index 00000000000..58651440d20
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/pr72741-2.f
@@ -0,0 +1,39 @@
+      SUBROUTINE v_1
+!$ACC ROUTINE
+!$ACC ROUTINE ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE GANG ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE SEQ ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE WORKER ! { dg-error "ACC ROUTINE already applied" }
+      END SUBROUTINE v_1
+
+      SUBROUTINE sub_1
+      IMPLICIT NONE
+      EXTERNAL :: g_1
+!$ACC ROUTINE (g_1) GANG
+!$ACC ROUTINE (g_1) VECTOR ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE (g_1) SEQ ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE (g_1) ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE (g_1) ! { dg-error "ACC ROUTINE already applied" }
+
+      CALL v_1
+      CALL g_1
+      CALL ABORT
+      END SUBROUTINE sub_1
+
+      MODULE m_w_1
+      IMPLICIT NONE
+      EXTERNAL :: w_1
+!$ACC ROUTINE (w_1) WORKER
+!$ACC ROUTINE (w_1) ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE (w_1) SEQ ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE (w_1) ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE (w_1) VECTOR ! { dg-error "ACC ROUTINE already applied" }
+
+      CONTAINS
+      SUBROUTINE sub_2
+      CALL v_1
+      CALL w_1
+      CALL ABORT
+      END SUBROUTINE sub_2
+      END MODULE m_w_1
diff --git a/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-1.f b/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-1.f
new file mode 100644
index 00000000000..d84cdf9d0a8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-1.f
@@ -0,0 +1,16 @@
+      SUBROUTINE sub_1
+      IMPLICIT NONE
+!$ACC ROUTINE (ABORT) SEQ VECTOR ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
+
+      CALL ABORT
+      END SUBROUTINE sub_1
+
+      MODULE m_w_1
+      IMPLICIT NONE
+!$ACC ROUTINE (ABORT) VECTOR GANG ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
+
+      CONTAINS
+      SUBROUTINE sub_2
+      CALL ABORT
+      END SUBROUTINE sub_2
+      END MODULE m_w_1
diff --git a/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-2.f b/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-2.f
new file mode 100644
index 00000000000..e5e3794d1c5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-2.f
@@ -0,0 +1,22 @@
+! Check for invalid clauses with intrinsic function specified in !$ACC ROUTINE ( NAME ).
+
+      SUBROUTINE sub_1
+      IMPLICIT NONE
+!$ACC ROUTINE (ABORT) WORKER ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
+!$ACC ROUTINE (ABORT) GANG ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
+!$ACC ROUTINE (ABORT) VECTOR ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
+
+      CALL ABORT
+      END SUBROUTINE sub_1
+
+      MODULE m_w_1
+      IMPLICIT NONE
+!$ACC ROUTINE (ABORT) VECTOR ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
+!$ACC ROUTINE (ABORT) WORKER ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
+!$ACC ROUTINE (ABORT) GANG ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
+
+      CONTAINS
+      SUBROUTINE sub_2
+      CALL ABORT
+      END SUBROUTINE sub_2
+      END MODULE m_w_1
diff --git a/gcc/testsuite/gfortran.dg/goacc/pr72741.f90 b/gcc/testsuite/gfortran.dg/goacc/pr72741.f90
index b295a4fcc59..3fbd94f6f7d 100644
--- a/gcc/testsuite/gfortran.dg/goacc/pr72741.f90
+++ b/gcc/testsuite/gfortran.dg/goacc/pr72741.f90
@@ -1,13 +1,24 @@
 SUBROUTINE v_1
   !$ACC ROUTINE VECTOR WORKER ! { dg-error "Multiple loop axes" }
+  !$ACC ROUTINE VECTOR ! { dg-error "ACC ROUTINE already applied" }
+  !$ACC ROUTINE ! { dg-error "ACC ROUTINE already applied" }
+  !$ACC ROUTINE GANG VECTOR ! { dg-error "Multiple loop axes" }
 END SUBROUTINE v_1
 
+SUBROUTINE v_2
+  !$ACC ROUTINE(v_2) VECTOR WORKER ! { dg-error "Multiple loop axes" }
+  !$ACC ROUTINE(v_2) VECTOR ! { dg-error "ACC ROUTINE already applied" }
+  !$ACC ROUTINE(v_2) ! { dg-error "ACC ROUTINE already applied" }
+  !$ACC ROUTINE(v_2) GANG VECTOR ! { dg-error "Multiple loop axes" }
+END SUBROUTINE v_2
+
 SUBROUTINE sub_1
   IMPLICIT NONE
   EXTERNAL :: g_1
   !$ACC ROUTINE (g_1) GANG WORKER ! { dg-error "Multiple loop axes" }
-  !$ACC ROUTINE (ABORT) SEQ VECTOR ! { dg-error "Multiple loop axes" "" { xfail *-*-* } }
-! { dg-bogus "invalid function name abort" "" { xfail *-*-* } .-1 }
+  !$ACC ROUTINE (g_1) GANG ! { dg-error "ACC ROUTINE already applied" }
+  !$ACC ROUTINE (g_1) ! { dg-error "ACC ROUTINE already applied" }
+  !$ACC ROUTINE (g_1) VECTOR GANG ! { dg-error "Multiple loop axes" }
 
   CALL v_1
   CALL g_1
@@ -18,8 +29,9 @@ MODULE m_w_1
   IMPLICIT NONE
   EXTERNAL :: w_1
   !$ACC ROUTINE (w_1) WORKER SEQ ! { dg-error "Multiple loop axes" }
-  !$ACC ROUTINE (ABORT) VECTOR GANG ! { dg-error "Multiple loop axes" "" { xfail *-*-* } }
-! { dg-bogus "invalid function name abort" "" { xfail *-*-* } .-1 }
+  !$ACC ROUTINE (w_1) WORKER ! { dg-error "ACC ROUTINE already applied" }
+  !$ACC ROUTINE (w_1) ! { dg-error "ACC ROUTINE already applied" }
+  !$ACC ROUTINE (w_1) VECTOR WORKER ! { dg-error "Multiple loop axes" }
 
 CONTAINS
   SUBROUTINE sub_2
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/abort-1.f90 b/libgomp/testsuite/libgomp.oacc-fortran/abort-1.f90
index fc0af7ff7d8..cfe505ecb76 100644
--- a/libgomp/testsuite/libgomp.oacc-fortran/abort-1.f90
+++ b/libgomp/testsuite/libgomp.oacc-fortran/abort-1.f90
@@ -3,6 +3,7 @@
 
 program main
   implicit none
+  !$acc routine(abort) seq
 
   print *, "CheCKpOInT"
   !$acc parallel
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/acc_on_device-1-2.f b/libgomp/testsuite/libgomp.oacc-fortran/acc_on_device-1-2.f
index 75e24509ce9..d81ff1bd9ab 100644
--- a/libgomp/testsuite/libgomp.oacc-fortran/acc_on_device-1-2.f
+++ b/libgomp/testsuite/libgomp.oacc-fortran/acc_on_device-1-2.f
@@ -6,6 +6,7 @@
 
       USE OPENACC
       IMPLICIT NONE
+!$ACC ROUTINE(ABORT) SEQ
 
 !Host.
 
-- 
2.17.1