[PR72741, PR89433] Repeated use of the Fortran OpenACC 'routine' directive

	gcc/fortran/
	PR fortran/72741
	PR fortran/89433
	* openmp.c (gfc_match_oacc_routine): Handle repeated use of the
	Fortran OpenACC 'routine' directive.
	gcc/testsuite/
	PR fortran/72741
	PR fortran/89433
	* gfortran.dg/goacc/routine-multiple-directives-1.f90: New file.
	* gfortran.dg/goacc/routine-multiple-directives-2.f90: Likewise.

Co-Authored-By: Cesar Philippidis <cesar@codesourcery.com>

From-SVN: r269287

5 files changed, 185 insertions, 8 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1c8f712..6adb90a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -2,6 +2,11 @@
 	    Cesar Philippidis  <cesar@codesourcery.com>
 
 	PR fortran/72741
+	PR fortran/89433
+	* openmp.c (gfc_match_oacc_routine): Handle repeated use of the
+	Fortran OpenACC 'routine' directive.
+
+	PR fortran/72741
 	* gfortran.h (enum oacc_routine_lop): Add OACC_ROUTINE_LOP_ERROR.
 	* openmp.c (gfc_oacc_routine_lop, gfc_match_oacc_routine): Use it.
 	* trans-decl.c (add_attributes_to_decl): Likewise.
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 50b91f2..7a06eb5 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -2374,17 +2374,44 @@ 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 add = true;
+
+      /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
+	 match the first one.  */
+      for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
+	   n_p;
+	   n_p = n_p->next)
+	if (n_p->sym == sym)
+	  {
+	    add = false;
+	    if (lop != gfc_oacc_routine_lop (n_p->clauses))
+	      {
+		gfc_error ("!$ACC ROUTINE already applied at %C");
+		goto cleanup;
+	      }
+	  }
+
+      if (add)
+	{
+	  n = gfc_get_oacc_routine_name ();
+	  n->sym = sym;
+	  n->clauses = c;
+	  n->next = gfc_current_ns->oacc_routine_names;
+	  gfc_current_ns->oacc_routine_names = n;
+	}
     }
   else if (gfc_current_ns->proc_name)
     {
+      /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
+	 match the first one.  */
+      oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
+      if (lop_p != OACC_ROUTINE_LOP_NONE
+	  && lop != lop_p)
+	{
+	  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))
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9f4c598..8a36b1f 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -2,6 +2,11 @@
 	    Cesar Philippidis  <cesar@codesourcery.com>
 
 	PR fortran/72741
+	PR fortran/89433
+	* gfortran.dg/goacc/routine-multiple-directives-1.f90: New file.
+	* gfortran.dg/goacc/routine-multiple-directives-2.f90: Likewise.
+
+	PR fortran/72741
 	* gfortran.dg/goacc/routine-multiple-lop-clauses-1.f90: New file.
 
 	PR fortran/72741
diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-multiple-directives-1.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-multiple-directives-1.f90
new file mode 100644
index 0000000..6e12ee9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/routine-multiple-directives-1.f90
@@ -0,0 +1,58 @@
+! Check for valid cases of multiple OpenACC 'routine' directives.
+
+      SUBROUTINE s_1
+!$ACC ROUTINE(s_1)
+!$ACC ROUTINE(s_1) SEQ
+!$ACC ROUTINE SEQ
+      END SUBROUTINE s_1
+
+      SUBROUTINE s_2
+!$ACC ROUTINE
+!$ACC ROUTINE SEQ
+!$ACC ROUTINE(s_2)
+      END SUBROUTINE s_2
+
+      SUBROUTINE v_1
+!$ACC ROUTINE VECTOR
+!$ACC ROUTINE VECTOR
+!$ACC ROUTINE(v_1) VECTOR
+!$ACC ROUTINE VECTOR
+      END SUBROUTINE v_1
+
+      SUBROUTINE v_2
+!$ACC ROUTINE(v_2) VECTOR
+!$ACC ROUTINE VECTOR
+!$ACC ROUTINE(v_2) VECTOR
+      END SUBROUTINE v_2
+
+      SUBROUTINE sub_1
+      IMPLICIT NONE
+      EXTERNAL :: g_1
+!$ACC ROUTINE (g_1) GANG
+!$ACC ROUTINE (g_1) GANG
+!$ACC ROUTINE (g_1) GANG
+
+      CALL s_1
+      CALL s_2
+      CALL v_1
+      CALL v_2
+      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) WORKER
+
+      CONTAINS
+      SUBROUTINE sub_2
+      CALL s_1
+      CALL s_2
+      CALL v_1
+      CALL v_2
+      CALL w_1
+      CALL ABORT
+      END SUBROUTINE sub_2
+      END MODULE m_w_1
diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-multiple-directives-2.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-multiple-directives-2.f90
new file mode 100644
index 0000000..54365ae
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/routine-multiple-directives-2.f90
@@ -0,0 +1,82 @@
+! Check for invalid (and some valid) cases of multiple OpenACC 'routine'
+! directives.
+
+      SUBROUTINE s_1
+!$ACC ROUTINE VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" }
+!$ACC ROUTINE(s_1)
+!$ACC ROUTINE GANG ! { dg-error "\\!\\\$ACC ROUTINE already applied" }
+!$ACC ROUTINE(s_1) SEQ
+!$ACC ROUTINE
+!$ACC ROUTINE(s_1) WORKER ! { dg-error "\\!\\\$ACC ROUTINE already applied" }
+!$ACC ROUTINE GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" }
+      END SUBROUTINE s_1
+
+      SUBROUTINE s_2
+!$ACC ROUTINE(s_2) VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" }
+!$ACC ROUTINE
+!$ACC ROUTINE(s_2) GANG ! { dg-error "\\!\\\$ACC ROUTINE already applied" }
+!$ACC ROUTINE SEQ
+!$ACC ROUTINE(s_2)
+!$ACC ROUTINE WORKER ! { dg-error "\\!\\\$ACC ROUTINE already applied" }
+!$ACC ROUTINE(s_2) GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" }
+      END SUBROUTINE s_2
+
+      SUBROUTINE v_1
+!$ACC ROUTINE VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" }
+!$ACC ROUTINE VECTOR
+!$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(v_1) VECTOR
+!$ACC ROUTINE WORKER ! { dg-error "\\!\\\$ACC ROUTINE already applied" }
+!$ACC ROUTINE GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" }
+      END SUBROUTINE v_1
+
+      SUBROUTINE v_2
+!$ACC ROUTINE(v_2) VECTOR
+!$ACC ROUTINE(v_2) VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" }
+!$ACC ROUTINE(v_2) ! { dg-error "\\!\\\$ACC ROUTINE already applied" }
+!$ACC ROUTINE VECTOR
+!$ACC ROUTINE(v_2) GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" }
+      END SUBROUTINE v_2
+
+      SUBROUTINE sub_1
+      IMPLICIT NONE
+      EXTERNAL :: g_1
+!$ACC ROUTINE (g_1) GANG
+!$ACC ROUTINE (g_1) GANG WORKER ! { dg-error "Multiple loop axes specified for routine" }
+!$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) GANG
+!$ACC ROUTINE (g_1) ! { dg-error "\\!\\\$ACC ROUTINE already applied" }
+
+      CALL s_1
+      CALL s_2
+      CALL v_1
+      CALL v_2
+      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) WORKER SEQ ! { dg-error "Multiple loop axes specified for routine" }
+!$ACC ROUTINE (w_1) ! { dg-error "\\!\\\$ACC ROUTINE already applied" }
+!$ACC ROUTINE (w_1) WORKER
+!$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 s_1
+      CALL s_2
+      CALL v_1
+      CALL v_2
+      CALL w_1
+      CALL ABORT
+      END SUBROUTINE sub_2
+      END MODULE m_w_1