openmp, fortran: Add support for OpenMP declare variant directive in Fortran

2021-10-14  Kwok Cheung Yeung  <kcy@codesourcery.com>

gcc/c-family/

	* c-omp.c (c_omp_check_context_selector): Rename to
	omp_check_context_selector and move to omp-general.c.
	(c_omp_mark_declare_variant): Rename to omp_mark_declare_variant and
	move to omp-general.c.

gcc/c/

	* c-parser.c (c_finish_omp_declare_variant): Change call from
	c_omp_check_context_selector to omp_check_context_selector. Change
	call from c_omp_mark_declare_variant to omp_mark_declare_variant.

gcc/cp/

	* decl.c (omp_declare_variant_finalize_one): Change call from
	c_omp_mark_declare_variant to omp_mark_declare_variant.
	* parser.c (cp_finish_omp_declare_variant): Change call from
	c_omp_check_context_selector to omp_check_context_selector.

gcc/fortran/

	* gfortran.h (enum gfc_statement): Add ST_OMP_DECLARE_VARIANT.
	(enum gfc_omp_trait_property_kind): New.
	(struct gfc_omp_trait_property): New.
	(gfc_get_omp_trait_property): New macro.
	(struct gfc_omp_selector): New.
	(gfc_get_omp_selector): New macro.
	(struct gfc_omp_set_selector): New.
	(gfc_get_omp_set_selector): New macro.
	(struct gfc_omp_declare_variant): New.
	(gfc_get_omp_declare_variant): New macro.
	(struct gfc_namespace): Add omp_declare_variant field.
	(gfc_free_omp_declare_variant_list): New prototype.
	* match.h (gfc_match_omp_declare_variant): New prototype.
	* openmp.c (gfc_free_omp_trait_property_list): New.
	(gfc_free_omp_selector_list): New.
	(gfc_free_omp_set_selector_list): New.
	(gfc_free_omp_declare_variant_list): New.
	(gfc_match_omp_clauses): Add extra optional argument.  Handle end of
	clauses for context selectors.
	(omp_construct_selectors, omp_device_selectors,
	omp_implementation_selectors, omp_user_selectors): New.
	(gfc_match_omp_context_selector): New.
	(gfc_match_omp_context_selector_specification): New.
	(gfc_match_omp_declare_variant): New.
	* parse.c: Include tree-core.h and omp-general.h.
	(decode_omp_directive): Handle 'declare variant'.
	(case_omp_decl): Include ST_OMP_DECLARE_VARIANT.
	(gfc_ascii_statement): Handle ST_OMP_DECLARE_VARIANT.
	(gfc_parse_file): Initialize omp_requires_mask.
	* symbol.c (gfc_free_namespace): Call
	gfc_free_omp_declare_variant_list.
	* trans-decl.c (gfc_get_extern_function_decl): Call
	gfc_trans_omp_declare_variant.
	(gfc_create_function_decl): Call gfc_trans_omp_declare_variant.
	* trans-openmp.c (gfc_trans_omp_declare_variant): New.
	* trans-stmt.h (gfc_trans_omp_declare_variant): New prototype.

gcc/

	* omp-general.c (omp_check_context_selector):  Move from c-omp.c.
	(omp_mark_declare_variant): Move from c-omp.c.
	(omp_context_name_list_prop): Update for Fortran strings.
	* omp-general.h (omp_check_context_selector): New prototype.
	(omp_mark_declare_variant): New prototype.

gcc/testsuite/

	* gfortran.dg/gomp/declare-variant-1.f90: New test.
	* gfortran.dg/gomp/declare-variant-10.f90: New test.
	* gfortran.dg/gomp/declare-variant-11.f90: New test.
	* gfortran.dg/gomp/declare-variant-12.f90: New test.
	* gfortran.dg/gomp/declare-variant-13.f90: New test.
	* gfortran.dg/gomp/declare-variant-14.f90: New test.
	* gfortran.dg/gomp/declare-variant-15.f90: New test.
	* gfortran.dg/gomp/declare-variant-16.f90: New test.
	* gfortran.dg/gomp/declare-variant-17.f90: New test.
	* gfortran.dg/gomp/declare-variant-18.f90: New test.
	* gfortran.dg/gomp/declare-variant-19.f90: New test.
	* gfortran.dg/gomp/declare-variant-2.f90: New test.
	* gfortran.dg/gomp/declare-variant-2a.f90: New test.
	* gfortran.dg/gomp/declare-variant-3.f90: New test.
	* gfortran.dg/gomp/declare-variant-4.f90: New test.
	* gfortran.dg/gomp/declare-variant-5.f90: New test.
	* gfortran.dg/gomp/declare-variant-6.f90: New test.
	* gfortran.dg/gomp/declare-variant-7.f90: New test.
	* gfortran.dg/gomp/declare-variant-8.f90: New test.
	* gfortran.dg/gomp/declare-variant-9.f90: New test.

libgomp/

	* testsuite/libgomp.fortran/declare-variant-1.f90: New test.

8 files changed, 829 insertions, 6 deletions

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b2b0254..5b9f897 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -239,7 +239,7 @@ enum gfc_statement
   ST_OMP_DO_SIMD, ST_OMP_END_DO_SIMD, ST_OMP_PARALLEL_DO_SIMD,
   ST_OMP_END_PARALLEL_DO_SIMD, ST_OMP_DECLARE_SIMD, ST_OMP_DECLARE_REDUCTION,
   ST_OMP_TARGET, ST_OMP_END_TARGET, ST_OMP_TARGET_DATA, ST_OMP_END_TARGET_DATA,
-  ST_OMP_TARGET_UPDATE, ST_OMP_DECLARE_TARGET,
+  ST_OMP_TARGET_UPDATE, ST_OMP_DECLARE_TARGET, ST_OMP_DECLARE_VARIANT,
   ST_OMP_TEAMS, ST_OMP_END_TEAMS, ST_OMP_DISTRIBUTE, ST_OMP_END_DISTRIBUTE,
   ST_OMP_DISTRIBUTE_SIMD, ST_OMP_END_DISTRIBUTE_SIMD,
   ST_OMP_DISTRIBUTE_PARALLEL_DO, ST_OMP_END_DISTRIBUTE_PARALLEL_DO,
@@ -1553,6 +1553,73 @@ typedef struct gfc_omp_declare_simd
 gfc_omp_declare_simd;
 #define gfc_get_omp_declare_simd() XCNEW (gfc_omp_declare_simd)
 
+
+enum gfc_omp_trait_property_kind
+{
+  CTX_PROPERTY_NONE,
+  CTX_PROPERTY_USER,
+  CTX_PROPERTY_NAME_LIST,
+  CTX_PROPERTY_ID,
+  CTX_PROPERTY_EXPR,
+  CTX_PROPERTY_SIMD
+};
+
+typedef struct gfc_omp_trait_property
+{
+  struct gfc_omp_trait_property *next;
+  enum gfc_omp_trait_property_kind property_kind;
+  bool is_name : 1;
+
+  union
+    {
+      gfc_expr *expr;
+      gfc_symbol *sym;
+      gfc_omp_clauses *clauses;
+      char *name;
+    };
+} gfc_omp_trait_property;
+#define gfc_get_omp_trait_property() XCNEW (gfc_omp_trait_property)
+
+typedef struct gfc_omp_selector
+{
+  struct gfc_omp_selector *next;
+
+  char *trait_selector_name;
+  gfc_expr *score;
+  struct gfc_omp_trait_property *properties;
+} gfc_omp_selector;
+#define gfc_get_omp_selector() XCNEW (gfc_omp_selector)
+
+typedef struct gfc_omp_set_selector
+{
+  struct gfc_omp_set_selector *next;
+
+  const char *trait_set_selector_name;
+  struct gfc_omp_selector *trait_selectors;
+} gfc_omp_set_selector;
+#define gfc_get_omp_set_selector() XCNEW (gfc_omp_set_selector)
+
+
+/* Node in the linked list used for storing !$omp declare variant
+   constructs.  */
+
+typedef struct gfc_omp_declare_variant
+{
+  struct gfc_omp_declare_variant *next;
+  locus where; /* Where the !$omp declare variant construct occurred.  */
+
+  struct gfc_symtree *base_proc_symtree;
+  struct gfc_symtree *variant_proc_symtree;
+
+  gfc_omp_set_selector *set_selectors;
+
+  bool checked_p : 1; /* Set if previously checked for errors.  */
+  bool error_p : 1; /* Set if error found in directive.  */
+}
+gfc_omp_declare_variant;
+#define gfc_get_omp_declare_variant() XCNEW (gfc_omp_declare_variant)
+
+
 typedef struct gfc_omp_udr
 {
   struct gfc_omp_udr *next;
@@ -2022,6 +2089,9 @@ typedef struct gfc_namespace
   /* Linked list of !$omp declare simd constructs.  */
   struct gfc_omp_declare_simd *omp_declare_simd;
 
+  /* Linked list of !$omp declare variant constructs.  */
+  struct gfc_omp_declare_variant *omp_declare_variant;
+
   /* A hash set for the the gfc expressions that have already
      been finalized in this namespace.  */
 
@@ -3422,6 +3492,7 @@ bool gfc_omp_requires_add_clause (gfc_omp_requires_kind, const char *,
 void gfc_check_omp_requires (gfc_namespace *, int);
 void gfc_free_omp_clauses (gfc_omp_clauses *);
 void gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *);
+void gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list);
 void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
 void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
 void gfc_free_omp_udr (gfc_omp_udr *);
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 92fd127..21e94f7 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -160,6 +160,7 @@ match gfc_match_omp_critical (void);
 match gfc_match_omp_declare_reduction (void);
 match gfc_match_omp_declare_simd (void);
 match gfc_match_omp_declare_target (void);
+match gfc_match_omp_declare_variant (void);
 match gfc_match_omp_depobj (void);
 match gfc_match_omp_distribute (void);
 match gfc_match_omp_distribute_parallel_do (void);
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 6a4ca28..2a161f3 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -168,6 +168,70 @@ gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
     }
 }
 
+static void
+gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
+{
+  while (list)
+    {
+      gfc_omp_trait_property *current = list;
+      list = list->next;
+      switch (current->property_kind)
+	{
+	case CTX_PROPERTY_ID:
+	  free (current->name);
+	  break;
+	case CTX_PROPERTY_NAME_LIST:
+	  if (current->is_name)
+	    free (current->name);
+	  break;
+	case CTX_PROPERTY_SIMD:
+	  gfc_free_omp_clauses (current->clauses);
+	  break;
+	default:
+	  break;
+	}
+      free (current);
+    }
+}
+
+static void
+gfc_free_omp_selector_list (gfc_omp_selector *list)
+{
+  while (list)
+    {
+      gfc_omp_selector *current = list;
+      list = list->next;
+      gfc_free_omp_trait_property_list (current->properties);
+      free (current);
+    }
+}
+
+static void
+gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
+{
+  while (list)
+    {
+      gfc_omp_set_selector *current = list;
+      list = list->next;
+      gfc_free_omp_selector_list (current->trait_selectors);
+      free (current);
+    }
+}
+
+/* Free an !$omp declare variant construct list.  */
+
+void
+gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
+{
+  while (list)
+    {
+      gfc_omp_declare_variant *current = list;
+      list = list->next;
+      gfc_free_omp_set_selector_list (current->set_selectors);
+      free (current);
+    }
+}
+
 /* Free an !$omp declare reduction.  */
 
 void
@@ -1353,7 +1417,7 @@ gfc_match_dupl_atomic (bool not_dupl, const char *name)
 static match
 gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 		       bool first = true, bool needs_space = true,
-		       bool openacc = false)
+		       bool openacc = false, bool context_selector = false)
 {
   bool error = false;
   gfc_omp_clauses *c = gfc_get_omp_clauses ();
@@ -2843,7 +2907,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
     }
 
 end:
-  if (error || gfc_match_omp_eos () != MATCH_YES)
+  if (error
+      || (context_selector && gfc_peek_ascii_char () != ')')
+      || (!context_selector && gfc_match_omp_eos () != MATCH_YES))
     {
       if (!gfc_error_flag_test ())
 	gfc_error ("Failed to match clause at %C");
@@ -4429,6 +4495,449 @@ cleanup:
 }
 
 
+static const char *const omp_construct_selectors[] = {
+  "simd", "target", "teams", "parallel", "do", NULL };
+static const char *const omp_device_selectors[] = {
+  "kind", "isa", "arch", NULL };
+static const char *const omp_implementation_selectors[] = {
+  "vendor", "extension", "atomic_default_mem_order", "unified_address",
+  "unified_shared_memory", "dynamic_allocators", "reverse_offload", NULL };
+static const char *const omp_user_selectors[] = {
+  "condition", NULL };
+
+
+/* OpenMP 5.0:
+
+   trait-selector:
+     trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
+
+   trait-score:
+     score(score-expression)  */
+
+match
+gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
+{
+  do
+    {
+      char selector[GFC_MAX_SYMBOL_LEN + 1];
+
+      if (gfc_match_name (selector) != MATCH_YES)
+	{
+	  gfc_error ("expected trait selector name at %C");
+	  return MATCH_ERROR;
+	}
+
+      gfc_omp_selector *os = gfc_get_omp_selector ();
+      os->trait_selector_name = XNEWVEC (char, strlen (selector) + 1);
+      strcpy (os->trait_selector_name, selector);
+      os->next = oss->trait_selectors;
+      oss->trait_selectors = os;
+
+      const char *const *selectors = NULL;
+      bool allow_score = true;
+      bool allow_user = false;
+      int property_limit = 0;
+      enum gfc_omp_trait_property_kind property_kind = CTX_PROPERTY_NONE;
+      switch (oss->trait_set_selector_name[0])
+	{
+	case 'c': /* construct */
+	  selectors = omp_construct_selectors;
+	  allow_score = false;
+	  property_limit = 1;
+	  property_kind = CTX_PROPERTY_SIMD;
+	  break;
+	case 'd': /* device */
+	  selectors = omp_device_selectors;
+	  allow_score = false;
+	  allow_user = true;
+	  property_limit = 3;
+	  property_kind = CTX_PROPERTY_NAME_LIST;
+	  break;
+	case 'i': /* implementation */
+	  selectors = omp_implementation_selectors;
+	  allow_user = true;
+	  property_limit = 3;
+	  property_kind = CTX_PROPERTY_NAME_LIST;
+	  break;
+	case 'u': /* user */
+	  selectors = omp_user_selectors;
+	  property_limit = 1;
+	  property_kind = CTX_PROPERTY_EXPR;
+	  break;
+	default:
+	  gcc_unreachable ();
+	}
+      for (int i = 0; ; i++)
+	{
+	  if (selectors[i] == NULL)
+	    {
+	      if (allow_user)
+		{
+		  property_kind = CTX_PROPERTY_USER;
+		  break;
+		}
+	      else
+		{
+		  gfc_error ("selector '%s' not allowed for context selector "
+			     "set '%s' at %C",
+			     selector, oss->trait_set_selector_name);
+		  return MATCH_ERROR;
+		}
+	    }
+	  if (i == property_limit)
+	    property_kind = CTX_PROPERTY_NONE;
+	  if (strcmp (selectors[i], selector) == 0)
+	    break;
+	}
+      if (property_kind == CTX_PROPERTY_NAME_LIST
+	  && oss->trait_set_selector_name[0] == 'i'
+	  && strcmp (selector, "atomic_default_mem_order") == 0)
+	property_kind = CTX_PROPERTY_ID;
+
+      if (gfc_match (" (") == MATCH_YES)
+	{
+	  if (property_kind == CTX_PROPERTY_NONE)
+	    {
+	      gfc_error ("selector '%s' does not accept any properties at %C",
+			 selector);
+	      return MATCH_ERROR;
+	    }
+
+	  if (allow_score && gfc_match (" score") == MATCH_YES)
+	    {
+	      if (gfc_match (" (") != MATCH_YES)
+		{
+		  gfc_error ("expected '(' at %C");
+		  return MATCH_ERROR;
+		}
+	      if (gfc_match_expr (&os->score) != MATCH_YES
+		  || !gfc_resolve_expr (os->score)
+		  || os->score->ts.type != BT_INTEGER
+		  || os->score->rank != 0)
+		{
+		  gfc_error ("score argument must be constant integer "
+			     "expression at %C");
+		  return MATCH_ERROR;
+		}
+
+	      if (os->score->expr_type == EXPR_CONSTANT
+		  && mpz_sgn (os->score->value.integer) < 0)
+		{
+		  gfc_error ("score argument must be non-negative at %C");
+		  return MATCH_ERROR;
+		}
+
+	      if (gfc_match (" )") != MATCH_YES)
+		{
+		  gfc_error ("expected ')' at %C");
+		  return MATCH_ERROR;
+		}
+
+	      if (gfc_match (" :") != MATCH_YES)
+		{
+		  gfc_error ("expected : at %C");
+		  return MATCH_ERROR;
+		}
+	    }
+
+	  gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
+	  otp->property_kind = property_kind;
+	  otp->next = os->properties;
+	  os->properties = otp;
+
+	  switch (property_kind)
+	    {
+	    case CTX_PROPERTY_USER:
+	      do
+		{
+		  if (gfc_match_expr (&otp->expr) != MATCH_YES)
+		    {
+		      gfc_error ("property must be constant integer "
+				 "expression or string literal at %C");
+		      return MATCH_ERROR;
+		    }
+
+		  if (gfc_match (" ,") != MATCH_YES)
+		    break;
+		}
+	      while (1);
+	      break;
+	    case CTX_PROPERTY_ID:
+	      {
+		char buf[GFC_MAX_SYMBOL_LEN + 1];
+		if (gfc_match_name (buf) == MATCH_YES)
+		  {
+		    otp->name = XNEWVEC (char, strlen (buf) + 1);
+		    strcpy (otp->name, buf);
+		  }
+		else
+		  {
+		    gfc_error ("expected identifier at %C");
+		    return MATCH_ERROR;
+		  }
+	      }
+	      break;
+	    case CTX_PROPERTY_NAME_LIST:
+	      do
+		{
+		  char buf[GFC_MAX_SYMBOL_LEN + 1];
+		  if (gfc_match_name (buf) == MATCH_YES)
+		    {
+		      otp->name = XNEWVEC (char, strlen (buf) + 1);
+		      strcpy (otp->name, buf);
+		      otp->is_name = true;
+		    }
+		  else if (gfc_match_literal_constant (&otp->expr, 0)
+			   != MATCH_YES
+			   || otp->expr->ts.type != BT_CHARACTER)
+		    {
+		      gfc_error ("expected identifier or string literal "
+				 "at %C");
+		      return MATCH_ERROR;
+		    }
+
+		  if (gfc_match (" ,") == MATCH_YES)
+		    {
+		      otp = gfc_get_omp_trait_property ();
+		      otp->property_kind = property_kind;
+		      otp->next = os->properties;
+		      os->properties = otp;
+		    }
+		  else
+		    break;
+		}
+	      while (1);
+	      break;
+	    case CTX_PROPERTY_EXPR:
+	      if (gfc_match_expr (&otp->expr) != MATCH_YES)
+		{
+		  gfc_error ("expected expression at %C");
+		  return MATCH_ERROR;
+		}
+	      if (!gfc_resolve_expr (otp->expr)
+		  || (otp->expr->ts.type != BT_LOGICAL
+		      && otp->expr->ts.type != BT_INTEGER)
+		  || otp->expr->rank != 0)
+		{
+		  gfc_error ("property must be constant integer or logical "
+			     "expression at %C");
+		  return MATCH_ERROR;
+		}
+	      break;
+	    case CTX_PROPERTY_SIMD:
+	      {
+		if (gfc_match_omp_clauses (&otp->clauses,
+					   OMP_DECLARE_SIMD_CLAUSES,
+					   true, false, false, true)
+		    != MATCH_YES)
+		  {
+		  gfc_error ("expected simd clause at %C");
+		    return MATCH_ERROR;
+		  }
+		break;
+	      }
+	    default:
+	      gcc_unreachable ();
+	    }
+
+	  if (gfc_match (" )") != MATCH_YES)
+	    {
+	      gfc_error ("expected ')' at %C");
+	      return MATCH_ERROR;
+	    }
+	}
+      else if (property_kind == CTX_PROPERTY_NAME_LIST
+	       || property_kind == CTX_PROPERTY_ID
+	       || property_kind == CTX_PROPERTY_EXPR)
+	{
+	  if (gfc_match (" (") != MATCH_YES)
+	    {
+	      gfc_error ("expected '(' at %C");
+	      return MATCH_ERROR;
+	    }
+	}
+
+      if (gfc_match (" ,") != MATCH_YES)
+	break;
+    }
+  while (1);
+
+  return MATCH_YES;
+}
+
+/* OpenMP 5.0:
+
+   trait-set-selector[,trait-set-selector[,...]]
+
+   trait-set-selector:
+     trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
+
+   trait-set-selector-name:
+     constructor
+     device
+     implementation
+     user  */
+
+match
+gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv)
+{
+  do
+    {
+      match m;
+      const char *selector_sets[] = { "construct", "device",
+				      "implementation", "user" };
+      const int selector_set_count
+	= sizeof (selector_sets) / sizeof (*selector_sets);
+      int i;
+      char buf[GFC_MAX_SYMBOL_LEN + 1];
+
+      m = gfc_match_name (buf);
+      if (m == MATCH_YES)
+	for (i = 0; i < selector_set_count; i++)
+	  if (strcmp (buf, selector_sets[i]) == 0)
+	    break;
+
+      if (m != MATCH_YES || i == selector_set_count)
+	{
+	  gfc_error ("expected 'construct', 'device', 'implementation' or "
+		     "'user' at %C");
+	  return MATCH_ERROR;
+	}
+
+      m = gfc_match (" =");
+      if (m != MATCH_YES)
+	{
+	  gfc_error ("expected '=' at %C");
+	  return MATCH_ERROR;
+	}
+
+      m = gfc_match (" {");
+      if (m != MATCH_YES)
+	{
+	  gfc_error ("expected '{' at %C");
+	  return MATCH_ERROR;
+	}
+
+      gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
+      oss->next = odv->set_selectors;
+      oss->trait_set_selector_name = selector_sets[i];
+      odv->set_selectors = oss;
+
+      if (gfc_match_omp_context_selector (oss) != MATCH_YES)
+	return MATCH_ERROR;
+
+      m = gfc_match (" }");
+      if (m != MATCH_YES)
+	{
+	  gfc_error ("expected '}' at %C");
+	  return MATCH_ERROR;
+	}
+
+      m = gfc_match (" ,");
+      if (m != MATCH_YES)
+	break;
+    }
+  while (1);
+
+  return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_declare_variant (void)
+{
+  bool first_p = true;
+  char buf[GFC_MAX_SYMBOL_LEN + 1];
+
+  if (gfc_match (" (") != MATCH_YES)
+    {
+      gfc_error ("expected '(' at %C");
+      return MATCH_ERROR;
+    }
+
+  gfc_symtree *base_proc_st, *variant_proc_st;
+  if (gfc_match_name (buf) != MATCH_YES)
+    {
+      gfc_error ("expected name at %C");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_get_ha_sym_tree (buf, &base_proc_st))
+    return MATCH_ERROR;
+
+  if (gfc_match (" :") == MATCH_YES)
+    {
+      if (gfc_match_name (buf) != MATCH_YES)
+	{
+	  gfc_error ("expected variant name at %C");
+	  return MATCH_ERROR;
+	}
+
+      if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
+	return MATCH_ERROR;
+    }
+  else
+    {
+      /* Base procedure not specified.  */
+      variant_proc_st = base_proc_st;
+      base_proc_st = NULL;
+    }
+
+  gfc_omp_declare_variant *odv;
+  odv = gfc_get_omp_declare_variant ();
+  odv->where = gfc_current_locus;
+  odv->variant_proc_symtree = variant_proc_st;
+  odv->base_proc_symtree = base_proc_st;
+  odv->next = NULL;
+  odv->error_p = false;
+
+  /* Add the new declare variant to the end of the list.  */
+  gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
+  while (*prev_next)
+    prev_next = &((*prev_next)->next);
+  *prev_next = odv;
+
+  if (gfc_match (" )") != MATCH_YES)
+    {
+      gfc_error ("expected ')' at %C");
+      return MATCH_ERROR;
+    }
+
+  for (;;)
+    {
+      if (gfc_match (" match") != MATCH_YES)
+	{
+	  if (first_p)
+	    {
+	      gfc_error ("expected 'match' at %C");
+	      return MATCH_ERROR;
+	    }
+	  else
+	    break;
+	}
+
+      if (gfc_match (" (") != MATCH_YES)
+	{
+	  gfc_error ("expected '(' at %C");
+	  return MATCH_ERROR;
+	}
+
+      if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES)
+	return MATCH_ERROR;
+
+      if (gfc_match (" )") != MATCH_YES)
+	{
+	  gfc_error ("expected ')' at %C");
+	  return MATCH_ERROR;
+	}
+
+      first_p = false;
+    }
+
+  return MATCH_YES;
+}
+
+
 match
 gfc_match_omp_threadprivate (void)
 {
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 7d765a0..2a454be 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -26,6 +26,8 @@ along with GCC; see the file COPYING3.  If not see
 #include <setjmp.h>
 #include "match.h"
 #include "parse.h"
+#include "tree-core.h"
+#include "omp-general.h"
 
 /* Current statement label.  Zero means no statement label.  Because new_st
    can get wiped during statement matching, we have to keep it separate.  */
@@ -860,6 +862,8 @@ decode_omp_directive (void)
 	       ST_OMP_DECLARE_SIMD);
       matchdo ("declare target", gfc_match_omp_declare_target,
 	       ST_OMP_DECLARE_TARGET);
+      matchdo ("declare variant", gfc_match_omp_declare_variant,
+	       ST_OMP_DECLARE_VARIANT);
       break;
     case 's':
       matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
@@ -1718,6 +1722,7 @@ next_statement (void)
 
 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
   case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
+  case ST_OMP_DECLARE_VARIANT: \
   case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
 
 /* Block end statements.  Errors associated with interchanging these
@@ -2361,6 +2366,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_OMP_DECLARE_TARGET:
       p = "!$OMP DECLARE TARGET";
       break;
+    case ST_OMP_DECLARE_VARIANT:
+      p = "!$OMP DECLARE VARIANT";
+      break;
     case ST_OMP_DEPOBJ:
       p = "!$OMP DEPOBJ";
       break;
@@ -6793,6 +6801,24 @@ done:
        gfc_current_ns = gfc_current_ns->sibling)
     gfc_check_omp_requires (gfc_current_ns, omp_requires);
 
+  /* Populate omp_requires_mask (needed for resolving OpenMP
+     metadirectives and declare variant).  */
+  switch (omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
+    {
+    case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
+      omp_requires_mask
+	= (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_SEQ_CST);
+      break;
+    case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
+      omp_requires_mask
+	= (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQ_REL);
+      break;
+    case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
+      omp_requires_mask
+	= (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELAXED);
+      break;
+    }
+
   /* Do the parse tree dump.  */
   gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
 
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 6d61bf4..2c4acd5 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4046,6 +4046,7 @@ gfc_free_namespace (gfc_namespace *ns)
   free_tb_tree (ns->tb_uop_root);
   gfc_free_finalizer_list (ns->finalizers);
   gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
+  gfc_free_omp_declare_variant_list (ns->omp_declare_variant);
   gfc_free_charlen (ns->cl_list, NULL);
   free_st_labels (ns->st_labels);
 
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 87455f8..7da1d2e 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -2362,9 +2362,13 @@ module_sym:
     pushdecl_top_level (fndecl);
 
   if (sym->formal_ns
-      && sym->formal_ns->proc_name == sym
-      && sym->formal_ns->omp_declare_simd)
-    gfc_trans_omp_declare_simd (sym->formal_ns);
+      && sym->formal_ns->proc_name == sym)
+    {
+      if (sym->formal_ns->omp_declare_simd)
+	gfc_trans_omp_declare_simd (sym->formal_ns);
+      if (flag_openmp)
+	gfc_trans_omp_declare_variant (sym->formal_ns);
+    }
 
   return fndecl;
 }
@@ -3112,6 +3116,12 @@ gfc_create_function_decl (gfc_namespace * ns, bool global)
 
   if (ns->omp_declare_simd)
     gfc_trans_omp_declare_simd (ns);
+
+  /* Handle 'declare variant' directives.  The applicable directives might
+     be declared in a parent namespace, so this needs to be called even if
+     there are no local directives.  */
+  if (flag_openmp)
+    gfc_trans_omp_declare_variant (ns);
 }
 
 /* Return the decl used to hold the function return value.  If
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index d234d1b..37d2331 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -7258,3 +7258,207 @@ gfc_trans_omp_declare_simd (gfc_namespace *ns)
       DECL_ATTRIBUTES (fndecl) = c;
     }
 }
+
+void
+gfc_trans_omp_declare_variant (gfc_namespace *ns)
+{
+  tree base_fn_decl = ns->proc_name->backend_decl;
+  gfc_namespace *search_ns = ns;
+  gfc_omp_declare_variant *next;
+
+  for (gfc_omp_declare_variant *odv = search_ns->omp_declare_variant;
+       search_ns; odv = next)
+    {
+      /* Look in the parent namespace if there are no more directives in the
+	 current namespace.  */
+      if (!odv)
+	{
+	  search_ns = search_ns->parent;
+	  if (search_ns)
+	    next = search_ns->omp_declare_variant;
+	  continue;
+	}
+
+      next = odv->next;
+
+      if (odv->error_p)
+	continue;
+
+      /* Check directive the first time it is encountered.  */
+      bool error_found = true;
+
+      if (odv->checked_p)
+	error_found = false;
+      if (odv->base_proc_symtree == NULL)
+	{
+	  if (!search_ns->proc_name->attr.function
+	      && !search_ns->proc_name->attr.subroutine)
+	    gfc_error ("The base name for 'declare variant' must be "
+		       "specified at %L ", &odv->where);
+	  else
+	    error_found = false;
+	}
+      else
+	{
+	  if (!search_ns->contained
+	      && strcmp (odv->base_proc_symtree->name,
+			 ns->proc_name->name))
+	    gfc_error ("The base name at %L does not match the name of the "
+		       "current procedure", &odv->where);
+	  else if (odv->base_proc_symtree->n.sym->attr.entry)
+	    gfc_error ("The base name at %L must not be an entry name",
+			&odv->where);
+	  else if (odv->base_proc_symtree->n.sym->attr.generic)
+	    gfc_error ("The base name at %L must not be a generic name",
+			&odv->where);
+	  else if (odv->base_proc_symtree->n.sym->attr.proc_pointer)
+	    gfc_error ("The base name at %L must not be a procedure pointer",
+			&odv->where);
+	  else if (odv->base_proc_symtree->n.sym->attr.implicit_type)
+	    gfc_error ("The base procedure at %L must have an explicit "
+			"interface", &odv->where);
+	  else
+	    error_found = false;
+	}
+
+      odv->checked_p = true;
+      if (error_found)
+	{
+	  odv->error_p = true;
+	  continue;
+	}
+
+      /* Ignore directives that do not apply to the current procedure.  */
+      if ((odv->base_proc_symtree == NULL && search_ns != ns)
+	  || (odv->base_proc_symtree != NULL
+	      && strcmp (odv->base_proc_symtree->name, ns->proc_name->name)))
+	continue;
+
+      tree set_selectors = NULL_TREE;
+      gfc_omp_set_selector *oss;
+
+      for (oss = odv->set_selectors; oss; oss = oss->next)
+	{
+	  tree selectors = NULL_TREE;
+	  gfc_omp_selector *os;
+	  for (os = oss->trait_selectors; os; os = os->next)
+	    {
+	      tree properties = NULL_TREE;
+	      gfc_omp_trait_property *otp;
+
+	      for (otp = os->properties; otp; otp = otp->next)
+		{
+		  switch (otp->property_kind)
+		    {
+		    case CTX_PROPERTY_USER:
+		    case CTX_PROPERTY_EXPR:
+		      {
+			gfc_se se;
+			gfc_init_se (&se, NULL);
+			gfc_conv_expr (&se, otp->expr);
+			properties = tree_cons (NULL_TREE, se.expr,
+						properties);
+		      }
+		      break;
+		    case CTX_PROPERTY_ID:
+		      properties = tree_cons (get_identifier (otp->name),
+					      NULL_TREE, properties);
+		      break;
+		    case CTX_PROPERTY_NAME_LIST:
+		      {
+			tree prop = NULL_TREE, value = NULL_TREE;
+			if (otp->is_name)
+			  prop = get_identifier (otp->name);
+			else
+			  value = gfc_conv_constant_to_tree (otp->expr);
+
+			properties = tree_cons (prop, value, properties);
+		      }
+		      break;
+		    case CTX_PROPERTY_SIMD:
+		      properties = gfc_trans_omp_clauses (NULL, otp->clauses,
+							  odv->where, true);
+		      break;
+		    default:
+		      gcc_unreachable ();
+		    }
+		}
+
+	      if (os->score)
+		{
+		  gfc_se se;
+		  gfc_init_se (&se, NULL);
+		  gfc_conv_expr (&se, os->score);
+		  properties = tree_cons (get_identifier (" score"),
+					  se.expr, properties);
+		}
+
+	      selectors = tree_cons (get_identifier (os->trait_selector_name),
+				     properties, selectors);
+	    }
+
+	  set_selectors
+	    = tree_cons (get_identifier (oss->trait_set_selector_name),
+			 selectors, set_selectors);
+	}
+
+      const char *variant_proc_name = odv->variant_proc_symtree->name;
+      gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym;
+      if (variant_proc_sym == NULL || variant_proc_sym->attr.implicit_type)
+	{
+	  gfc_symtree *proc_st;
+	  gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st);
+	  variant_proc_sym = proc_st->n.sym;
+	}
+      if (variant_proc_sym == NULL)
+	{
+	  gfc_error ("Cannot find symbol %qs", variant_proc_name);
+	  continue;
+	}
+      set_selectors = omp_check_context_selector
+	  (gfc_get_location (&odv->where), set_selectors);
+      if (set_selectors != error_mark_node)
+	{
+	  if (!variant_proc_sym->attr.implicit_type
+	      && !variant_proc_sym->attr.subroutine
+	      && !variant_proc_sym->attr.function)
+	    {
+	      gfc_error ("variant %qs at %L is not a function or subroutine",
+			 variant_proc_name, &odv->where);
+	      variant_proc_sym = NULL;
+	    }
+	  else if (omp_get_context_selector (set_selectors, "construct",
+					     "simd") == NULL_TREE)
+	    {
+	      char err[256];
+	      if (!gfc_compare_interfaces (ns->proc_name, variant_proc_sym,
+					   variant_proc_sym->name, 0, 1,
+					   err, sizeof (err), NULL, NULL))
+		{
+		  gfc_error ("variant %qs and base %qs at %L have "
+			     "incompatible types: %s",
+			     variant_proc_name, ns->proc_name->name,
+			     &odv->where, err);
+		  variant_proc_sym = NULL;
+		}
+	    }
+	  if (variant_proc_sym != NULL)
+	    {
+	      gfc_set_sym_referenced (variant_proc_sym);
+	      tree construct = omp_get_context_selector (set_selectors,
+							 "construct", NULL);
+	      omp_mark_declare_variant (gfc_get_location (&odv->where),
+					gfc_get_symbol_decl (variant_proc_sym),
+					construct);
+	      if (omp_context_selector_matches (set_selectors))
+		{
+		  tree id = get_identifier ("omp declare variant base");
+		  tree variant = gfc_get_symbol_decl (variant_proc_sym);
+		  DECL_ATTRIBUTES (base_fn_decl)
+		    = tree_cons (id, build_tree_list (variant, set_selectors),
+				 DECL_ATTRIBUTES (base_fn_decl));
+		}
+	    }
+	}
+    }
+}
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index 763f894..1a24d9b 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -71,6 +71,7 @@ tree gfc_trans_deallocate_array (tree);
 /* trans-openmp.c */
 tree gfc_trans_omp_directive (gfc_code *);
 void gfc_trans_omp_declare_simd (gfc_namespace *);
+void gfc_trans_omp_declare_variant (gfc_namespace *);
 tree gfc_trans_oacc_directive (gfc_code *);
 tree gfc_trans_oacc_declare (gfc_namespace *);