Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / fortran / openmp.cc
blob: 714148138c22468d10acb303aaeb2c9d374cc640 [file] [log] [blame]
/* OpenMP directive matching and resolving.
Copyright (C) 2005-2022 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 "constructor.h"
#include "diagnostic.h"
#include "gomp-constants.h"
#include "target-memory.h" /* For gfc_encode_character. */
/* Match an end of OpenMP directive. End of OpenMP directive is optional
whitespace, followed by '\n' or comment '!'. */
static 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;
}
match
gfc_match_omp_eos_error (void)
{
if (gfc_match_omp_eos() == MATCH_YES)
return MATCH_YES;
gfc_error ("Unexpected junk at %C");
return MATCH_ERROR;
}
/* 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_lower);
gfc_free_expr (c->num_teams_upper);
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);
gfc_free_expr (c->detach);
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],
i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND);
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);
}
}
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
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,
bool allow_derived = 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;
gfc_gobble_whitespace ();
if ((allow_sections && gfc_peek_ascii_char () == '(')
|| (allow_derived && 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;
}
if (gfc_is_coindexed (expr))
{
gfc_error ("List item shall not be coindexed at %C");
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 = 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, false);
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, false);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
/* Match detach(event-handle). */
static match
gfc_match_omp_detach (gfc_expr **expr)
{
locus old_loc = gfc_current_locus;
if (gfc_match ("detach ( ") != MATCH_YES)
goto syntax_error;
if (gfc_match_variable (expr, 0) != MATCH_YES)
goto syntax_error;
if (gfc_match_char (')') != MATCH_YES)
goto syntax_error;
return MATCH_YES;
syntax_error:
gfc_error ("Syntax error in OpenMP detach clause at %C");
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, false);
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 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_IN_REDUCTION,
OMP_CLAUSE_TASK_REDUCTION,
OMP_CLAUSE_IF,
OMP_CLAUSE_NUM_THREADS,
OMP_CLAUSE_SCHEDULE,
OMP_CLAUSE_DEFAULT,
OMP_CLAUSE_ORDER,
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_NOTEMPORAL,
OMP_CLAUSE_NUM_TASKS,
OMP_CLAUSE_PRIORITY,
OMP_CLAUSE_SIMD,
OMP_CLAUSE_THREADS,
OMP_CLAUSE_USE_DEVICE_PTR,
OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */
OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */
OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */
OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */
OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */
OMP_CLAUSE_DETACH, /* OpenMP 5.0. */
OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */
OMP_CLAUSE_ALLOCATE, /* OpenMP 5.0. */
OMP_CLAUSE_BIND, /* OpenMP 5.0. */
OMP_CLAUSE_FILTER, /* OpenMP 5.1. */
OMP_CLAUSE_AT, /* OpenMP 5.1. */
OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */
OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
OMP_CLAUSE_NOWAIT,
/* This must come last. */
OMP_MASK1_LAST
};
/* More OpenMP clauses and 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_NO_CREATE,
OMP_CLAUSE_PRESENT,
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,
OMP_CLAUSE_IF_PRESENT,
OMP_CLAUSE_FINALIZE,
OMP_CLAUSE_ATTACH,
OMP_CLAUSE_NOHOST,
OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */
/* 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,
bool allow_common, bool allow_derived)
{
gfc_omp_namelist **head = NULL;
if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
allow_derived)
== MATCH_YES)
{
gfc_omp_namelist *n;
for (n = *head; n; n = n->next)
n->u.map_op = map_op;
return true;
}
return false;
}
static match
gfc_match_iterator (gfc_namespace **ns, bool permit_var)
{
locus old_loc = gfc_current_locus;
if (gfc_match ("iterator ( ") != MATCH_YES)
return MATCH_NO;
gfc_typespec ts;
gfc_symbol *last = NULL;
gfc_expr *begin, *end, *step;
*ns = gfc_build_block_ns (gfc_current_ns);
char name[GFC_MAX_SYMBOL_LEN + 1];
while (true)
{
locus prev_loc = gfc_current_locus;
if (gfc_match_type_spec (&ts) == MATCH_YES
&& gfc_match (" :: ") == MATCH_YES)
{
if (ts.type != BT_INTEGER)
{
gfc_error ("Expected INTEGER type at %L", &prev_loc);
return MATCH_ERROR;
}
permit_var = false;
}
else
{
ts.type = BT_INTEGER;
ts.kind = gfc_default_integer_kind;
gfc_current_locus = prev_loc;
}
prev_loc = gfc_current_locus;
if (gfc_match_name (name) != MATCH_YES)
{
gfc_error ("Expected identifier at %C");
goto failed;
}
if (gfc_find_symtree ((*ns)->sym_root, name))
{
gfc_error ("Same identifier %qs specified again at %C", name);
goto failed;
}
gfc_symbol *sym = gfc_new_symbol (name, *ns);
if (last)
last->tlink = sym;
else
(*ns)->omp_affinity_iterators = sym;
last = sym;
sym->declared_at = prev_loc;
sym->ts = ts;
sym->attr.flavor = FL_VARIABLE;
sym->attr.artificial = 1;
sym->attr.referenced = 1;
sym->refs++;
gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name);
st->n.sym = sym;
prev_loc = gfc_current_locus;
if (gfc_match (" = ") != MATCH_YES)
goto failed;
permit_var = false;
begin = end = step = NULL;
if (gfc_match ("%e : ", &begin) != MATCH_YES
|| gfc_match ("%e ", &end) != MATCH_YES)
{
gfc_error ("Expected range-specification at %C");
gfc_free_expr (begin);
gfc_free_expr (end);
return MATCH_ERROR;
}
if (':' == gfc_peek_ascii_char ())
{
step = gfc_get_expr ();
if (gfc_match (": %e ", &step) != MATCH_YES)
{
gfc_free_expr (begin);
gfc_free_expr (end);
gfc_free_expr (step);
goto failed;
}
}
gfc_expr *e = gfc_get_expr ();
e->where = prev_loc;
e->expr_type = EXPR_ARRAY;
e->ts = ts;
e->rank = 1;
e->shape = gfc_get_shape (1);
mpz_init_set_ui (e->shape[0], step ? 3 : 2);
gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where);
gfc_constructor_append_expr (&e->value.constructor, end, &end->where);
if (step)
gfc_constructor_append_expr (&e->value.constructor, step, &step->where);
sym->value = e;
if (gfc_match (") ") == MATCH_YES)
break;
if (gfc_match (", ") != MATCH_YES)
goto failed;
}
return MATCH_YES;
failed:
gfc_namespace *prev_ns = NULL;
for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling)
{
if (it == *ns)
{
if (prev_ns)
prev_ns->sibling = it->sibling;
else
gfc_current_ns->contained = it->sibling;
gfc_free_namespace (it);
break;
}
prev_ns = it;
}
*ns = NULL;
if (!permit_var)
return MATCH_ERROR;
gfc_current_locus = old_loc;
return MATCH_NO;
}
/* reduction ( reduction-modifier, reduction-operator : variable-list )
in_reduction ( reduction-operator : variable-list )
task_reduction ( reduction-operator : variable-list ) */
static match
gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
bool allow_derived, bool openmp_target = false)
{
if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
return MATCH_NO;
else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
return MATCH_NO;
else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
return MATCH_NO;
locus old_loc = gfc_current_locus;
int list_idx = 0;
if (pc == 'r' && !openacc)
{
if (gfc_match ("inscan") == MATCH_YES)
list_idx = OMP_LIST_REDUCTION_INSCAN;
else if (gfc_match ("task") == MATCH_YES)
list_idx = OMP_LIST_REDUCTION_TASK;
else if (gfc_match ("default") == MATCH_YES)
list_idx = OMP_LIST_REDUCTION;
if (list_idx != 0 && gfc_match (", ") != MATCH_YES)
{
gfc_error ("Comma expected at %C");
gfc_current_locus = old_loc;
return MATCH_NO;
}
if (list_idx == 0)
list_idx = OMP_LIST_REDUCTION;
}
else if (pc == 'i')
list_idx = OMP_LIST_IN_REDUCTION;
else if (pc == 't')
list_idx = OMP_LIST_TASK_REDUCTION;
else
list_idx = OMP_LIST_REDUCTION;
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[list_idx], false, NULL,
&head, openacc, allow_derived) != MATCH_YES)
{
gfc_current_locus = old_loc;
return MATCH_NO;
}
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, false);
}
else
for (n = *head; n; n = n->next)
{
n->u.reduction_op = rop;
if (udr)
{
n->u2.udr = gfc_get_omp_namelist_udr ();
n->u2.udr->udr = udr;
}
if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION)
{
gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
p->sym = n->sym;
p->where = p->where;
p->u.map_op = OMP_MAP_ALWAYS_TOFROM;
tl = &c->lists[OMP_LIST_MAP];
while (*tl)
tl = &((*tl)->next);
*tl = p;
p->next = NULL;
}
}
return MATCH_YES;
}
/* Match with duplicate check. Matches 'name'. If expr != NULL, it
then matches '(expr)', otherwise, if open_parens is true,
it matches a ' ( ' after 'name'.
dupl_message requires '%qs %L' - and is used by
gfc_match_dupl_memorder and gfc_match_dupl_atomic. */
static match
gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false,
gfc_expr **expr = NULL, const char *dupl_msg = NULL)
{
match m;
locus old_loc = gfc_current_locus;
if ((m = gfc_match (name)) != MATCH_YES)
return m;
if (!not_dupl)
{
if (dupl_msg)
gfc_error (dupl_msg, name, &old_loc);
else
gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
return MATCH_ERROR;
}
if (open_parens || expr)
{
if (gfc_match (" ( ") != MATCH_YES)
{
gfc_error ("Expected %<(%> after %qs at %C", name);
return MATCH_ERROR;
}
if (expr)
{
if (gfc_match ("%e )", expr) != MATCH_YES)
{
gfc_error ("Invalid expression after %<%s(%> at %C", name);
return MATCH_ERROR;
}
}
}
return MATCH_YES;
}
static match
gfc_match_dupl_memorder (bool not_dupl, const char *name)
{
return gfc_match_dupl_check (not_dupl, name, false, NULL,
"Duplicated memory-order clause: unexpected %s "
"clause at %L");
}
static match
gfc_match_dupl_atomic (bool not_dupl, const char *name)
{
return gfc_match_dupl_check (not_dupl, name, false, NULL,
"Duplicated atomic clause: unexpected %s "
"clause at %L");
}
/* 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, bool context_selector = false,
bool openmp_target = false)
{
bool error = false;
gfc_omp_clauses *c = gfc_get_omp_clauses ();
locus old_loc;
/* Determine whether we're dealing with an OpenACC directive that permits
derived type member accesses. This in particular disallows
"!$acc declare" from using such accesses, because it's not clear if/how
that should work. */
bool allow_derived = (openacc
&& ((mask & OMP_CLAUSE_ATTACH)
|| (mask & OMP_CLAUSE_DETACH)
|| (mask & OMP_CLAUSE_HOST_SELF)));
gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
*cp = NULL;
while (1)
{
match m = MATCH_NO;
if ((first || (m = 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 ();
if (pc == '\n' && m == MATCH_YES)
{
gfc_error ("Clause expected at %C after trailing comma");
goto error;
}
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, false);
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_MEMORDER)
&& (m = gfc_match_dupl_memorder ((c->memorder
== OMP_MEMORDER_UNSET),
"acq_rel")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->memorder = OMP_MEMORDER_ACQ_REL;
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_MEMORDER)
&& (m = gfc_match_dupl_memorder ((c->memorder
== OMP_MEMORDER_UNSET),
"acquire")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->memorder = OMP_MEMORDER_ACQUIRE;
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_AFFINITY)
&& gfc_match ("affinity ( ") == MATCH_YES)
{
gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
m = gfc_match_iterator (&ns_iter, true);
if (m == MATCH_ERROR)
break;
if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
{
gfc_error ("Expected %<:%> at %C");
break;
}
if (ns_iter)
gfc_current_ns = ns_iter;
head = NULL;
m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY],
false, NULL, &head, true);
gfc_current_ns = ns_curr;
if (m == MATCH_ERROR)
break;
if (ns_iter)
{
for (gfc_omp_namelist *n = *head; n; n = n->next)
{
n->u2.ns = ns_iter;
ns_iter->refs++;
}
}
continue;
}
if ((mask & OMP_CLAUSE_ALLOCATE)
&& gfc_match ("allocate ( ") == MATCH_YES)
{
gfc_expr *allocator = NULL;
old_loc = gfc_current_locus;
m = gfc_match_expr (&allocator);
if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
{
/* If no ":" then there is no allocator, we backtrack
and read the variable list. */
gfc_free_expr (allocator);
allocator = NULL;
gfc_current_locus = old_loc;
}
gfc_omp_namelist **head = NULL;
m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
true, NULL, &head);
if (m != MATCH_YES)
{
gfc_free_expr (allocator);
gfc_error ("Expected variable list at %C");
goto error;
}
for (gfc_omp_namelist *n = *head; n; n = n->next)
if (allocator)
n->expr = gfc_copy_expr (allocator);
else
n->expr = NULL;
gfc_free_expr (allocator);
continue;
}
if ((mask & OMP_CLAUSE_AT)
&& (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
if (gfc_match ("compilation )") == MATCH_YES)
c->at = OMP_AT_COMPILATION;
else if (gfc_match ("execution )") == MATCH_YES)
c->at = OMP_AT_EXECUTION;
else
{
gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
"at %C");
goto error;
}
continue;
}
if ((mask & OMP_CLAUSE_ASYNC)
&& (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->async = true;
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)
&& (m = gfc_match_dupl_check (!c->par_auto, "auto"))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->par_auto = true;
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_ATTACH)
&& gfc_match ("attach ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_ATTACH, false,
allow_derived))
continue;
break;
case 'b':
if ((mask & OMP_CLAUSE_BIND)
&& (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind",
true)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
if (gfc_match ("teams )") == MATCH_YES)
c->bind = OMP_BIND_TEAMS;
else if (gfc_match ("parallel )") == MATCH_YES)
c->bind = OMP_BIND_PARALLEL;
else if (gfc_match ("thread )") == MATCH_YES)
c->bind = OMP_BIND_THREAD;
else
{
gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
"BIND at %C");
break;
}
continue;
}
break;
case 'c':
if ((mask & OMP_CLAUSE_CAPTURE)
&& (m = gfc_match_dupl_check (!c->capture, "capture"))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->capture = true;
needs_space = true;
continue;
}
if (mask & OMP_CLAUSE_COLLAPSE)
{
gfc_expr *cexpr = NULL;
if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true,
&cexpr)) != MATCH_NO)
{
int collapse;
if (m == MATCH_ERROR)
goto error;
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;
}
gfc_free_expr (cexpr);
c->collapse = collapse;
continue;
}
}
if ((mask & OMP_CLAUSE_COMPARE)
&& (m = gfc_match_dupl_check (!c->compare, "compare"))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->compare = true;
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_COPY)
&& gfc_match ("copy ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_TOFROM, true,
allow_derived))
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_TO, true,
allow_derived))
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_FROM, true, allow_derived))
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_ALLOC, true, allow_derived))
continue;
break;
case 'd':
if ((mask & OMP_CLAUSE_DEFAULTMAP)
&& gfc_match ("defaultmap ( ") == MATCH_YES)
{
enum gfc_omp_defaultmap behavior;
gfc_omp_defaultmap_category category
= OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
if (gfc_match ("alloc ") == MATCH_YES)
behavior = OMP_DEFAULTMAP_ALLOC;
else if (gfc_match ("tofrom ") == MATCH_YES)
behavior = OMP_DEFAULTMAP_TOFROM;
else if (gfc_match ("to ") == MATCH_YES)
behavior = OMP_DEFAULTMAP_TO;
else if (gfc_match ("from ") == MATCH_YES)
behavior = OMP_DEFAULTMAP_FROM;
else if (gfc_match ("firstprivate ") == MATCH_YES)
behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
else if (gfc_match ("none ") == MATCH_YES)
behavior = OMP_DEFAULTMAP_NONE;
else if (gfc_match ("default ") == MATCH_YES)
behavior = OMP_DEFAULTMAP_DEFAULT;
else
{
gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
"NONE or DEFAULT at %C");
break;
}
if (')' == gfc_peek_ascii_char ())
;
else if (gfc_match (": ") != MATCH_YES)
break;
else
{
if (gfc_match ("scalar ") == MATCH_YES)
category = OMP_DEFAULTMAP_CAT_SCALAR;
else if (gfc_match ("aggregate ") == MATCH_YES)
category = OMP_DEFAULTMAP_CAT_AGGREGATE;
else if (gfc_match ("allocatable ") == MATCH_YES)
category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
else if (gfc_match ("pointer ") == MATCH_YES)
category = OMP_DEFAULTMAP_CAT_POINTER;
else
{
gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE or "
"POINTER at %C");
break;
}
}
for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
{
if (i != category
&& category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
continue;
if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
{
const char *pcategory = NULL;
switch (i)
{
case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
case OMP_DEFAULTMAP_CAT_AGGREGATE:
pcategory = "AGGREGATE";
break;
case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
pcategory = "ALLOCATABLE";
break;
case OMP_DEFAULTMAP_CAT_POINTER:
pcategory = "POINTER";
break;
default: gcc_unreachable ();
}
if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
"unspecified category");
else
gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
"category %s", pcategory);
goto error;
}
}
c->defaultmap[category] = behavior;
if (gfc_match (")") != MATCH_YES)
break;
continue;
}
if ((mask & OMP_CLAUSE_DEFAULT)
&& (m = gfc_match_dupl_check (c->default_sharing
== OMP_DEFAULT_UNKNOWN, "default",
true)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
if (gfc_match ("none") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_NONE;
else if (openacc)
{
if (gfc_match ("present") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_PRESENT;
}
else
{
if (gfc_match ("firstprivate") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
else if (gfc_match ("private") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_PRIVATE;
else if (gfc_match ("shared") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_SHARED;
}
if (c->default_sharing == OMP_DEFAULT_UNKNOWN)
{
if (openacc)
gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
"at %C");
else
gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
"in DEFAULT clause at %C");
goto error;
}
if (gfc_match (" )") != MATCH_YES)
goto error;
continue;
}
if ((mask & OMP_CLAUSE_DELETE)
&& gfc_match ("delete ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_RELEASE, true,
allow_derived))
continue;
if ((mask & OMP_CLAUSE_DEPEND)
&& gfc_match ("depend ( ") == MATCH_YES)
{
gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
match m_it = gfc_match_iterator (&ns_iter, false);
if (m_it == MATCH_ERROR)
break;
if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
break;
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 (gfc_match ("mutexinoutset") == MATCH_YES)
depend_op = OMP_DEPEND_MUTEXINOUTSET;
else if (gfc_match ("depobj") == MATCH_YES)
depend_op = OMP_DEPEND_DEPOBJ;
else if (!c->depend_source
&& gfc_match ("source )") == MATCH_YES)
{
if (m_it == MATCH_YES)
{
gfc_error ("ITERATOR may not be combined with SOURCE "
"at %C");
gfc_free_omp_clauses (c);
return MATCH_ERROR;
}
c->depend_source = true;
continue;
}
else if (gfc_match ("sink : ") == MATCH_YES)
{
if (m_it == MATCH_YES)
{
gfc_error ("ITERATOR may not be combined with SINK "
"at %C");
break;
}
if (gfc_match_omp_depend_sink (&c->lists[OMP_LIST_DEPEND])
== MATCH_YES)
continue;
m = MATCH_NO;
}
else
m = MATCH_NO;
head = NULL;
if (ns_iter)
gfc_current_ns = ns_iter;
if (m == MATCH_YES)
m = gfc_match_omp_variable_list (" : ",
&c->lists[OMP_LIST_DEPEND],
false, NULL, &head, true);
gfc_current_ns = ns_curr;
if (m == MATCH_YES)
{
gfc_omp_namelist *n;
for (n = *head; n; n = n->next)
{
n->u.depend_op = depend_op;
n->u2.ns = ns_iter;
if (ns_iter)
ns_iter->refs++;
}
continue;
}
break;
}
if ((mask & OMP_CLAUSE_DETACH)
&& !openacc
&& !c->detach
&& gfc_match_omp_detach (&c->detach) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_DETACH)
&& openacc
&& gfc_match ("detach ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_DETACH, false,
allow_derived))
continue;
if ((mask & OMP_CLAUSE_DEVICE)
&& !openacc
&& ((m = gfc_match_dupl_check (!c->device, "device", true))
!= MATCH_NO))
{
if (m == MATCH_ERROR)
goto error;
c->ancestor = false;
if (gfc_match ("device_num : ") == MATCH_YES)
{
if (gfc_match ("%e )", &c->device) != MATCH_YES)
{
gfc_error ("Expected integer expression at %C");
break;
}
}
else if (gfc_match ("ancestor : ") == MATCH_YES)
{
c->ancestor = true;
if (!(gfc_current_ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
{
gfc_error ("%<ancestor%> device modifier not "
"preceded by %<requires%> directive "
"with %<reverse_offload%> clause at %C");
break;
}
locus old_loc2 = gfc_current_locus;
if (gfc_match ("%e )", &c->device) == MATCH_YES)
{
int device = 0;
if (!gfc_extract_int (c->device, &device) && device != 1)
{
gfc_current_locus = old_loc2;
gfc_error ("the %<device%> clause expression must "
"evaluate to %<1%> at %C");
break;
}
}
else
{
gfc_error ("Expected integer expression at %C");
break;
}
}
else if (gfc_match ("%e )", &c->device) != MATCH_YES)
{
gfc_error ("Expected integer expression or a single device-"
"modifier %<device_num%> or %<ancestor%> at %C");
break;
}
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, true,
allow_derived))
continue;
if ((mask & OMP_CLAUSE_DEVICEPTR)
&& gfc_match ("deviceptr ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_FORCE_DEVICEPTR, false,
allow_derived))
continue;
if ((mask & OMP_CLAUSE_DEVICE_TYPE)
&& gfc_match ("device_type ( ") == MATCH_YES)
{
if (gfc_match ("host") == MATCH_YES)
c->device_type = OMP_DEVICE_TYPE_HOST;
else if (gfc_match ("nohost") == MATCH_YES)
c->device_type = OMP_DEVICE_TYPE_NOHOST;
else if (gfc_match ("any") == MATCH_YES)
c->device_type = OMP_DEVICE_TYPE_ANY;
else
{
gfc_error ("Expected HOST, NOHOST or ANY at %C");
break;
}
if (gfc_match (" )") != MATCH_YES)
break;
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)
{
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_FAIL)
&& (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
"fail", true)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
if (gfc_match ("seq_cst") == MATCH_YES)
c->fail = OMP_MEMORDER_SEQ_CST;
else if (gfc_match ("acquire") == MATCH_YES)
c->fail = OMP_MEMORDER_ACQUIRE;
else if (gfc_match ("relaxed") == MATCH_YES)
c->fail = OMP_MEMORDER_RELAXED;
else
{
gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
break;
}
if (gfc_match (" )") != MATCH_YES)
goto error;
continue;
}
if ((mask & OMP_CLAUSE_FILTER)
&& (m = gfc_match_dupl_check (!c->filter, "filter", true,
&c->filter)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
continue;
}
if ((mask & OMP_CLAUSE_FINAL)
&& (m = gfc_match_dupl_check (!c->final_expr, "final", true,
&c->final_expr)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
continue;
}
if ((mask & OMP_CLAUSE_FINALIZE)
&& (m = gfc_match_dupl_check (!c->finalize, "finalize"))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->finalize = true;
needs_space = true;
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)
&& (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->gang = true;
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)
&& (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
if (gfc_match ("strict : ") == MATCH_YES)
c->grainsize_strict = true;
if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
goto error;
continue;
}
break;
case 'h':
if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR)
&& gfc_match_omp_variable_list
("has_device_addr (", &c->lists[OMP_LIST_HAS_DEVICE_ADDR],
false, NULL, NULL, true) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_HINT)
&& (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
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, true,
allow_derived))
continue;
break;
case 'i':
if ((mask & OMP_CLAUSE_IF_PRESENT)
&& (m = gfc_match_dupl_check (!c->if_present, "if_present"))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->if_present = true;
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_IF)
&& (m = gfc_match_dupl_check (!c->if_expr, "if", true))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
if (!openacc)
{
/* This should match the enum gfc_omp_if_kind order. */
static const char *ifs[OMP_IF_LAST] = {
"cancel : %e )",
"parallel : %e )",
"simd : %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;
}
if (gfc_match (" %e )", &c->if_expr) == MATCH_YES)
continue;
goto error;
}
if ((mask & OMP_CLAUSE_IN_REDUCTION)
&& gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
openmp_target) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_INBRANCH)
&& (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch,
"inbranch")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->inbranch = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_INDEPENDENT)
&& (m = gfc_match_dupl_check (!c->independent, "independent"))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
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 ("lastprivate ( ") == MATCH_YES)
{
bool conditional = gfc_match ("conditional : ") == MATCH_YES;
head = NULL;
if (gfc_match_omp_variable_list ("",
&c->lists[OMP_LIST_LASTPRIVATE],
false, NULL, &head) == MATCH_YES)
{
gfc_omp_namelist *n;
for (n = *head; n; n = n->next)
n->u.lastprivate_conditional = conditional;
continue;
}
gfc_current_locus = old_loc;
break;
}
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, false);
gfc_current_locus = old_loc;
*head = NULL;
break;
}
}
if (end_colon && gfc_match (" %e )", &step) != MATCH_YES)
{
gfc_free_omp_namelist (*head, false);
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;
int always_modifier = 0;
int close_modifier = 0;
locus second_always_locus = old_loc2;
locus second_close_locus = old_loc2;
for (;;)
{
locus current_locus = gfc_current_locus;
if (gfc_match ("always ") == MATCH_YES)
{
if (always_modifier++ == 1)
second_always_locus = current_locus;
}
else if (gfc_match ("close ") == MATCH_YES)
{
if (close_modifier++ == 1)
second_close_locus = current_locus;
}
else
break;
gfc_match (", ");
}
gfc_omp_map_op map_op = OMP_MAP_TOFROM;
if (gfc_match ("alloc : ") == MATCH_YES)
map_op = OMP_MAP_ALLOC;
else if (gfc_match ("tofrom : ") == MATCH_YES)
map_op = always_modifier ? OMP_MAP_ALWAYS_TOFROM : OMP_MAP_TOFROM;
else if (gfc_match ("to : ") == MATCH_YES)
map_op = always_modifier ? OMP_MAP_ALWAYS_TO : OMP_MAP_TO;
else if (gfc_match ("from : ") == MATCH_YES)
map_op = always_modifier ? 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
{
gfc_current_locus = old_loc2;
always_modifier = 0;
close_modifier = 0;
}
if (always_modifier > 1)
{
gfc_error ("too many %<always%> modifiers at %L",
&second_always_locus);
break;
}
if (close_modifier > 1)
{
gfc_error ("too many %<close%> modifiers at %L",
&second_close_locus);
break;
}
head = NULL;
if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
false, NULL, &head,
true, true) == MATCH_YES)
{
gfc_omp_namelist *n;
for (n = *head; n; n = n->next)
n->u.map_op = map_op;
continue;
}
gfc_current_locus = old_loc;
break;
}
if ((mask & OMP_CLAUSE_MERGEABLE)
&& (m = gfc_match_dupl_check (!c->mergeable, "mergeable"))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->mergeable = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_MESSAGE)
&& (m = gfc_match_dupl_check (!c->message, "message", true,
&c->message)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
continue;
}
break;
case 'n':
if ((mask & OMP_CLAUSE_NO_CREATE)
&& gfc_match ("no_create ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_IF_PRESENT, true,
allow_derived))
continue;
if ((mask & OMP_CLAUSE_NOGROUP)
&& (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->nogroup = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_NOHOST)
&& (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->nohost = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_NOTEMPORAL)
&& gfc_match_omp_variable_list ("nontemporal (",
&c->lists[OMP_LIST_NONTEMPORAL],
true) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_NOTINBRANCH)
&& (m = gfc_match_dupl_check (!c->notinbranch && !c->inbranch,
"notinbranch")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->notinbranch = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_NOWAIT)
&& (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->nowait = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_NUM_GANGS)
&& (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs",
true)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES)
goto error;
continue;
}
if ((mask & OMP_CLAUSE_NUM_TASKS)
&& (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
if (gfc_match ("strict : ") == MATCH_YES)
c->num_tasks_strict = true;
if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
goto error;
continue;
}
if ((mask & OMP_CLAUSE_NUM_TEAMS)
&& (m = gfc_match_dupl_check (!c->num_teams_upper, "num_teams",
true)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
if (gfc_match ("%e ", &c->num_teams_upper) != MATCH_YES)
goto error;
if (gfc_peek_ascii_char () == ':')
{
c->num_teams_lower = c->num_teams_upper;
c->num_teams_upper = NULL;
if (gfc_match (": %e ", &c->num_teams_upper) != MATCH_YES)
goto error;
}
if (gfc_match (") ") != MATCH_YES)
goto error;
continue;
}
if ((mask & OMP_CLAUSE_NUM_THREADS)
&& (m = gfc_match_dupl_check (!c->num_threads, "num_threads", true,
&c->num_threads)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
continue;
}
if ((mask & OMP_CLAUSE_NUM_WORKERS)
&& (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers",
true, &c->num_workers_expr))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
continue;
}
break;
case 'o':
if ((mask & OMP_CLAUSE_ORDER)
&& (m = gfc_match_dupl_check (!c->order_concurrent, "order ("))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
if (gfc_match (" reproducible : concurrent )") == MATCH_YES)
c->order_reproducible = true;
else if (gfc_match (" concurrent )") == MATCH_YES)
;
else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES)
c->order_unconstrained = true;
else
{
gfc_error ("Expected ORDER(CONCURRENT) at %C "
"with optional %<reproducible%> or "
"%<unconstrained%> modifier");
goto error;
}
c->order_concurrent = true;
continue;
}
if ((mask & OMP_CLAUSE_ORDERED)
&& (m = gfc_match_dupl_check (!c->ordered, "ordered"))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
gfc_expr *cexpr = NULL;
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_COPY)
&& gfc_match ("pcopy ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_TOFROM, true, allow_derived))
continue;
if ((mask & OMP_CLAUSE_COPYIN)
&& gfc_match ("pcopyin ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_TO, true, allow_derived))
continue;
if ((mask & OMP_CLAUSE_COPYOUT)
&& gfc_match ("pcopyout ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_FROM, true, allow_derived))
continue;
if ((mask & OMP_CLAUSE_CREATE)
&& gfc_match ("pcreate ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_ALLOC, true, allow_derived))
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, false,
allow_derived))
continue;
if ((mask & OMP_CLAUSE_COPY)
&& gfc_match ("present_or_copy ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_TOFROM, true,
allow_derived))
continue;
if ((mask & OMP_CLAUSE_COPYIN)
&& gfc_match ("present_or_copyin ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_TO, true, allow_derived))
continue;
if ((mask & OMP_CLAUSE_COPYOUT)
&& gfc_match ("present_or_copyout ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_FROM, true, allow_derived))
continue;
if ((mask & OMP_CLAUSE_CREATE)
&& gfc_match ("present_or_create ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_ALLOC, true, allow_derived))
continue;
if ((mask & OMP_CLAUSE_PRIORITY)
&& (m = gfc_match_dupl_check (!c->priority, "priority", true,
&c->priority)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
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)
&& (m = gfc_match_dupl_check ((c->proc_bind
== OMP_PROC_BIND_UNKNOWN),
"proc_bind", true)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
if (gfc_match ("primary )") == MATCH_YES)
c->proc_bind = OMP_PROC_BIND_PRIMARY;
else if (gfc_match ("master )") == MATCH_YES)
c->proc_bind = OMP_PROC_BIND_MASTER;
else if (gfc_match ("spread )") == MATCH_YES)
c->proc_bind = OMP_PROC_BIND_SPREAD;
else if (gfc_match ("close )") == MATCH_YES)
c->proc_bind = OMP_PROC_BIND_CLOSE;
else
goto error;
continue;
}
break;
case 'r':
if ((mask & OMP_CLAUSE_ATOMIC)
&& (m = gfc_match_dupl_atomic ((c->atomic_op
== GFC_OMP_ATOMIC_UNSET),
"read")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->atomic_op = GFC_OMP_ATOMIC_READ;
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_REDUCTION)
&& gfc_match_omp_clause_reduction (pc, c, openacc,
allow_derived) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_MEMORDER)
&& (m = gfc_match_dupl_memorder ((c->memorder
== OMP_MEMORDER_UNSET),
"relaxed")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->memorder = OMP_MEMORDER_RELAXED;
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_MEMORDER)
&& (m = gfc_match_dupl_memorder ((c->memorder
== OMP_MEMORDER_UNSET),
"release")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->memorder = OMP_MEMORDER_RELEASE;
needs_space = true;
continue;
}
break;
case 's':
if ((mask & OMP_CLAUSE_SAFELEN)
&& (m = gfc_match_dupl_check (!c->safelen_expr, "safelen",
true, &c->safelen_expr))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
continue;
}
if ((mask & OMP_CLAUSE_SCHEDULE)
&& (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE,
"schedule", true)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
int nmodifiers = 0;
locus old_loc2 = gfc_current_locus;
do
{
if (gfc_match ("simd") == MATCH_YES)
{
c->sched_simd = true;
nmodifiers++;
}
else if (gfc_match ("monotonic") == MATCH_YES)
{
c->sched_monotonic = true;
nmodifiers++;
}
else if (gfc_match ("nonmonotonic") == MATCH_YES)
{
c->sched_nonmonotonic = true;
nmodifiers++;
}
else
{
if (nmodifiers)
gfc_current_locus = old_loc2;
break;
}
if (nmodifiers == 1
&& 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)
{
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, true,
allow_derived))
continue;
if ((mask & OMP_CLAUSE_SEQ)
&& (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->seq = true;
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_MEMORDER)
&& (m = gfc_match_dupl_memorder ((c->memorder
== OMP_MEMORDER_UNSET),
"seq_cst")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->memorder = OMP_MEMORDER_SEQ_CST;
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)
&& (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true,
&c->simdlen_expr)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
continue;
}
if ((mask & OMP_CLAUSE_SIMD)
&& (m = gfc_match_dupl_check (!c->simd, "simd")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->simd = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_SEVERITY)
&& (m = gfc_match_dupl_check (!c->severity, "severity", true))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
if (gfc_match ("fatal )") == MATCH_YES)
c->severity = OMP_SEVERITY_FATAL;
else if (gfc_match ("warning )") == MATCH_YES)
c->severity = OMP_SEVERITY_WARNING;
else
{
gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
"at %C");
goto error;
}
continue;
}
break;
case 't':
if ((mask & OMP_CLAUSE_TASK_REDUCTION)
&& gfc_match_omp_clause_reduction (pc, c, openacc,
allow_derived) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_THREAD_LIMIT)
&& (m = gfc_match_dupl_check (!c->thread_limit, "thread_limit",
true, &c->thread_limit))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
continue;
}
if ((mask & OMP_CLAUSE_THREADS)
&& (m = gfc_match_dupl_check (!c->threads, "threads"))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
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)
&& (m = gfc_match_dupl_check (!c->untied, "untied")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->untied = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_ATOMIC)
&& (m = gfc_match_dupl_atomic ((c->atomic_op
== GFC_OMP_ATOMIC_UNSET),
"update")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
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;
if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
&& gfc_match_omp_variable_list
("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR],
false, NULL, NULL, true) == 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)
&& (m = gfc_match_dupl_check (!c->vector_length_expr,
"vector_length", true,
&c->vector_length_expr))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
continue;
}
if ((mask & OMP_CLAUSE_VECTOR)
&& (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->vector = true;
m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_NO)
needs_space = true;
continue;
}
break;
case 'w':
if ((mask & OMP_CLAUSE_WAIT)
&& gfc_match ("wait") == MATCH_YES)
{
m = match_oacc_expr_list (" (", &c->wait_list, false);
if (m == MATCH_ERROR)
goto error;
else if (m == MATCH_NO)
{
gfc_expr *expr
= gfc_get_constant_expr (BT_INTEGER,
gfc_default_integer_kind,
&gfc_current_locus);
mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
gfc_expr_list **expr_list = &c->wait_list;
while (*expr_list)
expr_list = &(*expr_list)->next;
*expr_list = gfc_get_expr_list ();
(*expr_list)->expr = expr;
needs_space = true;
}
continue;
}
if ((mask & OMP_CLAUSE_WEAK)
&& (m = gfc_match_dupl_check (!c->weak, "weak"))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->weak = true;
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_WORKER)
&& (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->worker = true;
m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
if (m == MATCH_ERROR)