[WIP] [PR fortran/72741] Rework Fortran OpenACC routine clause handlingtschwinge/omp/pr72741-wip

9 files changed, 500 insertions, 225 deletions

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index c70f51f9b6f..5f194216d76 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -303,15 +303,6 @@ enum save_state
 { SAVE_NONE = 0, SAVE_EXPLICIT, SAVE_IMPLICIT
 };
 
-/* Flags to keep track of ACC routine states.  */
-enum oacc_function
-{ OACC_FUNCTION_NONE = 0,
-  OACC_FUNCTION_SEQ,
-  OACC_FUNCTION_GANG,
-  OACC_FUNCTION_WORKER,
-  OACC_FUNCTION_VECTOR
-};
-
 /* Strings for all symbol attributes.  We use these for dumping the
    parse tree, in error messages, and also when reading and writing
    modules.  In symbol.c.  */
@@ -321,7 +312,6 @@ extern const mstring intents[];
 extern const mstring access_types[];
 extern const mstring ifsrc_types[];
 extern const mstring save_status[];
-extern const mstring oacc_function_types[];
 
 /* Enumeration of all the generic intrinsic functions.  Used by the
    backend for identification of a function.  */
@@ -705,6 +695,126 @@ CInteropKind_t;
 extern CInteropKind_t c_interop_kinds_table[];
 
 
+/* We need to store source lines as sequences of multibyte source
+   characters. We define here a type wide enough to hold any multibyte
+   source character, just like libcpp does.  A 32-bit type is enough.  */
+
+#if HOST_BITS_PER_INT >= 32
+typedef unsigned int gfc_char_t;
+#elif HOST_BITS_PER_LONG >= 32
+typedef unsigned long gfc_char_t;
+#elif defined(HAVE_LONG_LONG) && (HOST_BITS_PER_LONGLONG >= 32)
+typedef unsigned long long gfc_char_t;
+#else
+# error "Cannot find an integer type with at least 32 bits"
+#endif
+
+
+/* The following three structures are used to identify a location in
+   the sources.
+
+   gfc_file is used to maintain a tree of the source files and how
+   they include each other
+
+   gfc_linebuf holds a single line of source code and information
+   which file it resides in
+
+   locus point to the sourceline and the character in the source
+   line.
+*/
+
+typedef struct gfc_file
+{
+  struct gfc_file *next, *up;
+  int inclusion_line, line;
+  char *filename;
+} gfc_file;
+
+typedef struct gfc_linebuf
+{
+  source_location location;
+  struct gfc_file *file;
+  struct gfc_linebuf *next;
+
+  int truncated;
+  bool dbg_emitted;
+
+  gfc_char_t line[1];
+} gfc_linebuf;
+
+#define gfc_linebuf_header_size (offsetof (gfc_linebuf, line))
+
+#define gfc_linebuf_linenum(LBUF) (LOCATION_LINE ((LBUF)->location))
+
+typedef struct
+{
+  gfc_char_t *nextc;
+  gfc_linebuf *lb;
+} locus;
+
+/* In order for the "gfc" format checking to work correctly, you must
+   have declared a typedef locus first.  */
+#if GCC_VERSION >= 4001
+#define ATTRIBUTE_GCC_GFC(m, n) __attribute__ ((__format__ (__gcc_gfc__, m, n))) ATTRIBUTE_NONNULL(m)
+#else
+#define ATTRIBUTE_GCC_GFC(m, n) ATTRIBUTE_NONNULL(m)
+#endif
+
+
+/* Suppress error messages or re-enable them.  */
+
+void gfc_push_suppress_errors (void);
+void gfc_pop_suppress_errors (void);
+
+
+/* Character length structures hold the expression that gives the
+   length of a character variable.  We avoid putting these into
+   gfc_typespec because doing so prevents us from doing structure
+   copies and forces us to deallocate any typespecs we create, as well
+   as structures that contain typespecs.  They also can have multiple
+   character typespecs pointing to them.
+
+   These structures form a singly linked list within the current
+   namespace and are deallocated with the namespace.  It is possible to
+   end up with gfc_charlen structures that have nothing pointing to them.  */
+
+typedef struct gfc_charlen
+{
+  struct gfc_expr *length;
+  struct gfc_charlen *next;
+  bool length_from_typespec; /* Length from explicit array ctor typespec?  */
+  tree backend_decl;
+  tree passed_length; /* Length argument explicitly passed.  */
+
+  int resolved;
+}
+gfc_charlen;
+
+#define gfc_get_charlen() XCNEW (gfc_charlen)
+
+/* Type specification structure.  */
+typedef struct
+{
+  bt type;
+  int kind;
+
+  union
+  {
+    struct gfc_symbol *derived;	/* For derived types only.  */
+    gfc_charlen *cl;		/* For character types only.  */
+    int pad;			/* For hollerith types only.  */
+  }
+  u;
+
+  struct gfc_symbol *interface;	/* For PROCEDURE declarations.  */
+  int is_c_interop;
+  int is_iso_c;
+  bt f90_type;
+  bool deferred;
+}
+gfc_typespec;
+
+
 /* Structure and list of supported extension attributes.  */
 typedef enum
 {
@@ -729,7 +839,7 @@ ext_attr_t;
 extern const ext_attr_t ext_attr_list[];
 
 /* Symbol attribute structure.  */
-typedef struct
+typedef struct symbol_attribute
 {
   /* Variable attributes.  */
   unsigned allocatable:1, dimension:1, codimension:1, external:1, intrinsic:1,
@@ -864,6 +974,13 @@ typedef struct
   /* Mentioned in OMP DECLARE TARGET.  */
   unsigned omp_declare_target:1;
 
+  /* OpenACC routine.  */
+  unsigned oacc_routine:1;
+  unsigned oacc_routine_gang:1;
+  unsigned oacc_routine_worker:1;
+  unsigned oacc_routine_vector:1;
+  unsigned oacc_routine_seq:1;
+
   /* Mentioned in OACC DECLARE.  */
   unsigned oacc_declare_create:1;
   unsigned oacc_declare_copyin:1;
@@ -871,136 +988,23 @@ typedef struct
   unsigned oacc_declare_device_resident:1;
   unsigned oacc_declare_link:1;
 
-  /* This is an OpenACC acclerator function at level N - 1  */
-  ENUM_BITFIELD (oacc_function) oacc_function:3;
-
   /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES).  */
   unsigned ext_attr:EXT_ATTR_NUM;
 
+  /* Location information for OMP clauses.  */
+  //TODO: how to handle in module.c/symbol.c?
+  locus omp_clauses_locus;
+
   /* The namespace where the attribute has been set.  */
   struct gfc_namespace *volatile_ns, *asynchronous_ns;
-}
-symbol_attribute;
-
-
-/* We need to store source lines as sequences of multibyte source
-   characters. We define here a type wide enough to hold any multibyte
-   source character, just like libcpp does.  A 32-bit type is enough.  */
-
-#if HOST_BITS_PER_INT >= 32
-typedef unsigned int gfc_char_t;
-#elif HOST_BITS_PER_LONG >= 32
-typedef unsigned long gfc_char_t;
-#elif defined(HAVE_LONG_LONG) && (HOST_BITS_PER_LONGLONG >= 32)
-typedef unsigned long long gfc_char_t;
-#else
-# error "Cannot find an integer type with at least 32 bits"
-#endif
-
-
-/* The following three structures are used to identify a location in
-   the sources.
-
-   gfc_file is used to maintain a tree of the source files and how
-   they include each other
-
-   gfc_linebuf holds a single line of source code and information
-   which file it resides in
-
-   locus point to the sourceline and the character in the source
-   line.
-*/
-
-typedef struct gfc_file
-{
-  struct gfc_file *next, *up;
-  int inclusion_line, line;
-  char *filename;
-} gfc_file;
-
-typedef struct gfc_linebuf
-{
-  source_location location;
-  struct gfc_file *file;
-  struct gfc_linebuf *next;
 
-  int truncated;
-  bool dbg_emitted;
-
-  gfc_char_t line[1];
-} gfc_linebuf;
-
-#define gfc_linebuf_header_size (offsetof (gfc_linebuf, line))
-
-#define gfc_linebuf_linenum(LBUF) (LOCATION_LINE ((LBUF)->location))
-
-typedef struct
-{
-  gfc_char_t *nextc;
-  gfc_linebuf *lb;
-} locus;
-
-/* In order for the "gfc" format checking to work correctly, you must
-   have declared a typedef locus first.  */
-#if GCC_VERSION >= 4001
-#define ATTRIBUTE_GCC_GFC(m, n) __attribute__ ((__format__ (__gcc_gfc__, m, n))) ATTRIBUTE_NONNULL(m)
-#else
-#define ATTRIBUTE_GCC_GFC(m, n) ATTRIBUTE_NONNULL(m)
-#endif
-
-
-/* Suppress error messages or re-enable them.  */
-
-void gfc_push_suppress_errors (void);
-void gfc_pop_suppress_errors (void);
-
-
-/* Character length structures hold the expression that gives the
-   length of a character variable.  We avoid putting these into
-   gfc_typespec because doing so prevents us from doing structure
-   copies and forces us to deallocate any typespecs we create, as well
-   as structures that contain typespecs.  They also can have multiple
-   character typespecs pointing to them.
-
-   These structures form a singly linked list within the current
-   namespace and are deallocated with the namespace.  It is possible to
-   end up with gfc_charlen structures that have nothing pointing to them.  */
-
-typedef struct gfc_charlen
-{
-  struct gfc_expr *length;
-  struct gfc_charlen *next;
-  bool length_from_typespec; /* Length from explicit array ctor typespec?  */
-  tree backend_decl;
-  tree passed_length; /* Length argument explicitly passed.  */
-
-  int resolved;
+  /* Chain to another set of symbol attributes.  Currently only used for
+     OpenACC routine.  */
+  //TODO: how to handle in module.c/symbol.c?
+  struct symbol_attribute *next;
 }
-gfc_charlen;
-
-#define gfc_get_charlen() XCNEW (gfc_charlen)
-
-/* Type specification structure.  */
-typedef struct
-{
-  bt type;
-  int kind;
-
-  union
-  {
-    struct gfc_symbol *derived;	/* For derived types only.  */
-    gfc_charlen *cl;		/* For character types only.  */
-    int pad;			/* For hollerith types only.  */
-  }
-  u;
+symbol_attribute;
 
-  struct gfc_symbol *interface;	/* For PROCEDURE declarations.  */
-  int is_c_interop;
-  int is_iso_c;
-  bt f90_type;
-  bool deferred;
-}
-gfc_typespec;
 
 /* Array specification.  */
 typedef struct
@@ -2816,6 +2820,11 @@ bool gfc_add_result (symbol_attribute *, const char *, locus *);
 bool gfc_add_save (symbol_attribute *, save_state, const char *, locus *);
 bool gfc_add_threadprivate (symbol_attribute *, const char *, locus *);
 bool gfc_add_omp_declare_target (symbol_attribute *, const char *, locus *);
+bool gfc_add_oacc_routine (symbol_attribute *, const char *, locus *);
+bool gfc_add_oacc_routine_gang (symbol_attribute *, const char *, locus *);
+bool gfc_add_oacc_routine_worker (symbol_attribute *, const char *, locus *);
+bool gfc_add_oacc_routine_vector (symbol_attribute *, const char *, locus *);
+bool gfc_add_oacc_routine_seq (symbol_attribute *, const char *, locus *);
 bool gfc_add_saved_common (symbol_attribute *, locus *);
 bool gfc_add_target (symbol_attribute *, locus *);
 bool gfc_add_dummy (symbol_attribute *, const char *, locus *);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 267858f2c24..4b590c6c1c4 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1986,6 +1986,7 @@ enum ab_attribute
   AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
   AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
   AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET,
+  AB_OACC_ROUTINE, AB_OACC_ROUTINE_GANG, AB_OACC_ROUTINE_WORKER, AB_OACC_ROUTINE_VECTOR, AB_OACC_ROUTINE_SEQ,
   AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE,
   AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR,
   AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK
@@ -2044,6 +2045,11 @@ static const mstring attr_bits[] =
     minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
     minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
     minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET),
+    minit ("OACC_ROUTINE", AB_OACC_ROUTINE),
+    minit ("OACC_ROUTINE_GANG", AB_OACC_ROUTINE_GANG),
+    minit ("OACC_ROUTINE_WORKER", AB_OACC_ROUTINE_WORKER),
+    minit ("OACC_ROUTINE_VECTOR", AB_OACC_ROUTINE_VECTOR),
+    minit ("OACC_ROUTINE_SEQ", AB_OACC_ROUTINE_SEQ),
     minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY),
     minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE),
     minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE),
@@ -2095,7 +2101,6 @@ DECL_MIO_NAME (procedure_type)
 DECL_MIO_NAME (ref_type)
 DECL_MIO_NAME (sym_flavor)
 DECL_MIO_NAME (sym_intent)
-DECL_MIO_NAME (oacc_function)
 #undef DECL_MIO_NAME
 
 /* Symbol attributes are stored in list with the first three elements
@@ -2117,8 +2122,6 @@ mio_symbol_attribute (symbol_attribute *attr)
   attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
   attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
   attr->save = MIO_NAME (save_state) (attr->save, save_status);
-  attr->oacc_function = MIO_NAME (oacc_function) (attr->oacc_function,
-						  oacc_function_types);
 
   ext_attr = attr->ext_attr;
   mio_integer ((int *) &ext_attr);
@@ -2236,6 +2239,16 @@ mio_symbol_attribute (symbol_attribute *attr)
 	MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
       if (attr->omp_declare_target)
 	MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits);
+      if (attr->oacc_routine)
+	MIO_NAME (ab_attribute) (AB_OACC_ROUTINE, attr_bits);
+      if (attr->oacc_routine_gang)
+	MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_GANG, attr_bits);
+      if (attr->oacc_routine_worker)
+	MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_WORKER, attr_bits);
+      if (attr->oacc_routine_vector)
+	MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_VECTOR, attr_bits);
+      if (attr->oacc_routine_seq)
+	MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_SEQ, attr_bits);
       if (attr->array_outer_dependency)
 	MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits);
       if (attr->module_procedure)
@@ -2422,6 +2435,21 @@ mio_symbol_attribute (symbol_attribute *attr)
 	    case AB_OMP_DECLARE_TARGET:
 	      attr->omp_declare_target = 1;
 	      break;
+	    case AB_OACC_ROUTINE:
+	      attr->oacc_routine = 1;
+	      break;
+	    case AB_OACC_ROUTINE_GANG:
+	      attr->oacc_routine_gang = 1;
+	      break;
+	    case AB_OACC_ROUTINE_WORKER:
+	      attr->oacc_routine_worker = 1;
+	      break;
+	    case AB_OACC_ROUTINE_VECTOR:
+	      attr->oacc_routine_vector = 1;
+	      break;
+	    case AB_OACC_ROUTINE_SEQ:
+	      attr->oacc_routine_seq = 1;
+	      break;
 	    case AB_ARRAY_OUTER_DEPENDENCY:
 	      attr->array_outer_dependency =1;
 	      break;
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 05e46613c6f..5a69e383fd3 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -1714,44 +1714,6 @@ gfc_match_oacc_cache (void)
   return MATCH_YES;
 }
 
-/* Determine the loop level for a routine.  Returns OACC_FUNCTION_NONE if
-   any error is detected.  */
-
-static oacc_function
-gfc_oacc_routine_dims (gfc_omp_clauses *clauses)
-{
-  int level = -1;
-  oacc_function ret = OACC_FUNCTION_SEQ;
-
-  if (clauses)
-    {
-      unsigned mask = 0;
-
-      if (clauses->gang)
-	{
-	  level = GOMP_DIM_GANG, mask |= GOMP_DIM_MASK (level);
-	  ret = OACC_FUNCTION_GANG;
-	}
-      if (clauses->worker)
-	{
-	  level = GOMP_DIM_WORKER, mask |= GOMP_DIM_MASK (level);
-	  ret = OACC_FUNCTION_WORKER;
-	}
-      if (clauses->vector)
-	{
-	  level = GOMP_DIM_VECTOR, mask |= GOMP_DIM_MASK (level);
-	  ret = OACC_FUNCTION_VECTOR;
-	}
-      if (clauses->seq)
-	level = GOMP_DIM_MAX, mask |= GOMP_DIM_MASK (level);
-
-      if (mask != (mask & -mask))
-	ret = OACC_FUNCTION_NONE;
-    }
-
-  return ret;
-}
-
 match
 gfc_match_oacc_routine (void)
 {
@@ -1761,7 +1723,8 @@ gfc_match_oacc_routine (void)
   gfc_omp_clauses *c = NULL;
   gfc_oacc_routine_name *n = NULL;
   gfc_intrinsic_sym *isym = NULL;
-  oacc_function dims = OACC_FUNCTION_NONE;
+  symbol_attribute *add_attr = NULL;
+  const char *add_attr_name = NULL;
 
   old_loc = gfc_current_locus;
 
@@ -1828,19 +1791,26 @@ gfc_match_oacc_routine (void)
 	  != MATCH_YES))
     return MATCH_ERROR;
 
-  dims = gfc_oacc_routine_dims (c);
-  if (dims == OACC_FUNCTION_NONE)
+  if (isym != NULL)
     {
-      gfc_error ("Multiple loop axes specified for routine %C");
-      gfc_current_locus = old_loc;
-      return MATCH_ERROR;
+      //TODO gfc_intrinsic_sym doesn't have symbol_attribute?
+      //add_attr = &isym->attr;
+      //add_attr_name = NULL; //TODO
+      /* Fake it.  TODO: handle device_type clauses...  */
+      if (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");
+	  gfc_current_locus = old_loc;
+	  return MATCH_ERROR;
+	}
     }
-
-  if (isym != NULL)
-    /* There is nothing to do for intrinsic procedures.  */
-    ;
   else if (sym != NULL)
     {
+      add_attr = &sym->attr;
+      add_attr_name = NULL; //TODO
+
       n = gfc_get_oacc_routine_name ();
       n->sym = sym;
       n->clauses = NULL;
@@ -1852,11 +1822,41 @@ gfc_match_oacc_routine (void)
     }
   else if (gfc_current_ns->proc_name)
     {
-      if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
-				       gfc_current_ns->proc_name->name,
-				       &old_loc))
+      add_attr = &gfc_current_ns->proc_name->attr;
+      add_attr_name = gfc_current_ns->proc_name->name;
+    }
+  else
+    gcc_unreachable ();
+
+  if (add_attr != NULL)
+    {
+      if (!gfc_add_omp_declare_target (add_attr, add_attr_name, &old_loc))
+	goto cleanup;
+      /* Skip over any existing symbol attributes capturing OpenACC routine
+	 directives.  */
+      while (add_attr->next != NULL)
+	add_attr = add_attr->next;
+      if (add_attr->oacc_routine)
+	{
+	  add_attr->next = XCNEW (symbol_attribute);
+	  gfc_clear_attr (add_attr->next);
+	  add_attr = add_attr->next;
+	}
+      if (!gfc_add_oacc_routine (add_attr, add_attr_name, &old_loc))
+	goto cleanup;
+      if (c && c->gang
+	  && !gfc_add_oacc_routine_gang (add_attr, add_attr_name, &old_loc))
+	goto cleanup;
+      if (c && c->worker
+	  && !gfc_add_oacc_routine_worker (add_attr, add_attr_name, &old_loc))
+	goto cleanup;
+      if (c && c->vector
+	  && !gfc_add_oacc_routine_vector (add_attr, add_attr_name, &old_loc))
+	goto cleanup;
+      if (c && c->seq
+	  && !gfc_add_oacc_routine_seq (add_attr, add_attr_name, &old_loc))
 	goto cleanup;
-      gfc_current_ns->proc_name->attr.oacc_function = dims;
+      add_attr->omp_clauses_locus = old_loc; //TODO OK to just assign that?
     }
 
   if (n)
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 84fa2bdbab3..36852dad68d 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -87,15 +87,6 @@ const mstring save_status[] =
     minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
 };
 
-const mstring oacc_function_types[] =
-{
-  minit ("NONE", OACC_FUNCTION_NONE),
-  minit ("OACC_FUNCTION_SEQ", OACC_FUNCTION_SEQ),
-  minit ("OACC_FUNCTION_GANG", OACC_FUNCTION_GANG),
-  minit ("OACC_FUNCTION_WORKER", OACC_FUNCTION_WORKER),
-  minit ("OACC_FUNCTION_VECTOR", OACC_FUNCTION_VECTOR)
-};
-
 /* This is to make sure the backend generates setup code in the correct
    order.  */
 
@@ -385,6 +376,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
     *contiguous = "CONTIGUOUS", *generic = "GENERIC";
   static const char *threadprivate = "THREADPRIVATE";
   static const char *omp_declare_target = "OMP DECLARE TARGET";
+  static const char *oacc_routine = "OACC ROUTINE";
+  static const char *oacc_routine_gang = "OACC ROUTINE GANG";
+  static const char *oacc_routine_worker = "OACC ROUTINE WORKER";
+  static const char *oacc_routine_vector = "OACC ROUTINE VECTOR";
+  static const char *oacc_routine_seq = "OACC ROUTINE SEQ";
   static const char *oacc_declare_copyin = "OACC DECLARE COPYIN";
   static const char *oacc_declare_create = "OACC DECLARE CREATE";
   static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR";
@@ -482,6 +478,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (dummy, intrinsic);
   conf (dummy, threadprivate);
   conf (dummy, omp_declare_target);
+  conf (dummy, oacc_routine);
+  conf (dummy, oacc_routine_gang);
+  conf (dummy, oacc_routine_worker);
+  conf (dummy, oacc_routine_vector);
+  conf (dummy, oacc_routine_seq);
   conf (pointer, target);
   conf (pointer, intrinsic);
   conf (pointer, elemental);
@@ -526,6 +527,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (in_equivalence, allocatable);
   conf (in_equivalence, threadprivate);
   conf (in_equivalence, omp_declare_target);
+  conf (in_equivalence, oacc_routine);
+  conf (in_equivalence, oacc_routine_gang);
+  conf (in_equivalence, oacc_routine_worker);
+  conf (in_equivalence, oacc_routine_vector);
+  conf (in_equivalence, oacc_routine_seq);
   conf (in_equivalence, oacc_declare_create);
   conf (in_equivalence, oacc_declare_copyin);
   conf (in_equivalence, oacc_declare_deviceptr);
@@ -579,6 +585,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (cray_pointee, in_equivalence);
   conf (cray_pointee, threadprivate);
   conf (cray_pointee, omp_declare_target);
+  conf (cray_pointee, oacc_routine);
+  conf (cray_pointee, oacc_routine_gang);
+  conf (cray_pointee, oacc_routine_worker);
+  conf (cray_pointee, oacc_routine_vector);
+  conf (cray_pointee, oacc_routine_seq);
   conf (cray_pointee, oacc_declare_create);
   conf (cray_pointee, oacc_declare_copyin);
   conf (cray_pointee, oacc_declare_deviceptr);
@@ -637,6 +648,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (proc_pointer, abstract)
 
   conf (entry, omp_declare_target)
+  conf (entry, oacc_routine)
+  conf (entry, oacc_routine_gang)
+  conf (entry, oacc_routine_worker)
+  conf (entry, oacc_routine_vector)
+  conf (entry, oacc_routine_seq)
   conf (entry, oacc_declare_create)
   conf (entry, oacc_declare_copyin)
   conf (entry, oacc_declare_deviceptr)
@@ -678,6 +694,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       conf2 (subroutine);
       conf2 (threadprivate);
       conf2 (omp_declare_target);
+      conf2 (oacc_routine);
+      conf2 (oacc_routine_gang);
+      conf2 (oacc_routine_worker);
+      conf2 (oacc_routine_vector);
+      conf2 (oacc_routine_seq);
       conf2 (oacc_declare_create);
       conf2 (oacc_declare_copyin);
       conf2 (oacc_declare_deviceptr);
@@ -764,6 +785,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       conf2 (threadprivate);
       conf2 (result);
       conf2 (omp_declare_target);
+      conf2 (oacc_routine);
+      conf2 (oacc_routine_gang);
+      conf2 (oacc_routine_worker);
+      conf2 (oacc_routine_vector);
+      conf2 (oacc_routine_seq);
       conf2 (oacc_declare_create);
       conf2 (oacc_declare_copyin);
       conf2 (oacc_declare_deviceptr);
@@ -1266,7 +1292,6 @@ bool
 gfc_add_omp_declare_target (symbol_attribute *attr, const char *name,
 			    locus *where)
 {
-
   if (check_used (attr, name, where))
     return false;
 
@@ -1279,6 +1304,81 @@ gfc_add_omp_declare_target (symbol_attribute *attr, const char *name,
 
 
 bool
+gfc_add_oacc_routine (symbol_attribute *attr, const char *name,
+		      locus *where)
+{
+  if (check_used (attr, name, where))
+    return false;
+
+  if (attr->oacc_routine)
+    return true;
+
+  attr->oacc_routine = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_oacc_routine_gang (symbol_attribute *attr, const char *name,
+			   locus *where)
+{
+  if (check_used (attr, name, where))
+    return false;
+
+  if (attr->oacc_routine_gang)
+    return true;
+
+  attr->oacc_routine_gang = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_oacc_routine_worker (symbol_attribute *attr, const char *name,
+			     locus *where)
+{
+  if (check_used (attr, name, where))
+    return false;
+
+  if (attr->oacc_routine_worker)
+    return true;
+
+  attr->oacc_routine_worker = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_oacc_routine_vector (symbol_attribute *attr, const char *name,
+			     locus *where)
+{
+  if (check_used (attr, name, where))
+    return false;
+
+  if (attr->oacc_routine_vector)
+    return true;
+
+  attr->oacc_routine_vector = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
+gfc_add_oacc_routine_seq (symbol_attribute *attr, const char *name,
+			  locus *where)
+{
+  if (check_used (attr, name, where))
+    return false;
+
+  if (attr->oacc_routine_seq)
+    return true;
+
+  attr->oacc_routine_seq = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
 gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name,
 			     locus *where)
 {
@@ -1915,6 +2015,21 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
   if (src->omp_declare_target
       && !gfc_add_omp_declare_target (dest, NULL, where))
     goto fail;
+  if (src->oacc_routine
+      && !gfc_add_oacc_routine (dest, NULL, where))
+    goto fail;
+  if (src->oacc_routine_gang
+      && !gfc_add_oacc_routine_gang (dest, NULL, where))
+    goto fail;
+  if (src->oacc_routine_worker
+      && !gfc_add_oacc_routine_worker (dest, NULL, where))
+    goto fail;
+  if (src->oacc_routine_vector
+      && !gfc_add_oacc_routine_vector (dest, NULL, where))
+    goto fail;
+  if (src->oacc_routine_seq
+      && !gfc_add_oacc_routine_seq (dest, NULL, where))
+    goto fail;
   if (src->oacc_declare_create
       && !gfc_add_oacc_declare_create (dest, NULL, where))
     goto fail;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 19344536cca..d1b956cb57b 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -46,6 +46,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "trans-stmt.h"
 #include "gomp-constants.h"
 #include "gimplify.h"
+#include "omp-low.h"
 
 #define MAX_LABEL_VALUE 99999
 
@@ -1360,37 +1361,94 @@ add_attributes_to_decl (symbol_attribute sym_attr, tree list)
       }
 
   if (sym_attr.omp_declare_target)
-    list = tree_cons (get_identifier ("omp declare target"),
-		      NULL_TREE, list);
-
-  if (sym_attr.oacc_function != OACC_FUNCTION_NONE)
     {
-      tree dims = NULL_TREE;
-      int ix;
-      int level = GOMP_DIM_MAX;
+      tree clauses = NULL_TREE;
+      symbol_attribute *oacc_routine_attr = &sym_attr;
+      while (oacc_routine_attr != NULL
+	     && oacc_routine_attr->oacc_routine)
+	{
+	  location_t loc = oacc_routine_attr->omp_clauses_locus.lb->location;
+	  //TODO use gfc_trans_omp_clauses?
+	  tree clauses_ = NULL_TREE;
+	  if (oacc_routine_attr->oacc_routine_gang)
+	    {
+	      tree c = build_omp_clause (loc, OMP_CLAUSE_GANG);
+	      OMP_CLAUSE_CHAIN (c) = clauses_;
+	      clauses_ = c;
+	    }
+	  if (oacc_routine_attr->oacc_routine_worker)
+	    {
+	      tree c = build_omp_clause (loc, OMP_CLAUSE_WORKER);
+	      OMP_CLAUSE_CHAIN (c) = clauses_;
+	      clauses_ = c;
+	    }
+	  if (oacc_routine_attr->oacc_routine_vector)
+	    {
+	      tree c = build_omp_clause (loc, OMP_CLAUSE_VECTOR);
+	      OMP_CLAUSE_CHAIN (c) = clauses_;
+	      clauses_ = c;
+	    }
+	  /* Default to seq if nothing else has been specified.  */
+	  if (oacc_routine_attr->oacc_routine_seq
+	      || clauses_ == NULL_TREE)
+	    {
+	      tree c = build_omp_clause (loc, OMP_CLAUSE_SEQ);
+	      OMP_CLAUSE_CHAIN (c) = clauses_;
+	      clauses_ = c;
+	    }
+
+	  /* If we saw more than one clause specifying the level of
+	     parallelism...  */
+	  if (OMP_CLAUSE_CHAIN (clauses_) != NULL_TREE)
+	    {
+	      gfc_error ("Multiple loop axes specified for routine at %L",
+			 &oacc_routine_attr->omp_clauses_locus);
 
-      switch (sym_attr.oacc_function)
+	      /* ..., only one clause survives.  */
+	      OMP_CLAUSE_CHAIN (clauses_) = NULL_TREE;
+	    }
+
+	  OMP_CLAUSE_CHAIN (clauses_) = clauses;
+	  clauses = clauses_;
+
+	  oacc_routine_attr = oacc_routine_attr->next;
+	}
+
+      /* For any chained symbol attributes for OpenACC routine, handle, and
+	 clean these up.  */
+      while (sym_attr.next != NULL)
 	{
-	case OACC_FUNCTION_GANG:
-	  level = GOMP_DIM_GANG;
-	  break;
-	case OACC_FUNCTION_WORKER:
-	  level = GOMP_DIM_WORKER;
-	  break;
-	case OACC_FUNCTION_VECTOR:
-	  level = GOMP_DIM_VECTOR;
-	  break;
-	case OACC_FUNCTION_SEQ:
-	default:;
+	  symbol_attribute *sym_attr_next = sym_attr.next->next;
+
+	  gfc_error ("!$ACC ROUTINE already applied at %L",
+		     &sym_attr.next->omp_clauses_locus);
+
+	  free (sym_attr.next);
+
+	  sym_attr.next = sym_attr_next;
 	}
 
-      for (ix = GOMP_DIM_MAX; ix--;)
-	dims = tree_cons (build_int_cst (boolean_type_node, ix >= level),
-			  integer_zero_node, dims);
+      if (sym_attr.oacc_routine)
+	{
+	  gcc_checking_assert (clauses != NULL_TREE);
+	  /* If we saw more than one set of symbol attributes for OpenACC
+	     routine, only one clause survives.  */
+	  OMP_CLAUSE_CHAIN (clauses) = NULL_TREE;
 
-      list = tree_cons (get_identifier ("oacc function"),
-			dims, list);
+	  /* Set the routine's level of parallelism.  */
+	  tree dims = build_oacc_routine_dims (clauses);
+#if 0
+	  // TODO Can we call this before decl_attributes has been called, which happens only after returning from add_attributes_to_decl?
+	  replace_oacc_fn_attrib (fndecl, dims);
+#else
+	  list = tree_cons (get_identifier ("oacc function"),
+			    dims, list);
+#endif
+	}
+      list = tree_cons (get_identifier ("omp declare target"),
+			NULL_TREE, list);
     }
+  gcc_checking_assert (sym_attr.next == NULL);
 
   return list;
 }
diff --git a/gcc/testsuite/gfortran.dg/goacc/oaccdevlow-routine.f95 b/gcc/testsuite/gfortran.dg/goacc/oaccdevlow-routine.f95
index 2161fe22839..6af19d5fb2e 100644
--- a/gcc/testsuite/gfortran.dg/goacc/oaccdevlow-routine.f95
+++ b/gcc/testsuite/gfortran.dg/goacc/oaccdevlow-routine.f95
@@ -20,7 +20,7 @@ subroutine ROUTINE
 end subroutine ROUTINE
 
 ! Check the offloaded function's attributes.
-! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(omp declare target, oacc function \\(0 0, 1 0, 1 0\\)\\)\\)" 1 "ompexp" } }
+! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc function \\(0 1, 1 0, 1 0\\), omp declare target\\)\\)" 1 "ompexp" } }
 
 ! Check the offloaded function's classification and compute dimensions (will
 ! always be [1, 1, 1] for target compilation).
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..e0c35d60303
--- /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.f90 b/gcc/testsuite/gfortran.dg/goacc/pr72741.f90
index cf897276769..bf47fc23767 100644
--- a/gcc/testsuite/gfortran.dg/goacc/pr72741.f90
+++ b/gcc/testsuite/gfortran.dg/goacc/pr72741.f90
@@ -1,12 +1,19 @@
 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" }
+  ! { dg-error "\\!\\\$ACC ROUTINE already applied" "already" { target *-*-* } 5 }
 END SUBROUTINE v_1
 
 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" }
+  ! { dg-error "\\!\\\$ACC ROUTINE already applied" "already" { target *-*-* } 15 }
 
   CALL v_1
   CALL g_1
@@ -17,7 +24,10 @@ 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" }
+  ! { dg-error "\\!\\\$ACC ROUTINE already applied" "already" { target *-*-* } 29 }
 
 CONTAINS
   SUBROUTINE sub_2