gcc/fortran/openmp.c

/* OpenMP directive matching and resolving.
   Copyright (C) 2005-2018 Free Software Foundation, Inc.
   Contributed by Jakub Jelinek

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3.  If not see
<http://www.gnu.org/licenses/>.  */

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "gfortran.h"
#include "arith.h"
#include "match.h"
#include "parse.h"
#include "diagnostic.h"
#include "gomp-constants.h"

/* Match an end of OpenMP directive.  End of OpenMP directive is optional
   whitespace, followed by '\n' or comment '!'.  */

match
gfc_match_omp_eos (void)
{
  locus old_loc;
  char c;

  old_loc = gfc_current_locus;
  gfc_gobble_whitespace ();

  c = gfc_next_ascii_char ();
  switch (c)
    {
    case '!':
      do
	c = gfc_next_ascii_char ();
      while (c != '\n');
      /* Fall through */

    case '\n':
      return MATCH_YES;
    }

  gfc_current_locus = old_loc;
  return MATCH_NO;
}

/* Free an omp_clauses structure.  */

void
gfc_free_omp_clauses (gfc_omp_clauses *c)
{
  int i;
  if (c == NULL)
    return;

  gfc_free_expr (c->if_expr);
  gfc_free_expr (c->final_expr);
  gfc_free_expr (c->num_threads);
  gfc_free_expr (c->chunk_size);
  gfc_free_expr (c->safelen_expr);
  gfc_free_expr (c->simdlen_expr);
  gfc_free_expr (c->num_teams);
  gfc_free_expr (c->device);
  gfc_free_expr (c->thread_limit);
  gfc_free_expr (c->dist_chunk_size);
  gfc_free_expr (c->grainsize);
  gfc_free_expr (c->hint);
  gfc_free_expr (c->num_tasks);
  gfc_free_expr (c->priority);
  for (i = 0; i < OMP_IF_LAST; i++)
    gfc_free_expr (c->if_exprs[i]);
  gfc_free_expr (c->async_expr);
  gfc_free_expr (c->gang_num_expr);
  gfc_free_expr (c->gang_static_expr);
  gfc_free_expr (c->worker_expr);
  gfc_free_expr (c->vector_expr);
  gfc_free_expr (c->num_gangs_expr);
  gfc_free_expr (c->num_workers_expr);
  gfc_free_expr (c->vector_length_expr);
  for (i = 0; i < OMP_LIST_NUM; i++)
    gfc_free_omp_namelist (c->lists[i]);
  gfc_free_expr_list (c->wait_list);
  gfc_free_expr_list (c->tile_list);
  free (CONST_CAST (char *, c->critical_name));
  free (c);
}

/* Free oacc_declare structures.  */

void
gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc)
{
  struct gfc_oacc_declare *decl = oc;

  do
    {
      struct gfc_oacc_declare *next;

      next = decl->next;
      gfc_free_omp_clauses (decl->clauses);
      free (decl);
      decl = next;
    }
  while (decl);
}

/* Free expression list. */
void
gfc_free_expr_list (gfc_expr_list *list)
{
  gfc_expr_list *n;

  for (; list; list = n)
    {
      n = list->next;
      free (list);
    }
}

/* Free an !$omp declare simd construct list.  */

void
gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
{
  if (ods)
    {
      gfc_free_omp_clauses (ods->clauses);
      free (ods);
    }
}

void
gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
{
  while (list)
    {
      gfc_omp_declare_simd *current = list;
      list = list->next;
      gfc_free_omp_declare_simd (current);
    }
}

/* Free an !$omp declare reduction.  */

void
gfc_free_omp_udr (gfc_omp_udr *omp_udr)
{
  if (omp_udr)
    {
      gfc_free_omp_udr (omp_udr->next);
      gfc_free_namespace (omp_udr->combiner_ns);
      if (omp_udr->initializer_ns)
	gfc_free_namespace (omp_udr->initializer_ns);
      free (omp_udr);
    }
}


static gfc_omp_udr *
gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
{
  gfc_symtree *st;

  if (ns == NULL)
    ns = gfc_current_ns;
  do
    {
      gfc_omp_udr *omp_udr;

      st = gfc_find_symtree (ns->omp_udr_root, name);
      if (st != NULL)
	{
	  for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
	    if (ts == NULL)
	      return omp_udr;
	    else if (gfc_compare_types (&omp_udr->ts, ts))
	      {
		if (ts->type == BT_CHARACTER)
		  {
		    if (omp_udr->ts.u.cl->length == NULL)
		      return omp_udr;
		    if (ts->u.cl->length == NULL)
		      continue;
		    if (gfc_compare_expr (omp_udr->ts.u.cl->length,
					  ts->u.cl->length,
					  INTRINSIC_EQ) != 0)
		      continue;
		  }
		return omp_udr;
	      }
	}

      /* Don't escape an interface block.  */
      if (ns && !ns->has_import_set
	  && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
	break;

      ns = ns->parent;
    }
  while (ns != NULL);

  return NULL;
}


/* Match a variable/common block list and construct a namelist from it.  */

static match
gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
			     bool allow_common, bool *end_colon = NULL,
			     gfc_omp_namelist ***headp = NULL,
			     bool allow_sections = false)
{
  gfc_omp_namelist *head, *tail, *p;
  locus old_loc, cur_loc;
  char n[GFC_MAX_SYMBOL_LEN+1];
  gfc_symbol *sym;
  match m;
  gfc_symtree *st;

  head = tail = NULL;

  old_loc = gfc_current_locus;

  m = gfc_match (str);
  if (m != MATCH_YES)
    return m;

  for (;;)
    {
      cur_loc = gfc_current_locus;
      m = gfc_match_symbol (&sym, 1);
      switch (m)
	{
	case MATCH_YES:
	  gfc_expr *expr;
	  expr = NULL;
	  if (allow_sections && gfc_peek_ascii_char () == '(')
	    {
	      gfc_current_locus = cur_loc;
	      m = gfc_match_variable (&expr, 0);
	      switch (m)
		{
		case MATCH_ERROR:
		  goto cleanup;
		case MATCH_NO:
		  goto syntax;
		default:
		  break;
		}
	    }
	  gfc_set_sym_referenced (sym);
	  p = gfc_get_omp_namelist ();
	  if (head == NULL)
	    head = tail = p;
	  else
	    {
	      tail->next = p;
	      tail = tail->next;
	    }
	  tail->sym = sym;
	  tail->expr = expr;
	  tail->where = cur_loc;
	  goto next_item;
	case MATCH_NO:
	  break;
	case MATCH_ERROR:
	  goto cleanup;
	}

      if (!allow_common)
	goto syntax;

      m = gfc_match (" / %n /", n);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO)
	goto syntax;

      st = gfc_find_symtree (gfc_current_ns->common_root, n);
      if (st == NULL)
	{
	  gfc_error ("COMMON block /%s/ not found at %C", n);
	  goto cleanup;
	}
      for (sym = st->n.common->head; sym; sym = sym->common_next)
	{
	  gfc_set_sym_referenced (sym);
	  p = gfc_get_omp_namelist ();
	  if (head == NULL)
	    head = tail = p;
	  else
	    {
	      tail->next = p;
	      tail = tail->next;
	    }
	  tail->sym = sym;
	  tail->where = cur_loc;
	}

    next_item:
      if (end_colon && gfc_match_char (':') == MATCH_YES)
	{
	  *end_colon = true;
	  break;
	}
      if (gfc_match_char (')') == MATCH_YES)
	break;
      if (gfc_match_char (',') != MATCH_YES)
	goto syntax;
    }

  while (*list)
    list = &(*list)->next;

  *list = head;
  if (headp)
    *headp = list;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in OpenMP variable list at %C");

cleanup:
  gfc_free_omp_namelist (head);
  gfc_current_locus = old_loc;
  return MATCH_ERROR;
}

/* Match a variable/procedure/common block list and construct a namelist
   from it.  */

static match
gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
{
  gfc_omp_namelist *head, *tail, *p;
  locus old_loc, cur_loc;
  char n[GFC_MAX_SYMBOL_LEN+1];
  gfc_symbol *sym;
  match m;
  gfc_symtree *st;

  head = tail = NULL;

  old_loc = gfc_current_locus;

  m = gfc_match (str);
  if (m != MATCH_YES)
    return m;

  for (;;)
    {
      cur_loc = gfc_current_locus;
      m = gfc_match_symbol (&sym, 1);
      switch (m)
	{
	case MATCH_YES:
	  p = gfc_get_omp_namelist ();
	  if (head == NULL)
	    head = tail = p;
	  else
	    {
	      tail->next = p;
	      tail = tail->next;
	    }
	  tail->sym = sym;
	  tail->where = cur_loc;
	  goto next_item;
	case MATCH_NO:
	  break;
	case MATCH_ERROR:
	  goto cleanup;
	}

      m = gfc_match (" / %n /", n);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO)
	goto syntax;

      st = gfc_find_symtree (gfc_current_ns->common_root, n);
      if (st == NULL)
	{
	  gfc_error ("COMMON block /%s/ not found at %C", n);
	  goto cleanup;
	}
      p = gfc_get_omp_namelist ();
      if (head == NULL)
	head = tail = p;
      else
	{
	  tail->next = p;
	  tail = tail->next;
	}
      tail->u.common = st->n.common;
      tail->where = cur_loc;

    next_item:
      if (gfc_match_char (')') == MATCH_YES)
	break;
      if (gfc_match_char (',') != MATCH_YES)
	goto syntax;
    }

  while (*list)
    list = &(*list)->next;

  *list = head;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in OpenMP variable list at %C");

cleanup:
  gfc_free_omp_namelist (head);
  gfc_current_locus = old_loc;
  return MATCH_ERROR;
}

/* Match depend(sink : ...) construct a namelist from it.  */

static match
gfc_match_omp_depend_sink (gfc_omp_namelist **list)
{
  gfc_omp_namelist *head, *tail, *p;
  locus old_loc, cur_loc;
  gfc_symbol *sym;

  head = tail = NULL;

  old_loc = gfc_current_locus;

  for (;;)
    {
      cur_loc = gfc_current_locus;
      switch (gfc_match_symbol (&sym, 1))
	{
	case MATCH_YES:
	  gfc_set_sym_referenced (sym);
	  p = gfc_get_omp_namelist ();
	  if (head == NULL)
	    {
	      head = tail = p;
	      head->u.depend_op = OMP_DEPEND_SINK_FIRST;
	    }
	  else
	    {
	      tail->next = p;
	      tail = tail->next;
	      tail->u.depend_op = OMP_DEPEND_SINK;
	    }
	  tail->sym = sym;
	  tail->expr = NULL;
	  tail->where = cur_loc;
	  if (gfc_match_char ('+') == MATCH_YES)
	    {
	      if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
		goto syntax;
	    }
	  else if (gfc_match_char ('-') == MATCH_YES)
	    {
	      if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
		goto syntax;
	      tail->expr = gfc_uminus (tail->expr);
	    }
	  break;
	case MATCH_NO:
	  goto syntax;
	case MATCH_ERROR:
	  goto cleanup;
	}

      if (gfc_match_char (')') == MATCH_YES)
	break;
      if (gfc_match_char (',') != MATCH_YES)
	goto syntax;
    }

  while (*list)
    list = &(*list)->next;

  *list = head;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in OpenMP DEPEND SINK list at %C");

cleanup:
  gfc_free_omp_namelist (head);
  gfc_current_locus = old_loc;
  return MATCH_ERROR;
}

static match
match_oacc_expr_list (const char *str, gfc_expr_list **list,
		      bool allow_asterisk)
{
  gfc_expr_list *head, *tail, *p;
  locus old_loc;
  gfc_expr *expr;
  match m;

  head = tail = NULL;

  old_loc = gfc_current_locus;

  m = gfc_match (str);
  if (m != MATCH_YES)
    return m;

  for (;;)
    {
      m = gfc_match_expr (&expr);
      if (m == MATCH_YES || allow_asterisk)
	{
	  p = gfc_get_expr_list ();
	  if (head == NULL)
	    head = tail = p;
	  else
	    {
	      tail->next = p;
	      tail = tail->next;
	    }
	  if (m == MATCH_YES)
	    tail->expr = expr;
	  else if (gfc_match (" *") != MATCH_YES)
	    goto syntax;
	  goto next_item;
	}
      if (m == MATCH_ERROR)
	goto cleanup;
      goto syntax;

    next_item:
      if (gfc_match_char (')') == MATCH_YES)
	break;
      if (gfc_match_char (',') != MATCH_YES)
	goto syntax;
    }

  while (*list)
    list = &(*list)->next;

  *list = head;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in OpenACC expression list at %C");

cleanup:
  gfc_free_expr_list (head);
  gfc_current_locus = old_loc;
  return MATCH_ERROR;
}

static match
match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
{
  match ret = MATCH_YES;

  if (gfc_match (" ( ") != MATCH_YES)
    return MATCH_NO;

  if (gwv == GOMP_DIM_GANG)
    {
        /* The gang clause accepts two optional arguments, num and static.
	 The num argument may either be explicit (num: <val>) or
	 implicit without (<val> without num:).  */

      while (ret == MATCH_YES)
	{
	  if (gfc_match (" static :") == MATCH_YES)
	    {
	      if (cp->gang_static)
		return MATCH_ERROR;
	      else
		cp->gang_static = true;
	      if (gfc_match_char ('*') == MATCH_YES)
		cp->gang_static_expr = NULL;
	      else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
		return MATCH_ERROR;
	    }
	  else
	    {
	      if (cp->gang_num_expr)
		return MATCH_ERROR;

	      /* The 'num' argument is optional.  */
	      gfc_match (" num :");

	      if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
		return MATCH_ERROR;
	    }

	  ret = gfc_match (" , ");
	}
    }
  else if (gwv == GOMP_DIM_WORKER)
    {
      /* The 'num' argument is optional.  */
      gfc_match (" num :");

      if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
	return MATCH_ERROR;
    }
  else if (gwv == GOMP_DIM_VECTOR)
    {
      /* The 'length' argument is optional.  */
      gfc_match (" length :");

      if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
	return MATCH_ERROR;
    }
  else
    gfc_fatal_error ("Unexpected OpenACC parallelism.");

  return gfc_match (" )");
}

static match
gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
{
  gfc_omp_namelist *head = NULL;
  gfc_omp_namelist *tail, *p;
  locus old_loc;
  char n[GFC_MAX_SYMBOL_LEN+1];
  gfc_symbol *sym;
  match m;
  gfc_symtree *st;

  old_loc = gfc_current_locus;

  m = gfc_match (str);
  if (m != MATCH_YES)
    return m;

  m = gfc_match (" (");

  for (;;)
    {
      m = gfc_match_symbol (&sym, 0);
      switch (m)
	{
	case MATCH_YES:
	  if (sym->attr.in_common)
	    {
	      gfc_error_now ("Variable at %C is an element of a COMMON block");
	      goto cleanup;
	    }
	  gfc_set_sym_referenced (sym);
	  p = gfc_get_omp_namelist ();
	  if (head == NULL)
	    head = tail = p;
	  else
	    {
	      tail->next = p;
	      tail = tail->next;
	    }
	  tail->sym = sym;
	  tail->expr = NULL;
	  tail->where = gfc_current_locus;
	  goto next_item;
	case MATCH_NO:
	  break;

	case MATCH_ERROR:
	  goto cleanup;
	}

      m = gfc_match (" / %n /", n);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO || n[0] == '\0')
	goto syntax;

      st = gfc_find_symtree (gfc_current_ns->common_root, n);
      if (st == NULL)
	{
	  gfc_error ("COMMON block /%s/ not found at %C", n);
	  goto cleanup;
	}

      for (sym = st->n.common->head; sym; sym = sym->common_next)
	{
	  gfc_set_sym_referenced (sym);
	  p = gfc_get_omp_namelist ();
	  if (head == NULL)
	    head = tail = p;
	  else
	    {
	      tail->next = p;
	      tail = tail->next;
	    }
	  tail->sym = sym;
	  tail->where = gfc_current_locus;
	}

    next_item:
      if (gfc_match_char (')') == MATCH_YES)
	break;
      if (gfc_match_char (',') != MATCH_YES)
	goto syntax;
    }

  if (gfc_match_omp_eos () != MATCH_YES)
    {
      gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
      goto cleanup;
    }

  while (*list)
    list = &(*list)->next;
  *list = head;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in !$ACC DECLARE list at %C");

cleanup:
  gfc_current_locus = old_loc;
  return MATCH_ERROR;
}

/* OpenMP 4.5 clauses.  */
enum omp_mask1
{
  OMP_CLAUSE_PRIVATE,
  OMP_CLAUSE_FIRSTPRIVATE,
  OMP_CLAUSE_LASTPRIVATE,
  OMP_CLAUSE_COPYPRIVATE,
  OMP_CLAUSE_SHARED,
  OMP_CLAUSE_COPYIN,
  OMP_CLAUSE_REDUCTION,
  OMP_CLAUSE_IF,
  OMP_CLAUSE_NUM_THREADS,
  OMP_CLAUSE_SCHEDULE,
  OMP_CLAUSE_DEFAULT,
  OMP_CLAUSE_ORDERED,
  OMP_CLAUSE_COLLAPSE,
  OMP_CLAUSE_UNTIED,
  OMP_CLAUSE_FINAL,
  OMP_CLAUSE_MERGEABLE,
  OMP_CLAUSE_ALIGNED,
  OMP_CLAUSE_DEPEND,
  OMP_CLAUSE_INBRANCH,
  OMP_CLAUSE_LINEAR,
  OMP_CLAUSE_NOTINBRANCH,
  OMP_CLAUSE_PROC_BIND,
  OMP_CLAUSE_SAFELEN,
  OMP_CLAUSE_SIMDLEN,
  OMP_CLAUSE_UNIFORM,
  OMP_CLAUSE_DEVICE,
  OMP_CLAUSE_MAP,
  OMP_CLAUSE_TO,
  OMP_CLAUSE_FROM,
  OMP_CLAUSE_NUM_TEAMS,
  OMP_CLAUSE_THREAD_LIMIT,
  OMP_CLAUSE_DIST_SCHEDULE,
  OMP_CLAUSE_DEFAULTMAP,
  OMP_CLAUSE_GRAINSIZE,
  OMP_CLAUSE_HINT,
  OMP_CLAUSE_IS_DEVICE_PTR,
  OMP_CLAUSE_LINK,
  OMP_CLAUSE_NOGROUP,
  OMP_CLAUSE_NUM_TASKS,
  OMP_CLAUSE_PRIORITY,
  OMP_CLAUSE_SIMD,
  OMP_CLAUSE_THREADS,
  OMP_CLAUSE_USE_DEVICE_PTR,
  OMP_CLAUSE_NOWAIT,
  /* This must come last.  */
  OMP_MASK1_LAST
};

/* OpenACC 2.0 specific clauses. */
enum omp_mask2
{
  OMP_CLAUSE_ASYNC,
  OMP_CLAUSE_NUM_GANGS,
  OMP_CLAUSE_NUM_WORKERS,
  OMP_CLAUSE_VECTOR_LENGTH,
  OMP_CLAUSE_COPY,
  OMP_CLAUSE_COPYOUT,
  OMP_CLAUSE_CREATE,
  OMP_CLAUSE_PRESENT,
  OMP_CLAUSE_PRESENT_OR_COPY,
  OMP_CLAUSE_PRESENT_OR_COPYIN,
  OMP_CLAUSE_PRESENT_OR_COPYOUT,
  OMP_CLAUSE_PRESENT_OR_CREATE,
  OMP_CLAUSE_DEVICEPTR,
  OMP_CLAUSE_GANG,
  OMP_CLAUSE_WORKER,
  OMP_CLAUSE_VECTOR,
  OMP_CLAUSE_SEQ,
  OMP_CLAUSE_INDEPENDENT,
  OMP_CLAUSE_USE_DEVICE,
  OMP_CLAUSE_DEVICE_RESIDENT,
  OMP_CLAUSE_HOST_SELF,
  OMP_CLAUSE_WAIT,
  OMP_CLAUSE_DELETE,
  OMP_CLAUSE_AUTO,
  OMP_CLAUSE_TILE,
  /* This must come last.  */
  OMP_MASK2_LAST
};

struct omp_inv_mask;

/* Customized bitset for up to 128-bits.
   The two enums above provide bit numbers to use, and which of the
   two enums it is determines which of the two mask fields is used.
   Supported operations are defining a mask, like:
   #define XXX_CLAUSES \
     (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
   oring such bitsets together or removing selected bits:
   (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
   and testing individual bits:
   if (mask & OMP_CLAUSE_UUU)  */

struct omp_mask {
  const uint64_t mask1;
  const uint64_t mask2;
  inline omp_mask ();
  inline omp_mask (omp_mask1);
  inline omp_mask (omp_mask2);
  inline omp_mask (uint64_t, uint64_t);
  inline omp_mask operator| (omp_mask1) const;
  inline omp_mask operator| (omp_mask2) const;
  inline omp_mask operator| (omp_mask) const;
  inline omp_mask operator& (const omp_inv_mask &) const;
  inline bool operator& (omp_mask1) const;
  inline bool operator& (omp_mask2) const;
  inline omp_inv_mask operator~ () const;
};

struct omp_inv_mask : public omp_mask {
  inline omp_inv_mask (const omp_mask &);
};

omp_mask::omp_mask () : mask1 (0), mask2 (0)
{
}

omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
{
}

omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
{
}

omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
{
}

omp_mask
omp_mask::operator| (omp_mask1 m) const
{
  return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
}

omp_mask
omp_mask::operator| (omp_mask2 m) const
{
  return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
}

omp_mask
omp_mask::operator| (omp_mask m) const
{
  return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
}

omp_mask
omp_mask::operator& (const omp_inv_mask &m) const
{
  return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
}

bool
omp_mask::operator& (omp_mask1 m) const
{
  return (mask1 & (((uint64_t) 1) << m)) != 0;
}

bool
omp_mask::operator& (omp_mask2 m) const
{
  return (mask2 & (((uint64_t) 1) << m)) != 0;
}

omp_inv_mask
omp_mask::operator~ () const
{
  return omp_inv_mask (*this);
}

omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
{
}

/* Helper function for OpenACC and OpenMP clauses involving memory
   mapping.  */

static bool
gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op)
{
  gfc_omp_namelist **head = NULL;
  if (gfc_match_omp_variable_list ("", list, false, NULL, &head, true)
      == MATCH_YES)
    {
      gfc_omp_namelist *n;
      for (n = *head; n; n = n->next)
	n->u.map_op = map_op;
      return true;
    }

  return false;
}

/* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
   clauses that are allowed for a particular directive.  */

static match
gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
		       bool first = true, bool needs_space = true,
		       bool openacc = false)
{
  gfc_omp_clauses *c = gfc_get_omp_clauses ();
  locus old_loc;

  gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
  *cp = NULL;
  while (1)
    {
      if ((first || gfc_match_char (',') != MATCH_YES)
	  && (needs_space && gfc_match_space () != MATCH_YES))
	break;
      needs_space = false;
      first = false;
      gfc_gobble_whitespace ();
      bool end_colon;
      gfc_omp_namelist **head;
      old_loc = gfc_current_locus;
      char pc = gfc_peek_ascii_char ();
      switch (pc)
	{
	case 'a':
	  end_colon = false;
	  head = NULL;
	  if ((mask & OMP_CLAUSE_ALIGNED)
	      && gfc_match_omp_variable_list ("aligned (",
					      &c->lists[OMP_LIST_ALIGNED],
					      false, &end_colon,
					      &head) == MATCH_YES)
	    {
	      gfc_expr *alignment = NULL;
	      gfc_omp_namelist *n;

	      if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
		{
		  gfc_free_omp_namelist (*head);
		  gfc_current_locus = old_loc;
		  *head = NULL;
		  break;
		}
	      for (n = *head; n; n = n->next)
		if (n->next && alignment)
		  n->expr = gfc_copy_expr (alignment);
		else
		  n->expr = alignment;
	      continue;
	    }
	  if ((mask & OMP_CLAUSE_ASYNC)
	      && !c->async
	      && gfc_match ("async") == MATCH_YES)
	    {
	      c->async = true;
	      match m = gfc_match (" ( %e )", &c->async_expr);
	      if (m == MATCH_ERROR)
		{
		  gfc_current_locus = old_loc;
		  break;
		}
	      else if (m == MATCH_NO)
		{
		  c->async_expr
		    = gfc_get_constant_expr (BT_INTEGER,
					     gfc_default_integer_kind,
					     &gfc_current_locus);
		  mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
		  needs_space = true;
		}
	      continue;
	    }
	  if ((mask & OMP_CLAUSE_AUTO)
	      && !c->par_auto
	      && gfc_match ("auto") == MATCH_YES)
	    {
	      c->par_auto = true;
	      needs_space = true;
	      continue;
	    }
	  break;
	case 'c':
	  if ((mask & OMP_CLAUSE_COLLAPSE)
	      && !c->collapse)
	    {
	      gfc_expr *cexpr = NULL;
	      match m = gfc_match ("collapse ( %e )", &cexpr);

	      if (m == MATCH_YES)
		{
		  int collapse;
		  if (gfc_extract_int (cexpr, &collapse, -1))
		    collapse = 1;
		  else if (collapse <= 0)
		    {
		      gfc_error_now ("COLLAPSE clause argument not"
				     " constant positive integer at %C");
		      collapse = 1;
		    }
		  c->collapse = collapse;
		  gfc_free_expr (cexpr);
		  continue;
		}
	    }
	  if ((mask & OMP_CLAUSE_COPY)
	      && gfc_match ("copy ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_FORCE_TOFROM))
	    continue;
	  if (mask & OMP_CLAUSE_COPYIN)
	    {
	      if (openacc)
		{
		  if (gfc_match ("copyin ( ") == MATCH_YES
		      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
						   OMP_MAP_FORCE_TO))
		    continue;
		}
	      else if (gfc_match_omp_variable_list ("copyin (",
						    &c->lists[OMP_LIST_COPYIN],
						    true) == MATCH_YES)
		continue;
	    }
	  if ((mask & OMP_CLAUSE_COPYOUT)
	      && gfc_match ("copyout ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_FORCE_FROM))
	    continue;
	  if ((mask & OMP_CLAUSE_COPYPRIVATE)
	      && gfc_match_omp_variable_list ("copyprivate (",
					      &c->lists[OMP_LIST_COPYPRIVATE],
					      true) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_CREATE)
	      && gfc_match ("create ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_FORCE_ALLOC))
	    continue;
	  break;
	case 'd':
	  if ((mask & OMP_CLAUSE_DEFAULT)
	      && c->default_sharing == OMP_DEFAULT_UNKNOWN)
	    {
	      if (gfc_match ("default ( none )") == MATCH_YES)
		c->default_sharing = OMP_DEFAULT_NONE;
	      else if (openacc)
		{
		  if (gfc_match ("default ( present )") == MATCH_YES)
		    c->default_sharing = OMP_DEFAULT_PRESENT;
		}
	      else
		{
		  if (gfc_match ("default ( firstprivate )") == MATCH_YES)
		    c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
		  else if (gfc_match ("default ( private )") == MATCH_YES)
		    c->default_sharing = OMP_DEFAULT_PRIVATE;
		  else if (gfc_match ("default ( shared )") == MATCH_YES)
		    c->default_sharing = OMP_DEFAULT_SHARED;
		}
	      if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
		continue;
	    }
	  if ((mask & OMP_CLAUSE_DEFAULTMAP)
	      && !c->defaultmap
	      && gfc_match ("defaultmap ( tofrom : scalar )") == MATCH_YES)
	    {
	      c->defaultmap = true;
	      continue;
	    }
	  if ((mask & OMP_CLAUSE_DELETE)
	      && gfc_match ("delete ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_DELETE))
	    continue;
	  if ((mask & OMP_CLAUSE_DEPEND)
	      && gfc_match ("depend ( ") == MATCH_YES)
	    {
	      match m = MATCH_YES;
	      gfc_omp_depend_op depend_op = OMP_DEPEND_OUT;
	      if (gfc_match ("inout") == MATCH_YES)
		depend_op = OMP_DEPEND_INOUT;
	      else if (gfc_match ("in") == MATCH_YES)
		depend_op = OMP_DEPEND_IN;
	      else if (gfc_match ("out") == MATCH_YES)
		depend_op = OMP_DEPEND_OUT;
	      else if (!c->depend_source
		       && gfc_match ("source )") == MATCH_YES)
		{
		  c->depend_source = true;
		  continue;
		}
	      else if (gfc_match ("sink : ") == MATCH_YES)
		{
		  if (gfc_match_omp_depend_sink (&c->lists[OMP_LIST_DEPEND])
		      == MATCH_YES)
		    continue;
		  m = MATCH_NO;
		}
	      else
		m = MATCH_NO;
	      head = NULL;
	      if (m == MATCH_YES
		  && gfc_match_omp_variable_list (" : ",
						  &c->lists[OMP_LIST_DEPEND],
						  false, NULL, &head,
						  true) == MATCH_YES)
		{
		  gfc_omp_namelist *n;
		  for (n = *head; n; n = n->next)
		    n->u.depend_op = depend_op;
		  continue;
		}
	      else
		gfc_current_locus = old_loc;
	    }
	  if ((mask & OMP_CLAUSE_DEVICE)
	      && !openacc
	      && c->device == NULL
	      && gfc_match ("device ( %e )", &c->device) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_DEVICE)
	      && openacc
	      && gfc_match ("device ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_FORCE_TO))
	    continue;
	  if ((mask & OMP_CLAUSE_DEVICEPTR)
	      && gfc_match ("deviceptr ( ") == MATCH_YES)
	    {
	      gfc_omp_namelist **list = &c->lists[OMP_LIST_MAP];
	      gfc_omp_namelist **head = NULL;
	      if (gfc_match_omp_variable_list ("", list, true, NULL,
					       &head, false) == MATCH_YES)
		{
		  gfc_omp_namelist *n;
		  for (n = *head; n; n = n->next)
		    n->u.map_op = OMP_MAP_FORCE_DEVICEPTR;
		  continue;
		}
	    }
	  if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
	      && gfc_match_omp_variable_list
		   ("device_resident (",
		    &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
	      && c->dist_sched_kind == OMP_SCHED_NONE
	      && gfc_match ("dist_schedule ( static") == MATCH_YES)
	    {
	      match m = MATCH_NO;
	      c->dist_sched_kind = OMP_SCHED_STATIC;
	      m = gfc_match (" , %e )", &c->dist_chunk_size);
	      if (m != MATCH_YES)
		m = gfc_match_char (')');
	      if (m != MATCH_YES)
		{
		  c->dist_sched_kind = OMP_SCHED_NONE;
		  gfc_current_locus = old_loc;
		}
	      else
		continue;
	    }
	  break;
	case 'f':
	  if ((mask & OMP_CLAUSE_FINAL)
	      && c->final_expr == NULL
	      && gfc_match ("final ( %e )", &c->final_expr) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
	      && gfc_match_omp_variable_list ("firstprivate (",
					      &c->lists[OMP_LIST_FIRSTPRIVATE],
					      true) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_FROM)
	      && gfc_match_omp_variable_list ("from (",
					      &c->lists[OMP_LIST_FROM], false,
					      NULL, &head, true) == MATCH_YES)
	    continue;
	  break;
	case 'g':
	  if ((mask & OMP_CLAUSE_GANG)
	      && !c->gang
	      && gfc_match ("gang") == MATCH_YES)
	    {
	      c->gang = true;
	      match m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
	      if (m == MATCH_ERROR)
		{
		  gfc_current_locus = old_loc;
		  break;
		}
	      else if (m == MATCH_NO)
		needs_space = true;
	      continue;
	    }
	  if ((mask & OMP_CLAUSE_GRAINSIZE)
	      && c->grainsize == NULL
	      && gfc_match ("grainsize ( %e )", &c->grainsize) == MATCH_YES)
	    continue;
	  break;
	case 'h':
	  if ((mask & OMP_CLAUSE_HINT)
	      && c->hint == NULL
	      && gfc_match ("hint ( %e )", &c->hint) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_HOST_SELF)
	      && gfc_match ("host ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_FORCE_FROM))
	    continue;
	  break;
	case 'i':
	  if ((mask & OMP_CLAUSE_IF)
	      && c->if_expr == NULL
	      && gfc_match ("if ( ") == MATCH_YES)
	    {
	      if (gfc_match ("%e )", &c->if_expr) == MATCH_YES)
		continue;
	      if (!openacc)
		{
		  /* This should match the enum gfc_omp_if_kind order.  */
		  static const char *ifs[OMP_IF_LAST] = {
		    " parallel : %e )",
		    " task : %e )",
		    " taskloop : %e )",
		    " target : %e )",
		    " target data : %e )",
		    " target update : %e )",
		    " target enter data : %e )",
		    " target exit data : %e )" };
		  int i;
		  for (i = 0; i < OMP_IF_LAST; i++)
		    if (c->if_exprs[i] == NULL
			&& gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
		      break;
		  if (i < OMP_IF_LAST)
		    continue;
		}
	      gfc_current_locus = old_loc;
	    }
	  if ((mask & OMP_CLAUSE_INBRANCH)
	      && !c->inbranch
	      && !c->notinbranch
	      && gfc_match ("inbranch") == MATCH_YES)
	    {
	      c->inbranch = needs_space = true;
	      continue;
	    }
	  if ((mask & OMP_CLAUSE_INDEPENDENT)
	      && !c->independent
	      && gfc_match ("independent") == MATCH_YES)
	    {
	      c->independent = true;
	      needs_space = true;
	      continue;
	    }
	  if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
	      && gfc_match_omp_variable_list
		   ("is_device_ptr (",
		    &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
	    continue;
	  break;
	case 'l':
	  if ((mask & OMP_CLAUSE_LASTPRIVATE)
	      && gfc_match_omp_variable_list ("lastprivate (",
					      &c->lists[OMP_LIST_LASTPRIVATE],
					      true) == MATCH_YES)
	    continue;
	  end_colon = false;
	  head = NULL;
	  if ((mask & OMP_CLAUSE_LINEAR)
	      && gfc_match ("linear (") == MATCH_YES)
	    {
	      gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
	      gfc_expr *step = NULL;

	      if (gfc_match_omp_variable_list (" ref (",
					       &c->lists[OMP_LIST_LINEAR],
					       false, NULL, &head)
		  == MATCH_YES)
		linear_op = OMP_LINEAR_REF;
	      else if (gfc_match_omp_variable_list (" val (",
						    &c->lists[OMP_LIST_LINEAR],
						    false, NULL, &head)
		       == MATCH_YES)
		linear_op = OMP_LINEAR_VAL;
	      else if (gfc_match_omp_variable_list (" uval (",
						    &c->lists[OMP_LIST_LINEAR],
						    false, NULL, &head)
		       == MATCH_YES)
		linear_op = OMP_LINEAR_UVAL;
	      else if (gfc_match_omp_variable_list ("",
						    &c->lists[OMP_LIST_LINEAR],
						    false, &end_colon, &head)
		       == MATCH_YES)
		linear_op = OMP_LINEAR_DEFAULT;
	      else
		{
		  gfc_current_locus = old_loc;
		  break;
		}
	      if (linear_op != OMP_LINEAR_DEFAULT)
		{
		  if (gfc_match (" :") == MATCH_YES)
		    end_colon = true;
		  else if (gfc_match (" )") != MATCH_YES)
		    {
		      gfc_free_omp_namelist (*head);
		      gfc_current_locus = old_loc;
		      *head = NULL;
		      break;
		    }
		}
	      if (end_colon && gfc_match (" %e )", &step) != MATCH_YES)
		{
		  gfc_free_omp_namelist (*head);
		  gfc_current_locus = old_loc;
		  *head = NULL;
		  break;
		}
	      else if (!end_colon)
		{
		  step = gfc_get_constant_expr (BT_INTEGER,
						gfc_default_integer_kind,
						&old_loc);
		  mpz_set_si (step->value.integer, 1);
		}
	      (*head)->expr = step;
	      if (linear_op != OMP_LINEAR_DEFAULT)
		for (gfc_omp_namelist *n = *head; n; n = n->next)
		  n->u.linear_op = linear_op;
	      continue;
	    }
	  if ((mask & OMP_CLAUSE_LINK)
	      && openacc
	      && (gfc_match_oacc_clause_link ("link (",
					      &c->lists[OMP_LIST_LINK])
		  == MATCH_YES))
	    continue;
	  else if ((mask & OMP_CLAUSE_LINK)
		   && !openacc
		   && (gfc_match_omp_to_link ("link (",
					      &c->lists[OMP_LIST_LINK])
		       == MATCH_YES))
	    continue;
	  break;
	case 'm':
	  if ((mask & OMP_CLAUSE_MAP)
	      && gfc_match ("map ( ") == MATCH_YES)
	    {
	      locus old_loc2 = gfc_current_locus;
	      bool always = false;
	      gfc_omp_map_op map_op = OMP_MAP_TOFROM;
	      if (gfc_match ("always , ") == MATCH_YES)
		always = true;
	      if (gfc_match ("alloc : ") == MATCH_YES)
		map_op = OMP_MAP_ALLOC;
	      else if (gfc_match ("tofrom : ") == MATCH_YES)
		map_op = always ? OMP_MAP_ALWAYS_TOFROM : OMP_MAP_TOFROM;
	      else if (gfc_match ("to : ") == MATCH_YES)
		map_op = always ? OMP_MAP_ALWAYS_TO : OMP_MAP_TO;
	      else if (gfc_match ("from : ") == MATCH_YES)
		map_op = always ? OMP_MAP_ALWAYS_FROM : OMP_MAP_FROM;
	      else if (gfc_match ("release : ") == MATCH_YES)
		map_op = OMP_MAP_RELEASE;
	      else if (gfc_match ("delete : ") == MATCH_YES)
		map_op = OMP_MAP_DELETE;
	      else if (always)
		{
		  gfc_current_locus = old_loc2;
		  always = false;
		}
	      head = NULL;
	      if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
					       false, NULL, &head,
					       true) == MATCH_YES)
		{
		  gfc_omp_namelist *n;
		  for (n = *head; n; n = n->next)
		    n->u.map_op = map_op;
		  continue;
		}
	      else
		gfc_current_locus = old_loc;
	    }
	  if ((mask & OMP_CLAUSE_MERGEABLE) && !c->mergeable
	      && gfc_match ("mergeable") == MATCH_YES)
	    {
	      c->mergeable = needs_space = true;
	      continue;
	    }
	  break;
	case 'n':
	  if ((mask & OMP_CLAUSE_NOGROUP)
	      && !c->nogroup
	      && gfc_match ("nogroup") == MATCH_YES)
	    {
	      c->nogroup = needs_space = true;
	      continue;
	    }
	  if ((mask & OMP_CLAUSE_NOTINBRANCH)
	      && !c->notinbranch
	      && !c->inbranch
	      && gfc_match ("notinbranch") == MATCH_YES)
	    {
	      c->notinbranch = needs_space = true;
	      continue;
	    }
	  if ((mask & OMP_CLAUSE_NOWAIT)
	      && !c->nowait
	      && gfc_match ("nowait") == MATCH_YES)
	    {
	      c->nowait = needs_space = true;
	      continue;
	    }
	  if ((mask & OMP_CLAUSE_NUM_GANGS)
	      && c->num_gangs_expr == NULL
	      && gfc_match ("num_gangs ( %e )",
			    &c->num_gangs_expr) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_NUM_TASKS)
	      && c->num_tasks == NULL
	      && gfc_match ("num_tasks ( %e )", &c->num_tasks) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_NUM_TEAMS)
	      && c->num_teams == NULL
	      && gfc_match ("num_teams ( %e )", &c->num_teams) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_NUM_THREADS)
	      && c->num_threads == NULL
	      && (gfc_match ("num_threads ( %e )", &c->num_threads)
		  == MATCH_YES))
	    continue;
	  if ((mask & OMP_CLAUSE_NUM_WORKERS)
	      && c->num_workers_expr == NULL
	      && gfc_match ("num_workers ( %e )",
			    &c->num_workers_expr) == MATCH_YES)
	    continue;
	  break;
	case 'o':
	  if ((mask & OMP_CLAUSE_ORDERED)
	      && !c->ordered
	      && gfc_match ("ordered") == MATCH_YES)
	    {
	      gfc_expr *cexpr = NULL;
	      match m = gfc_match (" ( %e )", &cexpr);

	      c->ordered = true;
	      if (m == MATCH_YES)
		{
		  int ordered = 0;
		  if (gfc_extract_int (cexpr, &ordered, -1))
		    ordered = 0;
		  else if (ordered <= 0)
		    {
		      gfc_error_now ("ORDERED clause argument not"
				     " constant positive integer at %C");
		      ordered = 0;
		    }
		  c->orderedc = ordered;
		  gfc_free_expr (cexpr);
		  continue;
		}

	      needs_space = true;
	      continue;
	    }
	  break;
	case 'p':
	  if ((mask & OMP_CLAUSE_PRESENT_OR_COPY)
	      && gfc_match ("pcopy ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_TOFROM))
	    continue;
	  if ((mask & OMP_CLAUSE_PRESENT_OR_COPYIN)
	      && gfc_match ("pcopyin ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_TO))
	    continue;
	  if ((mask & OMP_CLAUSE_PRESENT_OR_COPYOUT)
	      && gfc_match ("pcopyout ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_FROM))
	    continue;
	  if ((mask & OMP_CLAUSE_PRESENT_OR_CREATE)
	      && gfc_match ("pcreate ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_ALLOC))
	    continue;
	  if ((mask & OMP_CLAUSE_PRESENT)
	      && gfc_match ("present ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_FORCE_PRESENT))
	    continue;
	  if ((mask & OMP_CLAUSE_PRESENT_OR_COPY)
	      && gfc_match ("present_or_copy ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_TOFROM))
	    continue;
	  if ((mask & OMP_CLAUSE_PRESENT_OR_COPYIN)
	      && gfc_match ("present_or_copyin ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_TO))
	    continue;
	  if ((mask & OMP_CLAUSE_PRESENT_OR_COPYOUT)
	      && gfc_match ("present_or_copyout ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_FROM))
	    continue;
	  if ((mask & OMP_CLAUSE_PRESENT_OR_CREATE)
	      && gfc_match ("present_or_create ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_ALLOC))
	    continue;
	  if ((mask & OMP_CLAUSE_PRIORITY)
	      && c->priority == NULL
	      && gfc_match ("priority ( %e )", &c->priority) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_PRIVATE)
	      && gfc_match_omp_variable_list ("private (",
					      &c->lists[OMP_LIST_PRIVATE],
					      true) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_PROC_BIND)
	      && c->proc_bind == OMP_PROC_BIND_UNKNOWN)
	    {
	      if (gfc_match ("proc_bind ( master )") == MATCH_YES)
		c->proc_bind = OMP_PROC_BIND_MASTER;
	      else if (gfc_match ("proc_bind ( spread )") == MATCH_YES)
		c->proc_bind = OMP_PROC_BIND_SPREAD;
	      else if (gfc_match ("proc_bind ( close )") == MATCH_YES)
		c->proc_bind = OMP_PROC_BIND_CLOSE;
	      if (c->proc_bind != OMP_PROC_BIND_UNKNOWN)
		continue;
	    }
	  break;
	case 'r':
	  if ((mask & OMP_CLAUSE_REDUCTION)
	      && gfc_match ("reduction ( ") == MATCH_YES)
	    {
	      gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
	      char buffer[GFC_MAX_SYMBOL_LEN + 3];
	      if (gfc_match_char ('+') == MATCH_YES)
		rop = OMP_REDUCTION_PLUS;
	      else if (gfc_match_char ('*') == MATCH_YES)
		rop = OMP_REDUCTION_TIMES;
	      else if (gfc_match_char ('-') == MATCH_YES)
		rop = OMP_REDUCTION_MINUS;
	      else if (gfc_match (".and.") == MATCH_YES)
		rop = OMP_REDUCTION_AND;
	      else if (gfc_match (".or.") == MATCH_YES)
		rop = OMP_REDUCTION_OR;
	      else if (gfc_match (".eqv.") == MATCH_YES)
		rop = OMP_REDUCTION_EQV;
	      else if (gfc_match (".neqv.") == MATCH_YES)
		rop = OMP_REDUCTION_NEQV;
	      if (rop != OMP_REDUCTION_NONE)
		snprintf (buffer, sizeof buffer, "operator %s",
			  gfc_op2string ((gfc_intrinsic_op) rop));
	      else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
		{
		  buffer[0] = '.';
		  strcat (buffer, ".");
		}
	      else if (gfc_match_name (buffer) == MATCH_YES)
		{
		  gfc_symbol *sym;
		  const char *n = buffer;

		  gfc_find_symbol (buffer, NULL, 1, &sym);
		  if (sym != NULL)
		    {
		      if (sym->attr.intrinsic)
			n = sym->name;
		      else if ((sym->attr.flavor != FL_UNKNOWN
				&& sym->attr.flavor != FL_PROCEDURE)
			       || sym->attr.external
			       || sym->attr.generic
			       || sym->attr.entry
			       || sym->attr.result
			       || sym->attr.dummy
			       || sym->attr.subroutine
			       || sym->attr.pointer
			       || sym->attr.target
			       || sym->attr.cray_pointer
			       || sym->attr.cray_pointee
			       || (sym->attr.proc != PROC_UNKNOWN
				   && sym->attr.proc != PROC_INTRINSIC)
			       || sym->attr.if_source != IFSRC_UNKNOWN
			       || sym == sym->ns->proc_name)
			{
			  sym = NULL;
			  n = NULL;
			}
		      else
			n = sym->name;
		    }
		  if (n == NULL)
		    rop = OMP_REDUCTION_NONE;
		  else if (strcmp (n, "max") == 0)
		    rop = OMP_REDUCTION_MAX;
		  else if (strcmp (n, "min") == 0)
		    rop = OMP_REDUCTION_MIN;
		  else if (strcmp (n, "iand") == 0)
		    rop = OMP_REDUCTION_IAND;
		  else if (strcmp (n, "ior") == 0)
		    rop = OMP_REDUCTION_IOR;
		  else if (strcmp (n, "ieor") == 0)
		    rop = OMP_REDUCTION_IEOR;
		  if (rop != OMP_REDUCTION_NONE
		      && sym != NULL
		      && ! sym->attr.intrinsic
		      && ! sym->attr.use_assoc
		      && ((sym->attr.flavor == FL_UNKNOWN
			  && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
					      sym->name, NULL))
			  || !gfc_add_intrinsic (&sym->attr, NULL)))
		    rop = OMP_REDUCTION_NONE;
		}
	      else
		buffer[0] = '\0';
	      gfc_omp_udr *udr
		= (buffer[0]
		   ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL) : NULL);
	      gfc_omp_namelist **head = NULL;
	      if (rop == OMP_REDUCTION_NONE && udr)
		rop = OMP_REDUCTION_USER;

	      if (gfc_match_omp_variable_list (" :",
					       &c->lists[OMP_LIST_REDUCTION],
					       false, NULL, &head,
					       openacc) == MATCH_YES)
		{
		  gfc_omp_namelist *n;
		  if (rop == OMP_REDUCTION_NONE)
		    {
		      n = *head;
		      *head = NULL;
		      gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
				     "at %L", buffer, &old_loc);
		      gfc_free_omp_namelist (n);
		    }
		  else
		    for (n = *head; n; n = n->next)
		      {
			n->u.reduction_op = rop;
			if (udr)
			  {
			    n->udr = gfc_get_omp_namelist_udr ();
			    n->udr->udr = udr;
			  }
		      }
		  continue;
		}
	      else
		gfc_current_locus = old_loc;
	    }
	  break;
	case 's':
	  if ((mask & OMP_CLAUSE_SAFELEN)
	      && c->safelen_expr == NULL
	      && gfc_match ("safelen ( %e )", &c->safelen_expr) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_SCHEDULE)
	      && c->sched_kind == OMP_SCHED_NONE
	      && gfc_match ("schedule ( ") == MATCH_YES)
	    {
	      int nmodifiers = 0;
	      locus old_loc2 = gfc_current_locus;
	      do
		{
		  if (!c->sched_simd
		      && gfc_match ("simd") == MATCH_YES)
		    {
		      c->sched_simd = true;
		      nmodifiers++;
		    }
		  else if (!c->sched_monotonic
			   && !c->sched_nonmonotonic
			   && gfc_match ("monotonic") == MATCH_YES)
		    {
		      c->sched_monotonic = true;
		      nmodifiers++;
		    }
		  else if (!c->sched_monotonic
			   && !c->sched_nonmonotonic
			   && gfc_match ("nonmonotonic") == MATCH_YES)
		    {
		      c->sched_nonmonotonic = true;
		      nmodifiers++;
		    }
		  else
		    {
		      if (nmodifiers)
			gfc_current_locus = old_loc2;
		      break;
		    }
		  if (nmodifiers == 0
		      && gfc_match (" , ") == MATCH_YES)
		    continue;
		  else if (gfc_match (" : ") == MATCH_YES)
		    break;
		  gfc_current_locus = old_loc2;
		  break;
		}
	      while (1);
	      if (gfc_match ("static") == MATCH_YES)
		c->sched_kind = OMP_SCHED_STATIC;
	      else if (gfc_match ("dynamic") == MATCH_YES)
		c->sched_kind = OMP_SCHED_DYNAMIC;
	      else if (gfc_match ("guided") == MATCH_YES)
		c->sched_kind = OMP_SCHED_GUIDED;
	      else if (gfc_match ("runtime") == MATCH_YES)
		c->sched_kind = OMP_SCHED_RUNTIME;
	      else if (gfc_match ("auto") == MATCH_YES)
		c->sched_kind = OMP_SCHED_AUTO;
	      if (c->sched_kind != OMP_SCHED_NONE)
		{
		  match m = MATCH_NO;
		  if (c->sched_kind != OMP_SCHED_RUNTIME
		      && c->sched_kind != OMP_SCHED_AUTO)
		    m = gfc_match (" , %e )", &c->chunk_size);
		  if (m != MATCH_YES)
		    m = gfc_match_char (')');
		  if (m != MATCH_YES)
		    c->sched_kind = OMP_SCHED_NONE;
		}
	      if (c->sched_kind != OMP_SCHED_NONE)
		continue;
	      else
		gfc_current_locus = old_loc;
	    }
	  if ((mask & OMP_CLAUSE_HOST_SELF)
	      && gfc_match ("self ( ") == MATCH_YES
	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
					   OMP_MAP_FORCE_FROM))
	    continue;
	  if ((mask & OMP_CLAUSE_SEQ)
	      && !c->seq
	      && gfc_match ("seq") == MATCH_YES)
	    {
	      c->seq = true;
	      needs_space = true;
	      continue;
	    }
	  if ((mask & OMP_CLAUSE_SHARED)
	      && gfc_match_omp_variable_list ("shared (",
					      &c->lists[OMP_LIST_SHARED],
					      true) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_SIMDLEN)
	      && c->simdlen_expr == NULL
	      && gfc_match ("simdlen ( %e )", &c->simdlen_expr) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_SIMD)
	      && !c->simd
	      && gfc_match ("simd") == MATCH_YES)
	    {
	      c->simd = needs_space = true;
	      continue;
	    }
	  break;
	case 't':
	  if ((mask & OMP_CLAUSE_THREAD_LIMIT)
	      && c->thread_limit == NULL
	      && gfc_match ("thread_limit ( %e )",
			    &c->thread_limit) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_THREADS)
	      && !c->threads
	      && gfc_match ("threads") == MATCH_YES)
	    {
	      c->threads = needs_space = true;
	      continue;
	    }
	  if ((mask & OMP_CLAUSE_TILE)
	      && !c->tile_list
	      && match_oacc_expr_list ("tile (", &c->tile_list,
				       true) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
	    {
	      if (gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO])
		  == MATCH_YES)
		continue;
	    }
	  else if ((mask & OMP_CLAUSE_TO)
	      && gfc_match_omp_variable_list ("to (",
					      &c->lists[OMP_LIST_TO], false,
					      NULL, &head, true) == MATCH_YES)
	    continue;
	  break;
	case 'u':
	  if ((mask & OMP_CLAUSE_UNIFORM)
	      && gfc_match_omp_variable_list ("uniform (",
					      &c->lists[OMP_LIST_UNIFORM],
					      false) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_UNTIED)
	      && !c->untied
	      && gfc_match ("untied") == MATCH_YES)
	    {
	      c->untied = needs_space = true;
	      continue;
	    }
	  if ((mask & OMP_CLAUSE_USE_DEVICE)
	      && gfc_match_omp_variable_list ("use_device (",
					      &c->lists[OMP_LIST_USE_DEVICE],
					      true) == MATCH_YES)
	    continue;
	  if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
	      && gfc_match_omp_variable_list
		   ("use_device_ptr (",
		    &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
	    continue;
	  break;
	case 'v':
	  /* VECTOR_LENGTH must be matched before VECTOR, because the latter
	     doesn't unconditionally match '('.  */
	  if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
	      && c->vector_length_expr == NULL
	      && (gfc_match ("vector_length ( %e )", &c->vector_length_expr)
		  == MATCH_YES))
	    continue;
	  if ((mask & OMP_CLAUSE_VECTOR)
	      && !c->vector
	      && gfc_match ("vector") == MATCH_YES)
	    {
	      c->vector = true;
	      match m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
	      if (m == MATCH_ERROR)
		{
		  gfc_current_locus = old_loc;
		  break;
		}
	      if (m == MATCH_NO)
		needs_space = true;
	      continue;
	    }
	  break;
	case 'w':
	  if ((mask & OMP_CLAUSE_WAIT)
	      && !c->wait
	      && gfc_match ("wait") == MATCH_YES)
	    {
	      c->wait = true;
	      match m = match_oacc_expr_list (" (", &c->wait_list, false);
	      if (m == MATCH_ERROR)
		{
		  gfc_current_locus = old_loc;
		  break;
		}
	      else if (m == MATCH_NO)
		needs_space = true;
	      continue;
	    }
	  if ((mask & OMP_CLAUSE_WORKER)
	      && !c->worker
	      && gfc_match ("worker") == MATCH_YES)
	    {
	      c->worker = true;
	      match m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
	      if (m == MATCH_ERROR)
		{
		  gfc_current_locus = old_loc;
		  break;
		}
	      else if (m == MATCH_NO)
		needs_space = true;
	      continue;
	    }
	  break;
	}
      break;
    }

  if (gfc_match_omp_eos () != MATCH_YES)
    {
      gfc_free_omp_clauses (c);
      return MATCH_ERROR;
    }

  *cp = c;
  return MATCH_YES;
}


#define OACC_PARALLEL_CLAUSES \
  (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS	      \
   | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
   | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT		      \
   | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY      \
   | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT	      \
   | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE \
   | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
#define OACC_KERNELS_CLAUSES \
  (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS	      \
   | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
   | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT		      \
   | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY      \
   | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT	      \
   | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
#define OACC_DATA_CLAUSES \
  (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR  | OMP_CLAUSE_COPY	      \
   | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE		      \
   | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY			      \
   | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT	      \
   | OMP_CLAUSE_PRESENT_OR_CREATE)
#define OACC_LOOP_CLAUSES \
  (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER	      \
   | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT	      \
   | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO	      \
   | OMP_CLAUSE_TILE)
#define OACC_PARALLEL_LOOP_CLAUSES \
  (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
#define OACC_KERNELS_LOOP_CLAUSES \
  (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
#define OACC_HOST_DATA_CLAUSES omp_mask (OMP_CLAUSE_USE_DEVICE)
#define OACC_DECLARE_CLAUSES \
  (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT	      \
   | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT    \
   | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY			      \
   | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT	      \
   | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_LINK)
#define OACC_UPDATE_CLAUSES \
  (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF	      \
   | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT)
#define OACC_ENTER_DATA_CLAUSES \
  (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT	      \
   | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT_OR_COPYIN     \
   | OMP_CLAUSE_PRESENT_OR_CREATE)
#define OACC_EXIT_DATA_CLAUSES \
  (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT	      \
   | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE)
#define OACC_WAIT_CLAUSES \
  omp_mask (OMP_CLAUSE_ASYNC)
#define OACC_ROUTINE_CLAUSES \
  (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR	      \
   | OMP_CLAUSE_SEQ)


static match
match_acc (gfc_exec_op op, const omp_mask mask)
{
  gfc_omp_clauses *c;
  if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
    return MATCH_ERROR;
  new_st.op = op;
  new_st.ext.omp_clauses = c;
  return MATCH_YES;
}

match
gfc_match_oacc_parallel_loop (void)
{
  return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
}


match
gfc_match_oacc_parallel (void)
{
  return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
}


match
gfc_match_oacc_kernels_loop (void)
{
  return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
}


match
gfc_match_oacc_kernels (void)
{
  return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
}


match
gfc_match_oacc_data (void)
{
  return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
}


match
gfc_match_oacc_host_data (void)
{
  return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
}


match
gfc_match_oacc_loop (void)
{
  return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
}


match
gfc_match_oacc_declare (void)
{
  gfc_omp_clauses *c;
  gfc_omp_namelist *n;
  gfc_namespace *ns = gfc_current_ns;
  gfc_oacc_declare *new_oc;
  bool module_var = false;
  locus where = gfc_current_locus;

  if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
      != MATCH_YES)
    return MATCH_ERROR;

  for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
    n->sym->attr.oacc_declare_device_resident = 1;

  for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
    n->sym->attr.oacc_declare_link = 1;

  for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
    {
      gfc_symbol *s = n->sym;

      if (s->ns->proc_name && s->ns->proc_name->attr.proc == PROC_MODULE)
	{
	  if (n->u.map_op != OMP_MAP_FORCE_ALLOC
	      && n->u.map_op != OMP_MAP_FORCE_TO)
	    {
	      gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
			 &where);
	      return MATCH_ERROR;
	    }

	  module_var = true;
	}

      if (s->attr.use_assoc)
	{
	  gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
		     &where);
	  return MATCH_ERROR;
	}

      if ((s->attr.dimension || s->attr.codimension)
	  && s->attr.dummy && s->as->type != AS_EXPLICIT)
	{
	  gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
		     &where);
	  return MATCH_ERROR;
	}

      switch (n->u.map_op)
	{
	  case OMP_MAP_FORCE_ALLOC:
	    s->attr.oacc_declare_create = 1;
	    break;

	  case OMP_MAP_FORCE_TO:
	    s->attr.oacc_declare_copyin = 1;
	    break;

	  case OMP_MAP_FORCE_DEVICEPTR:
	    s->attr.oacc_declare_deviceptr = 1;
	    break;

	  default:
	    break;
	}
    }

  new_oc = gfc_get_oacc_declare ();
  new_oc->next = ns->oacc_declare;
  new_oc->module_var = module_var;
  new_oc->clauses = c;
  new_oc->loc = gfc_current_locus;
  ns->oacc_declare = new_oc;

  return MATCH_YES;
}


match
gfc_match_oacc_update (void)
{
  gfc_omp_clauses *c;
  locus here = gfc_current_locus;

  if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
      != MATCH_YES)
    return MATCH_ERROR;

  if (!c->lists[OMP_LIST_MAP])
    {
      gfc_error ("%<acc update%> must contain at least one "
		 "%<device%> or %<host%> or %<self%> clause at %L", &here);
      return MATCH_ERROR;
    }

  new_st.op = EXEC_OACC_UPDATE;
  new_st.ext.omp_clauses = c;
  return MATCH_YES;
}


match
gfc_match_oacc_enter_data (void)
{
  return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
}


match
gfc_match_oacc_exit_data (void)
{
  return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
}


match
gfc_match_oacc_wait (void)
{
  gfc_omp_clauses *c = gfc_get_omp_clauses ();
  gfc_expr_list *wait_list = NULL, *el;
  bool space = true;
  match m;

  m = match_oacc_expr_list (" (", &wait_list, true);
  if (m == MATCH_ERROR)
    return m;
  else if (m == MATCH_YES)
    space = false;

  if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
      == MATCH_ERROR)
    return MATCH_ERROR;

  if (wait_list)
    for (el = wait_list; el; el = el->next)
      {
	if (el->expr == NULL)
	  {
	    gfc_error ("Invalid argument to !$ACC WAIT at %C");
	    return MATCH_ERROR;
	  }

	if (!gfc_resolve_expr (el->expr)
	    || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
	  {
	    gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
		       &el->expr->where);

	    return MATCH_ERROR;
	  }
      }
  c->wait_list = wait_list;
  new_st.op = EXEC_OACC_WAIT;
  new_st.ext.omp_clauses = c;
  return MATCH_YES;
}


match
gfc_match_oacc_cache (void)
{
  gfc_omp_clauses *c = gfc_get_omp_clauses ();
  /* The OpenACC cache directive explicitly only allows "array elements or
     subarrays", which we're currently not checking here.  Either check this
     after the call of gfc_match_omp_variable_list, or add something like a
     only_sections variant next to its allow_sections parameter.  */
  match m = gfc_match_omp_variable_list (" (",
					 &c->lists[OMP_LIST_CACHE], true,
					 NULL, NULL, true);
  if (m != MATCH_YES)
    {
      gfc_free_omp_clauses(c);
      return m;
    }

  if (gfc_current_state() != COMP_DO 
      && gfc_current_state() != COMP_DO_CONCURRENT)
    {
      gfc_error ("ACC CACHE directive must be inside of loop %C");
      gfc_free_omp_clauses(c);
      return MATCH_ERROR;
    }

  new_st.op = EXEC_OACC_CACHE;
  new_st.ext.omp_clauses = c;
  return MATCH_YES;
}

/* Determine the loop level for a routine.   */

static int
gfc_oacc_routine_dims (gfc_omp_clauses *clauses)
{
  int level = -1;

  if (clauses)
    {
      unsigned mask = 0;

      if (clauses->gang)
	level = GOMP_DIM_GANG, mask |= GOMP_DIM_MASK (level);
      if (clauses->worker)
	level = GOMP_DIM_WORKER, mask |= GOMP_DIM_MASK (level);
      if (clauses->vector)
	level = GOMP_DIM_VECTOR, mask |= GOMP_DIM_MASK (level);
      if (clauses->seq)
	level = GOMP_DIM_MAX, mask |= GOMP_DIM_MASK (level);

      if (mask != (mask & -mask))
	gfc_error ("Multiple loop axes specified for routine");
    }

  if (level < 0)
    level = GOMP_DIM_MAX;

  return level;
}

match
gfc_match_oacc_routine (void)
{
  locus old_loc;
  gfc_symbol *sym = NULL;
  match m;
  gfc_omp_clauses *c = NULL;
  gfc_oacc_routine_name *n = NULL;

  old_loc = gfc_current_locus;

  m = gfc_match (" (");

  if (gfc_current_ns->proc_name
      && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
      && m == MATCH_YES)
    {
      gfc_error ("Only the !$ACC ROUTINE form without "
		 "list is allowed in interface block at %C");
      goto cleanup;
    }

  if (m == MATCH_YES)
    {
      char buffer[GFC_MAX_SYMBOL_LEN + 1];
      gfc_symtree *st;

      m = gfc_match_name (buffer);
      if (m == MATCH_YES)
	{
	  st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
	  if (st)
	    {
	      sym = st->n.sym;
	      if (gfc_current_ns->proc_name != NULL
		  && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
	        sym = NULL;
	    }

	  if (st == NULL
	      || (sym
		  && !sym->attr.external
		  && !sym->attr.function
		  && !sym->attr.subroutine))
	    {
	      gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, "
			 "invalid function name %s",
			 (sym) ? sym->name : buffer);
	      gfc_current_locus = old_loc;
	      return MATCH_ERROR;
	    }
	}
      else
        {
	  gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
	  gfc_current_locus = old_loc;
	  return MATCH_ERROR;
	}

      if (gfc_match_char (')') != MATCH_YES)
	{
	  gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
		     " ')' after NAME");
	  gfc_current_locus = old_loc;
	  return MATCH_ERROR;
	}
    }

  if (gfc_match_omp_eos () != MATCH_YES
      && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
	  != MATCH_YES))
    return MATCH_ERROR;

  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;
    }
  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))
	goto cleanup;
      gfc_current_ns->proc_name->attr.oacc_function
	= gfc_oacc_routine_dims (c) + 1;
    }

  if (n)
    n->clauses = c;
  else if (gfc_current_ns->oacc_routine)
    gfc_current_ns->oacc_routine_clauses = c;

  new_st.op = EXEC_OACC_ROUTINE;
  new_st.ext.omp_clauses = c;
  return MATCH_YES;  

cleanup:
  gfc_current_locus = old_loc;
  return MATCH_ERROR;
}


#define OMP_PARALLEL_CLAUSES \
  (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE		\
   | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION	\
   | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT	\
   | OMP_CLAUSE_PROC_BIND)
#define OMP_DECLARE_SIMD_CLAUSES \
  (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR			\
   | OMP_CLAUSE_UNIFORM	| OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH	\
   | OMP_CLAUSE_NOTINBRANCH)
#define OMP_DO_CLAUSES \
  (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE		\
   | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION			\
   | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE	\
   | OMP_CLAUSE_LINEAR)
#define OMP_SECTIONS_CLAUSES \
  (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE		\
   | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
#define OMP_SIMD_CLAUSES \
  (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE		\
   | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN	\
   | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN)
#define OMP_TASK_CLAUSES \
  (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE		\
   | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT		\
   | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE	\
   | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY)
#define OMP_TASKLOOP_CLAUSES \
  (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE		\
   | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF		\
   | OMP_CLAUSE_DEFAULT	| OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL		\
   | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE	\
   | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP)
#define OMP_TARGET_CLAUSES \
  (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF	\
   | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE		\
   | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP			\
   | OMP_CLAUSE_IS_DEVICE_PTR)
#define OMP_TARGET_DATA_CLAUSES \
  (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF	\
   | OMP_CLAUSE_USE_DEVICE_PTR)
#define OMP_TARGET_ENTER_DATA_CLAUSES \
  (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF	\
   | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
#define OMP_TARGET_EXIT_DATA_CLAUSES \
  (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF	\
   | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
#define OMP_TARGET_UPDATE_CLAUSES \
  (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO		\
   | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
#define OMP_TEAMS_CLAUSES \
  (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT		\
   | OMP_CLAUSE_DEFAULT	| OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE	\
   | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION)
#define OMP_DISTRIBUTE_CLAUSES \
  (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE		\
   | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE)
#define OMP_SINGLE_CLAUSES \
  (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE)
#define OMP_ORDERED_CLAUSES \
  (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
#define OMP_DECLARE_TARGET_CLAUSES \
  (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK)


static match
match_omp (gfc_exec_op op, const omp_mask mask)
{
  gfc_omp_clauses *c;
  if (gfc_match_omp_clauses (&c, mask) != MATCH_YES)
    return MATCH_ERROR;
  new_st.op = op;
  new_st.ext.omp_clauses = c;
  return MATCH_YES;
}


match
gfc_match_omp_critical (void)
{
  char n[GFC_MAX_SYMBOL_LEN+1];
  gfc_omp_clauses *c = NULL;

  if (gfc_match (" ( %n )", n) != MATCH_YES)
    {
      n[0] = '\0';
      if (gfc_match_omp_eos () != MATCH_YES)
	{
	  gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
	  return MATCH_ERROR;
	}
    }
  else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT)) != MATCH_YES)
    return MATCH_ERROR;

  new_st.op = EXEC_OMP_CRITICAL;
  new_st.ext.omp_clauses = c;
  if (n[0])
    c->critical_name = xstrdup (n);
  return MATCH_YES;
}


match
gfc_match_omp_end_critical (void)
{
  char n[GFC_MAX_SYMBOL_LEN+1];

  if (gfc_match (" ( %n )", n) != MATCH_YES)
    n[0] = '\0';
  if (gfc_match_omp_eos () != MATCH_YES)
    {
      gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
      return MATCH_ERROR;
    }

  new_st.op = EXEC_OMP_END_CRITICAL;
  new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
  return MATCH_YES;
}


match
gfc_match_omp_distribute (void)
{
  return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
}


match
gfc_match_omp_distribute_parallel_do (void)
{
  return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
		    (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
		     | OMP_DO_CLAUSES)
		    & ~(omp_mask (OMP_CLAUSE_ORDERED))
		    & ~(omp_mask (OMP_CLAUSE_LINEAR)));
}


match
gfc_match_omp_distribute_parallel_do_simd (void)
{
  return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
		    (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
		     | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
		    & ~(omp_mask (OMP_CLAUSE_ORDERED)));
}


match
gfc_match_omp_distribute_simd (void)
{
  return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
		    OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
}


match
gfc_match_omp_do (void)
{
  return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
}


match
gfc_match_omp_do_simd (void)
{
  return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
}


match
gfc_match_omp_flush (void)
{
  gfc_omp_namelist *list = NULL;
  gfc_match_omp_variable_list (" (", &list, true);
  if (gfc_match_omp_eos () != MATCH_YES)
    {
      gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
      gfc_free_omp_namelist (list);
      return MATCH_ERROR;
    }
  new_st.op = EXEC_OMP_FLUSH;
  new_st.ext.omp_namelist = list;
  return MATCH_YES;
}


match
gfc_match_omp_declare_simd (void)
{
  locus where = gfc_current_locus;
  gfc_symbol *proc_name;
  gfc_omp_clauses *c;
  gfc_omp_declare_simd *ods;
  bool needs_space = false;

  switch (gfc_match (" ( %s ) ", &proc_name))
    {
    case MATCH_YES: break;
    case MATCH_NO: proc_name = NULL; needs_space = true; break;
    case MATCH_ERROR: return MATCH_ERROR;
    }

  if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
			     needs_space) != MATCH_YES)
    return MATCH_ERROR;

  if (gfc_current_ns->is_block_data)
    {
      gfc_free_omp_clauses (c);
      return MATCH_YES;
    }

  ods = gfc_get_omp_declare_simd ();
  ods->where = where;
  ods->proc_name = proc_name;
  ods->clauses = c;
  ods->next = gfc_current_ns->omp_declare_simd;
  gfc_current_ns->omp_declare_simd = ods;
  return MATCH_YES;
}


static bool
match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
{
  match m;
  locus old_loc = gfc_current_locus;
  char sname[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symbol *sym;
  gfc_namespace *ns = gfc_current_ns;
  gfc_expr *lvalue = NULL, *rvalue = NULL;
  gfc_symtree *st;
  gfc_actual_arglist *arglist;

  m = gfc_match (" %v =", &lvalue);
  if (m != MATCH_YES)
    gfc_current_locus = old_loc;
  else
    {
      m = gfc_match (" %e )", &rvalue);
      if (m == MATCH_YES)
	{
	  ns->code = gfc_get_code (EXEC_ASSIGN);
	  ns->code->expr1 = lvalue;
	  ns->code->expr2 = rvalue;
	  ns->code->loc = old_loc;
	  return true;
	}

      gfc_current_locus = old_loc;
      gfc_free_expr (lvalue);
    }

  m = gfc_match (" %n", sname);
  if (m != MATCH_YES)
    return false;

  if (strcmp (sname, omp_sym1->name) == 0
      || strcmp (sname, omp_sym2->name) == 0)
    return false;

  gfc_current_ns = ns->parent;
  if (gfc_get_ha_sym_tree (sname, &st))
    return false;

  sym = st->n.sym;
  if (sym->attr.flavor != FL_PROCEDURE
      && sym->attr.flavor != FL_UNKNOWN)
    return false;

  if (!sym->attr.generic
      && !sym->attr.subroutine
      && !sym->attr.function)
    {
      if (!(sym->attr.external && !sym->attr.referenced))
	{
	  /* ...create a symbol in this scope...  */
	  if (sym->ns != gfc_current_ns
	      && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
	    return false;

	  if (sym != st->n.sym)
	    sym = st->n.sym;
	}

      /* ...and then to try to make the symbol into a subroutine.  */
      if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
	return false;
    }

  gfc_set_sym_referenced (sym);
  gfc_gobble_whitespace ();
  if (gfc_peek_ascii_char () != '(')
    return false;

  gfc_current_ns = ns;
  m = gfc_match_actual_arglist (1, &arglist);
  if (m != MATCH_YES)
    return false;

  if (gfc_match_char (')') != MATCH_YES)
    return false;

  ns->code = gfc_get_code (EXEC_CALL);
  ns->code->symtree = st;
  ns->code->ext.actual = arglist;
  ns->code->loc = old_loc;
  return true;
}

static bool
gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
		    gfc_typespec *ts, const char **n)
{
  if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
    return false;

  switch (rop)
    {
    case OMP_REDUCTION_PLUS:
    case OMP_REDUCTION_MINUS:
    case OMP_REDUCTION_TIMES:
      return ts->type != BT_LOGICAL;
    case OMP_REDUCTION_AND:
    case OMP_REDUCTION_OR:
    case OMP_REDUCTION_EQV:
    case OMP_REDUCTION_NEQV:
      return ts->type == BT_LOGICAL;
    case OMP_REDUCTION_USER:
      if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
	{
	  gfc_symbol *sym;

	  gfc_find_symbol (name, NULL, 1, &sym);
	  if (sym != NULL)
	    {
	      if (sym->attr.intrinsic)
		*n = sym->name;
	      else if ((sym->attr.flavor != FL_UNKNOWN
			&& sym->attr.flavor != FL_PROCEDURE)
		       || sym->attr.external
		       || sym->attr.generic
		       || sym->attr.entry
		       || sym->attr.result
		       || sym->attr.dummy
		       || sym->attr.subroutine
		       || sym->attr.pointer
		       || sym->attr.target
		       || sym->attr.cray_pointer
		       || sym->attr.cray_pointee
		       || (sym->attr.proc != PROC_UNKNOWN
			   && sym->attr.proc != PROC_INTRINSIC)
		       || sym->attr.if_source != IFSRC_UNKNOWN
		       || sym == sym->ns->proc_name)
		*n = NULL;
	      else
		*n = sym->name;
	    }
	  else
	    *n = name;
	  if (*n
	      && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
	    return true;
	  else if (*n
		   && ts->type == BT_INTEGER
		   && (strcmp (*n, "iand") == 0
		       || strcmp (*n, "ior") == 0
		       || strcmp (*n, "ieor") == 0))
	    return true;
	}
      break;
    default:
      break;
    }
  return false;
}

gfc_omp_udr *
gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
{
  gfc_omp_udr *omp_udr;

  if (st == NULL)
    return NULL;

  for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
    if (omp_udr->ts.type == ts->type
	|| ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
	    && (ts->type == BT_DERIVED || ts->type == BT_CLASS)))
      {
	if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
	  {
	    if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
	      return omp_udr;
	  }
	else if (omp_udr->ts.kind == ts->kind)
	  {
	    if (omp_udr->ts.type == BT_CHARACTER)
	      {
		if (omp_udr->ts.u.cl->length == NULL
		    || ts->u.cl->length == NULL)
		  return omp_udr;
		if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
		  return omp_udr;
		if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
		  return omp_udr;
		if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
		  return omp_udr;
		if (ts->u.cl->length->ts.type != BT_INTEGER)
		  return omp_udr;
		if (gfc_compare_expr (omp_udr->ts.u.cl->length,
				      ts->u.cl->length, INTRINSIC_EQ) != 0)
		  continue;
	      }
	    return omp_udr;
	  }
      }
  return NULL;
}

match
gfc_match_omp_declare_reduction (void)
{
  match m;
  gfc_intrinsic_op op;
  char name[GFC_MAX_SYMBOL_LEN + 3];
  auto_vec<gfc_typespec, 5> tss;
  gfc_typespec ts;
  unsigned int i;
  gfc_symtree *st;
  locus where = gfc_current_locus;
  locus end_loc = gfc_current_locus;
  bool end_loc_set = false;
  gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;

  if (gfc_match_char ('(') != MATCH_YES)
    return MATCH_ERROR;

  m = gfc_match (" %o : ", &op);
  if (m == MATCH_ERROR)
    return MATCH_ERROR;
  if (m == MATCH_YES)
    {
      snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
      rop = (gfc_omp_reduction_op) op;
    }
  else
    {
      m = gfc_match_defined_op_name (name + 1, 1);
      if (m == MATCH_ERROR)
	return MATCH_ERROR;
      if (m == MATCH_YES)
	{
	  name[0] = '.';
	  strcat (name, ".");
	  if (gfc_match (" : ") != MATCH_YES)
	    return MATCH_ERROR;
	}
      else
	{
	  if (gfc_match (" %n : ", name) != MATCH_YES)
	    return MATCH_ERROR;
	}
      rop = OMP_REDUCTION_USER;
    }

  m = gfc_match_type_spec (&ts);
  if (m != MATCH_YES)
    return MATCH_ERROR;
  /* Treat len=: the same as len=*.  */
  if (ts.type == BT_CHARACTER)
    ts.deferred = false;
  tss.safe_push (ts);

  while (gfc_match_char (',') == MATCH_YES)
    {
      m = gfc_match_type_spec (&ts);
      if (m != MATCH_YES)
	return MATCH_ERROR;
      tss.safe_push (ts);
    }
  if (gfc_match_char (':') != MATCH_YES)
    return MATCH_ERROR;

  st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
  for (i = 0; i < tss.length (); i++)
    {
      gfc_symtree *omp_out, *omp_in;
      gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
      gfc_namespace *combiner_ns, *initializer_ns = NULL;
      gfc_omp_udr *prev_udr, *omp_udr;
      const char *predef_name = NULL;

      omp_udr = gfc_get_omp_udr ();
      omp_udr->name = gfc_get_string ("%s", name);
      omp_udr->rop = rop;
      omp_udr->ts = tss[i];
      omp_udr->where = where;

      gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
      combiner_ns->proc_name = combiner_ns->parent->proc_name;

      gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
      gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
      combiner_ns->omp_udr_ns = 1;
      omp_out->n.sym->ts = tss[i];
      omp_in->n.sym->ts = tss[i];
      omp_out->n.sym->attr.omp_udr_artificial_var = 1;
      omp_in->n.sym->attr.omp_udr_artificial_var = 1;
      omp_out->n.sym->attr.flavor = FL_VARIABLE;
      omp_in->n.sym->attr.flavor = FL_VARIABLE;
      gfc_commit_symbols ();
      omp_udr->combiner_ns = combiner_ns;
      omp_udr->omp_out = omp_out->n.sym;
      omp_udr->omp_in = omp_in->n.sym;

      locus old_loc = gfc_current_locus;

      if (!match_udr_expr (omp_out, omp_in))
	{
	 syntax:
	  gfc_current_locus = old_loc;
	  gfc_current_ns = combiner_ns->parent;
	  gfc_undo_symbols ();
	  gfc_free_omp_udr (omp_udr);
	  return MATCH_ERROR;
	}

      if (gfc_match (" initializer ( ") == MATCH_YES)
	{
	  gfc_current_ns = combiner_ns->parent;
	  initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
	  gfc_current_ns = initializer_ns;
	  initializer_ns->proc_name = initializer_ns->parent->proc_name;

	  gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
	  gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
	  initializer_ns->omp_udr_ns = 1;
	  omp_priv->n.sym->ts = tss[i];
	  omp_orig->n.sym->ts = tss[i];
	  omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
	  omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
	  omp_priv->n.sym->attr.flavor = FL_VARIABLE;
	  omp_orig->n.sym->attr.flavor = FL_VARIABLE;
	  gfc_commit_symbols ();
	  omp_udr->initializer_ns = initializer_ns;
	  omp_udr->omp_priv = omp_priv->n.sym;
	  omp_udr->omp_orig = omp_orig->n.sym;

	  if (!match_udr_expr (omp_priv, omp_orig))
	    goto syntax;
	}

      gfc_current_ns = combiner_ns->parent;
      if (!end_loc_set)
	{
	  end_loc_set = true;
	  end_loc = gfc_current_locus;
	}
      gfc_current_locus = old_loc;

      prev_udr = gfc_omp_udr_find (st, &tss[i]);
      if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
	  /* Don't error on !$omp declare reduction (min : integer : ...)
	     just yet, there could be integer :: min afterwards,
	     making it valid.  When the UDR is resolved, we'll get
	     to it again.  */
	  && (rop != OMP_REDUCTION_USER || name[0] == '.'))
	{
	  if (predef_name)
	    gfc_error_now ("Redefinition of predefined %s "
			   "!$OMP DECLARE REDUCTION at %L",
			   predef_name, &where);
	  else
	    gfc_error_now ("Redefinition of predefined "
			   "!$OMP DECLARE REDUCTION at %L", &where);
	}
      else if (prev_udr)
	{
	  gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
			 &where);
	  gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
			 &prev_udr->where);
	}
      else if (st)
	{
	  omp_udr->next = st->n.omp_udr;
	  st->n.omp_udr = omp_udr;
	}
      else
	{
	  st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
	  st->n.omp_udr = omp_udr;
	}
    }

  if (end_loc_set)
    {
      gfc_current_locus = end_loc;
      if (gfc_match_omp_eos () != MATCH_YES)
	{
	  gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
	  gfc_current_locus = where;
	  return MATCH_ERROR;
	}

      return MATCH_YES;
    }
  gfc_clear_error ();
  return MATCH_ERROR;
}


match
gfc_match_omp_declare_target (void)
{
  locus old_loc;
  match m;
  gfc_omp_clauses *c = NULL;
  int list;
  gfc_omp_namelist *n;
  gfc_symbol *s;

  old_loc = gfc_current_locus;

  if (gfc_current_ns->proc_name
      && gfc_match_omp_eos () == MATCH_YES)
    {
      if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
				       gfc_current_ns->proc_name->name,
				       &old_loc))
	goto cleanup;
      return MATCH_YES;
    }

  if (gfc_current_ns->proc_name
      && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
    {
      gfc_error ("Only the !$OMP DECLARE TARGET form without "
		 "clauses is allowed in interface block at %C");
      goto cleanup;
    }

  m = gfc_match (" (");
  if (m == MATCH_YES)
    {
      c = gfc_get_omp_clauses ();
      gfc_current_locus = old_loc;
      m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_TO]);
      if (m != MATCH_YES)
	goto syntax;
      if (gfc_match_omp_eos () != MATCH_YES)
	{
	  gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
	  goto cleanup;
	}
    }
  else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
    return MATCH_ERROR;

  gfc_buffer_error (false);

  for (list = OMP_LIST_TO; list != OMP_LIST_NUM;
       list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM))
    for (n = c->lists[list]; n; n = n->next)
      if (n->sym)
	n->sym->mark = 0;
      else if (n->u.common->head)
	n->u.common->head->mark = 0;

  for (list = OMP_LIST_TO; list != OMP_LIST_NUM;
       list <