2016-08-15  Cesar Philippidis  <cesar@codesourcery.com>

	gcc/fortran/
	* openmp.c (gfc_match_oacc_routine): Error on repeated ACC ROUTINE
	directives.  Consider the optional NAME argument being the current
	procedure name.
	* trans-decl.c (add_attributes_to_decl): Use build_oacc_routine_dims
	to construct the oacc_function attribute arguments.

	gcc/testsuite/
	* gfortran.dg/goacc/pr72741-2.f: New test.
	* gfortran.dg/goacc/pr72741-intrinsic-1.f: Add test coverage.
	* gfortran.dg/goacc/pr72741-intrinsic-2.f: Likewise.
	* gfortran.dg/goacc/pr72741.f90: Likewise.


diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 80f46c0..cb8efb8 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -1877,8 +1877,9 @@ gfc_match_oacc_cache (void)
   return MATCH_YES;
 }
 
-/* Determine the loop level for a routine.  Returns OACC_FUNCTION_NONE if
-   any error is detected.  */
+/* Determine the loop level for a routine.  Returns OACC_FUNCTION_NONE
+   if any error is detected.  Note that this function needs to be
+   called repeatedly for each DEVICE_TYPE.  */
 
 static oacc_function
 gfc_oacc_routine_dims (gfc_omp_clauses *clauses)
@@ -1925,6 +1926,7 @@ gfc_match_oacc_routine (void)
   gfc_omp_clauses *c = NULL;
   gfc_oacc_routine_name *n = NULL;
   oacc_function dims = OACC_FUNCTION_NONE;
+  bool seen_error = false;
 
   old_loc = gfc_current_locus;
 
@@ -1969,6 +1971,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
         {
@@ -1993,19 +2002,24 @@ 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 in !$ACC ROUTINE at %C");
-      goto cleanup;
+
+      /* Don't abort early, because it's important to let the user
+	 know of any potential duplicate routine directives.  */
+      seen_error = true;
     }
 
   if (isym != NULL)
     {
       if (c && (c->gang || c->worker || c->vector))
 	{
-	  gfc_error ("Intrinsic function specified in !$ACC ROUTINE ( NAME )"
-		     " at %C, with incompatible GANG, WORKER, or VECTOR clause");
+	  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
@@ -2013,24 +2027,59 @@ gfc_match_oacc_routine (void)
     }
   else if (sym != NULL)
     {
-      n = gfc_get_oacc_routine_name ();
-      n->sym = sym;
-      n->clauses = NULL;
-      n->next = NULL;
-      if (gfc_current_ns->oacc_routine_names != NULL)
-	n->next = gfc_current_ns->oacc_routine_names;
-
-      gfc_current_ns->oacc_routine_names = n;
+      bool needs_entry = true;
+      
+      /* Scan for any repeated routine directives on 'sym' and report
+	 an error if necessary.  TODO: Extend this function to scan
+	 for compatible DEVICE_TYPE dims.  */
+      for (n = gfc_current_ns->oacc_routine_names; n; n = n->next)
+	if (n->sym == sym)
+	  {
+	    needs_entry = false;
+	    if (dims != gfc_oacc_routine_dims (n->clauses))
+	      {
+		gfc_error ("$!ACC ROUTINE already applied at %C");
+		goto cleanup;
+	      }
+	  }
+
+      if (needs_entry)
+	{
+	  n = gfc_get_oacc_routine_name ();
+	  n->sym = sym;
+	  n->clauses = c;
+	  n->next = NULL;
+
+	  if (gfc_current_ns->oacc_routine_names != NULL)
+	    n->next = gfc_current_ns->oacc_routine_names;
+
+	  gfc_current_ns->oacc_routine_names = n;
+	}
+
+      if (seen_error)
+	goto cleanup;
     }
   else if (gfc_current_ns->proc_name)
     {
+      if (gfc_current_ns->proc_name->attr.oacc_function != OACC_FUNCTION_NONE
+	  && !seen_error)
+	{
+	  gfc_error ("!$ACC ROUTINE already applied at %C");
+	  goto cleanup;
+	}
+
       if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
 				       gfc_current_ns->proc_name->name,
 				       &old_loc))
 	goto cleanup;
-      gfc_current_ns->proc_name->attr.oacc_function = dims;
+
+      gfc_current_ns->proc_name->attr.oacc_function
+	= seen_error ? OACC_FUNCTION_SEQ : dims;
       gfc_current_ns->proc_name->attr.oacc_function_nohost
 	= c ? c->nohost : false;
+
+      if (seen_error)
+	goto cleanup;
     }
   else
     gcc_unreachable ();
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 5271268..785212f 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -45,6 +45,7 @@ along with GCC; see the file COPYING3.  If not see
 /* Only for gfc_trans_code.  Shouldn't need to include this.  */
 #include "trans-stmt.h"
 #include "gomp-constants.h"
+#include "omp-low.h"
 
 #define MAX_LABEL_VALUE 99999
 
@@ -1329,29 +1330,27 @@ add_attributes_to_decl (symbol_attribute sym_attr, tree list)
 
   if (sym_attr.oacc_function != OACC_FUNCTION_NONE)
     {
-      tree dims = NULL_TREE;
-      int ix;
-      int level = GOMP_DIM_MAX;
-
+      omp_clause_code code = OMP_CLAUSE_ERROR;
+      tree clause, dims;
+      
       switch (sym_attr.oacc_function)
 	{
 	case OACC_FUNCTION_GANG:
-	  level = GOMP_DIM_GANG;
+	  code = OMP_CLAUSE_GANG;
 	  break;
 	case OACC_FUNCTION_WORKER:
-	  level = GOMP_DIM_WORKER;
+	  code = OMP_CLAUSE_WORKER;
 	  break;
 	case OACC_FUNCTION_VECTOR:
-	  level = GOMP_DIM_VECTOR;
+	  code = OMP_CLAUSE_VECTOR;
 	  break;
 	case OACC_FUNCTION_SEQ:
-	default:;
+	default:
+	  code = OMP_CLAUSE_SEQ;
 	}
 
-      for (ix = GOMP_DIM_MAX; ix--;)
-	dims = tree_cons (build_int_cst (boolean_type_node, ix >= level),
-			  integer_zero_node, dims);
-
+      clause = build_omp_clause (UNKNOWN_LOCATION, code);
+      dims = build_oacc_routine_dims (clause);
       list = tree_cons (get_identifier ("oacc function"),
 			dims, list);
     }
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 0000000..5865144
--- /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
index 4bff3e3..d84cdf9 100644
--- a/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-1.f
+++ b/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-1.f
@@ -1,17 +1,13 @@
-! Check for valid clauses with intrinsic function specified in !$ACC ROUTINE ( NAME ).
-
       SUBROUTINE sub_1
       IMPLICIT NONE
-!$ACC ROUTINE (ABORT)
-!$ACC ROUTINE (ABORT) SEQ
+!$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) SEQ
-!$ACC ROUTINE (ABORT)
+!$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
diff --git a/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-2.f b/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-2.f
index fed8e76..e5e3794 100644
--- a/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-2.f
+++ b/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-2.f
@@ -2,18 +2,18 @@
 
       SUBROUTINE sub_1
       IMPLICIT NONE
-!$ACC ROUTINE (ABORT) WORKER ! { dg-error "Intrinsic function specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible GANG, WORKER, or VECTOR clause" }
-!$ACC ROUTINE (ABORT) GANG ! { dg-error "Intrinsic function specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible GANG, WORKER, or VECTOR clause" }
-!$ACC ROUTINE (ABORT) VECTOR ! { dg-error "Intrinsic function specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible GANG, WORKER, or VECTOR clause" }
+!$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 function specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible GANG, WORKER, or VECTOR clause" }
-!$ACC ROUTINE (ABORT) WORKER ! { dg-error "Intrinsic function specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible GANG, WORKER, or VECTOR clause" }
-!$ACC ROUTINE (ABORT) GANG ! { dg-error "Intrinsic function specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible GANG, WORKER, or VECTOR clause" }
+!$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
diff --git a/gcc/testsuite/gfortran.dg/goacc/pr72741.f90 b/gcc/testsuite/gfortran.dg/goacc/pr72741.f90
index cf89727..3fbd94f 100644
--- a/gcc/testsuite/gfortran.dg/goacc/pr72741.f90
+++ b/gcc/testsuite/gfortran.dg/goacc/pr72741.f90
@@ -1,12 +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" }
+  !$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
@@ -17,7 +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" }
+  !$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