Google Git
Sign in
gnu / gcc / feeb0d68f1c7085199c3734e6517a3a4b58309ef / . / gcc / fortran / openmp.cc
blob: e0e3b52ad57f9952c1a9586ee884f1f769a5f4ad [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. */
#include "bitmap.h"
static gfc_statement omp_code_to_statement (gfc_code *);
enum gfc_omp_directive_kind {
GFC_OMP_DIR_DECLARATIVE,
GFC_OMP_DIR_EXECUTABLE,
GFC_OMP_DIR_INFORMATIONAL,
GFC_OMP_DIR_META,
GFC_OMP_DIR_SUBSIDIARY,
GFC_OMP_DIR_UTILITY
};
struct gfc_omp_directive {
const char *name;
enum gfc_omp_directive_kind kind;
gfc_statement st;
};
/* Alphabetically sorted OpenMP clauses, except that longer strings are before
substrings; excludes combined/composite directives. See note for "ordered"
and "nothing". */
static const struct gfc_omp_directive gfc_omp_directives[] = {
/* {"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE}, */
/* {"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS}, */
{"assumes", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUMES},
{"assume", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUME},
{"atomic", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ATOMIC},
{"barrier", GFC_OMP_DIR_EXECUTABLE, ST_OMP_BARRIER},
{"cancellation point", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCELLATION_POINT},
{"cancel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCEL},
{"critical", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CRITICAL},
/* {"declare mapper", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_MAPPER}, */
{"declare reduction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_REDUCTION},
{"declare simd", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_SIMD},
{"declare target", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_TARGET},
{"declare variant", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_VARIANT},
{"depobj", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DEPOBJ},
/* {"dispatch", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISPATCH}, */
{"distribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISTRIBUTE},
{"do", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DO},
/* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */
{"error", GFC_OMP_DIR_UTILITY, ST_OMP_ERROR},
{"flush", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSH},
/* {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP}, */
{"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP},
{"masked", GFC_OMP_DIR_EXECUTABLE, ST_OMP_MASKED},
/* {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE}, */
/* Note: gfc_match_omp_nothing returns ST_NONE. */
{"nothing", GFC_OMP_DIR_UTILITY, ST_OMP_NOTHING},
/* Special case; for now map to the first one.
ordered-blockassoc = ST_OMP_ORDERED
ordered-standalone = ST_OMP_ORDERED_DEPEND + depend/doacross. */
{"ordered", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ORDERED},
{"parallel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_PARALLEL},
{"requires", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_REQUIRES},
{"scan", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SCAN},
{"scope", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SCOPE},
{"sections", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SECTIONS},
{"section", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SECTION},
{"simd", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SIMD},
{"single", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SINGLE},
{"target data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_DATA},
{"target enter data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_ENTER_DATA},
{"target exit data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_EXIT_DATA},
{"target update", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_UPDATE},
{"target", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET},
{"taskloop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKLOOP},
{"taskwait", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKWAIT},
{"taskyield", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKYIELD},
{"task", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK},
{"teams", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TEAMS},
{"threadprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_THREADPRIVATE},
/* {"tile", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TILE}, */
/* {"unroll", GFC_OMP_DIR_EXECUTABLE, ST_OMP_UNROLL}, */
{"workshare", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKSHARE},
};
/* 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));
if (c->assume)
{
free (c->assume->absent);
free (c->assume->contains);
gfc_free_expr_list (c->assume->holds);
free (c->assume);
}
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;
if has_all_memory != NULL, *has_all_memory is set and omp_all_memory
yields a list->sym NULL entry. */
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,
bool *has_all_memory = NULL)
{
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;
if (has_all_memory)
*has_all_memory = false;
m = gfc_match (str);
if (m != MATCH_YES)
return m;
for (;;)
{
cur_loc = gfc_current_locus;
m = gfc_match_name (n);
if (m == MATCH_YES && strcmp (n, "omp_all_memory") == 0)
{
if (!has_all_memory)
{
gfc_error ("%<omp_all_memory%> at %C not permitted in this "
"clause");
goto cleanup;
}
*has_all_memory = true;
p = gfc_get_omp_namelist ();
if (head == NULL)
head = tail = p;
else
{
tail->next = p;
tail = tail->next;
}
tail->where = cur_loc;
goto next_item;
}
if (m == MATCH_YES)
{
gfc_symtree *st;
if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES)
== MATCH_YES)
sym = st->n.sym;
}
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 doacross(sink : ...) construct a namelist from it;
if depend is true, match legacy 'depend(sink : ...)'. */
static match
gfc_match_omp_doacross_sink (gfc_omp_namelist **list, bool depend)
{
char n[GFC_MAX_SYMBOL_LEN+1];
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;
if (gfc_match_name (n) != MATCH_YES)
goto syntax;
if (UNLIKELY (strcmp (n, "omp_all_memory") == 0))
{
gfc_error ("%<omp_all_memory%> used with dependence-type "
"other than OUT or INOUT at %C");
goto cleanup;
}
sym = NULL;
if (!(strcmp (n, "omp_cur_iteration") == 0))
{
gfc_symtree *st;
if (gfc_get_ha_sym_tree (n, &st))
goto syntax;
sym = st->n.sym;
gfc_set_sym_referenced (sym);
}
p = gfc_get_omp_namelist ();
if (head == NULL)
{
head = tail = p;
head->u.depend_doacross_op = (depend ? OMP_DEPEND_SINK_FIRST
: OMP_DOACROSS_SINK_FIRST);
}
else
{
tail->next = p;
tail = tail->next;
tail->u.depend_doacross_op = OMP_DOACROSS_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);
}
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 SINK dependence-type 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 */
OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
OMP_CLAUSE_ASSUMPTIONS, /* 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 ())
{
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;
}
static match
gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
{
if (*assume == NULL)
*assume = gfc_get_omp_assumptions ();
do
{
gfc_statement st = ST_NONE;
gfc_gobble_whitespace ();
locus old_loc = gfc_current_locus;
char c = gfc_peek_ascii_char ();
enum gfc_omp_directive_kind kind
= GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */
for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++)
{
if (gfc_omp_directives[i].name[0] > c)
break;
if (gfc_omp_directives[i].name[0] != c)
continue;
if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES)
{
st = gfc_omp_directives[i].st;
kind = gfc_omp_directives[i].kind;
}
}
gfc_gobble_whitespace ();
c = gfc_peek_ascii_char ();
if (st == ST_NONE || (c != ',' && c != ')'))
{
if (st == ST_NONE)
gfc_error ("Unknown directive at %L", &old_loc);
else
gfc_error ("Invalid combined or composit directive at %L",
&old_loc);
return MATCH_ERROR;
}
if (kind == GFC_OMP_DIR_DECLARATIVE
|| kind == GFC_OMP_DIR_INFORMATIONAL
|| kind == GFC_OMP_DIR_META)
{
gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
"informational and meta directives not permitted",
gfc_ascii_statement (st, true), &old_loc,
is_absent ? "ABSENT" : "CONTAINS");
return MATCH_ERROR;
}
if (is_absent)
{
/* Use exponential allocation; equivalent to pow2p(x). */
int i = (*assume)->n_absent;
int size = ((i == 0) ? 4
: pow2p_hwi (i) == 1 ? i*2 : 0);
if (size != 0)
(*assume)->absent = XRESIZEVEC (gfc_statement,
(*assume)->absent, size);
(*assume)->absent[(*assume)->n_absent++] = st;
}
else
{
int i = (*assume)->n_contains;
int size = ((i == 0) ? 4
: pow2p_hwi (i) == 1 ? i*2 : 0);
if (size != 0)
(*assume)->contains = XRESIZEVEC (gfc_statement,
(*assume)->contains, size);
(*assume)->contains[(*assume)->n_contains++] = st;
}
gfc_gobble_whitespace ();
if (gfc_match(",") == MATCH_YES)
continue;
if (gfc_match(")") == MATCH_YES)
break;
gfc_error ("Expected %<,%> or %<)%> at %C");
return MATCH_ERROR;
}
while (true);
return MATCH_YES;
}
/* Check 'check' argument for duplicated statements in absent and/or contains
clauses. If 'merge', merge them from check to 'merge'. */
static match
omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
gfc_omp_assumptions *merge, locus *loc)
{
if (check == NULL)
return MATCH_YES;
bitmap_head absent_head, contains_head;
bitmap_obstack_initialize (NULL);
bitmap_initialize (&absent_head, &bitmap_default_obstack);
bitmap_initialize (&contains_head, &bitmap_default_obstack);
match m = MATCH_YES;
for (int i = 0; i < check->n_absent; i++)
if (!bitmap_set_bit (&absent_head, check->absent[i]))
{
gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
"directive at %L",
gfc_ascii_statement (check->absent[i], true),
"ABSENT", gfc_ascii_statement (st), loc);
m = MATCH_ERROR;
}
for (int i = 0; i < check->n_contains; i++)
{
if (!bitmap_set_bit (&contains_head, check->contains[i]))
{
gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
"directive at %L",
gfc_ascii_statement (check->contains[i], true),
"CONTAINS", gfc_ascii_statement (st), loc);
m = MATCH_ERROR;
}
if (bitmap_bit_p (&absent_head, check->contains[i]))
{
gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS "
"clauses in %s directive at %L",
gfc_ascii_statement (check->absent[i], true),
gfc_ascii_statement (st), loc);
m = MATCH_ERROR;
}
}
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (merge == NULL)
return MATCH_YES;
if (merge->absent == NULL && check->absent)
{
merge->n_absent = check->n_absent;
merge->absent = check->absent;
check->absent = NULL;
}
else if (merge->absent && check->absent)
{
check->absent = XRESIZEVEC (gfc_statement, check->absent,
merge->n_absent + check->n_absent);
for (int i = 0; i < merge->n_absent; i++)
if (!bitmap_bit_p (&absent_head, merge->absent[i]))
check->absent[check->n_absent++] = merge->absent[i];
free (merge->absent);
merge->absent = check->absent;
merge->n_absent = check->n_absent;
check->absent = NULL;
}
if (merge->contains == NULL && check->contains)
{
merge->n_contains = check->n_contains;
merge->contains = check->contains;
check->contains = NULL;
}
else if (merge->contains && check->contains)
{
check->contains = XRESIZEVEC (gfc_statement, check->contains,
merge->n_contains + check->n_contains);
for (int i = 0; i < merge->n_contains; i++)
if (!bitmap_bit_p (&contains_head, merge->contains[i]))
check->contains[check->n_contains++] = merge->contains[i];
free (merge->contains);
merge->contains = check->contains;
merge->n_contains = check->n_contains;
check->contains = 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_ASSUMPTIONS)
&& gfc_match ("absent ( ") == MATCH_YES)
{
if (gfc_omp_absent_contains_clause (&c->assume, true)
!= MATCH_YES)
goto error;
continue;
}
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_ASSUMPTIONS)
&& gfc_match ("contains ( ") == MATCH_YES)
{
if (gfc_omp_absent_contains_clause (&c->assume, false)
!= MATCH_YES)
goto error;
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;
/* DOACROSS: match 'doacross' and 'depend' with sink/source.
DEPEND: match 'depend' but not sink/source. */
m = MATCH_NO;
if (((mask & OMP_CLAUSE_DOACROSS)
&& gfc_match ("doacross ( ") == MATCH_YES)
|| (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS))
&& (m = gfc_match ("depend ( ")) == MATCH_YES))
{
bool has_omp_all_memory;
bool is_depend = m == MATCH_YES;
gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
match m_it = MATCH_NO;
if (is_depend)
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_doacross_op depend_op = OMP_DEPEND_OUT;
if (gfc_match ("inoutset") == MATCH_YES)
depend_op = OMP_DEPEND_INOUTSET;
else 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 (gfc_match ("source") == MATCH_YES)
{
if (m_it == MATCH_YES)
{
gfc_error ("ITERATOR may not be combined with SOURCE "
"at %C");
goto error;
}
if (!(mask & OMP_CLAUSE_DOACROSS))
{
gfc_error ("SOURCE at %C not permitted as dependence-type"
" for this directive");
goto error;
}
if (c->doacross_source)
{
gfc_error ("Duplicated clause with SOURCE dependence-type"
" at %C");
goto error;
}
gfc_gobble_whitespace ();
m = gfc_match (": ");
if (m != MATCH_YES && !is_depend)
{
gfc_error ("Expected %<:%> at %C");
goto error;
}
if (gfc_match (")") != MATCH_YES
&& !(m == MATCH_YES
&& gfc_match ("omp_cur_iteration )") == MATCH_YES))
{
gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> "
"at %C");
goto error;
}
c->doacross_source = true;
c->depend_source = is_depend;
continue;
}
else if (gfc_match ("sink ") == MATCH_YES)
{
if (!(mask & OMP_CLAUSE_DOACROSS))
{
gfc_error ("SINK at %C not permitted as dependence-type "
"for this directive");
goto error;
}
if (gfc_match (": ") != MATCH_YES)
{
gfc_error ("Expected %<:%> at %C");
goto error;
}
if (m_it == MATCH_YES)
{
gfc_error ("ITERATOR may not be combined with SINK "
"at %C");
goto error;
}
m = gfc_match_omp_doacross_sink (&c->lists[OMP_LIST_DEPEND],
is_depend);
if (m == MATCH_YES)
continue;
goto error;
}
else
m = MATCH_NO;
if (!(mask & OMP_CLAUSE_DEPEND))
{
gfc_error ("Expected dependence-type SINK or SOURCE at %C");
goto error;
}
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,
false, &has_omp_all_memory);
if (m != MATCH_YES)
goto error;
gfc_current_ns = ns_curr;
if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT
&& depend_op != OMP_DEPEND_OUT)
{
gfc_error ("%<omp_all_memory%> used with DEPEND kind "
"other than OUT or INOUT at %C");
goto error;
}
gfc_omp_namelist *n;
for (n = *head; n; n = n->next)
{
n->u.depend_doacross_op = depend_op;
n->u2.ns = ns_iter;
if (ns_iter)
ns_iter->refs++;
}
continue;
}
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)
{
bool has_requires = false;
c->ancestor = true;
for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
{
has_requires = true;
break;
}
if (!has_requires)
{
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 'e':
if ((mask & OMP_CLAUSE_ENTER))
{
m = gfc_match_omp_to_link ("enter (", &c->lists[OMP_LIST_ENTER]);
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_YES)
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, 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_ASSUMPTIONS)
&& gfc_match ("holds ( ") == MATCH_YES)
{
gfc_expr *e;
if (gfc_match ("%e )", &e) != MATCH_YES)
goto error;
if (c->assume == NULL)
c->assume = gfc_get_omp_assumptions ();
gfc_expr_list *el = XCNEW (gfc_expr_list);
el->expr = e;
el->next = c->assume->holds;
c->assume->holds = el;
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)
{
bool old_linear_modifier = false;
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;
old_linear_modifier = true;
}
else if (gfc_match_omp_variable_list (" val (",
&c->lists[OMP_LIST_LINEAR],
false, NULL, &head)
== MATCH_YES)
{
linear_op = OMP_LINEAR_VAL;
old_linear_modifier = true;
}
else if (gfc_match_omp_variable_list (" uval (",
&c->lists[OMP_LIST_LINEAR],
false, NULL, &head)
== MATCH_YES)
{
linear_op = OMP_LINEAR_UVAL;
old_linear_modifier = true;
}
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;
}
}
gfc_gobble_whitespace ();
if (old_linear_modifier && end_colon)
{
if (gfc_match (" %e )", &step) != MATCH_YES)
{
gfc_free_omp_namelist (*head, false);
gfc_current_locus = old_loc;
*head = NULL;
goto error;
}
}
else if (end_colon)
{
bool has_error = false;
bool has_modifiers = false;
bool has_step = false;
bool duplicate_step = false;
bool duplicate_mod = false;
while (true)
{
old_loc = gfc_current_locus;
bool close_paren = gfc_match ("val )") == MATCH_YES;
if (close_paren || gfc_match ("val , ") == MATCH_YES)
{
if (linear_op != OMP_LINEAR_DEFAULT)
{
duplicate_mod = true;
break;
}
linear_op = OMP_LINEAR_VAL;
has_modifiers = true;
if (close_paren)
break;
continue;
}
close_paren = gfc_match ("uval )") == MATCH_YES;
if (close_paren || gfc_match ("uval , ") == MATCH_YES)
{
if (linear_op != OMP_LINEAR_DEFAULT)
{
duplicate_mod = true;
break;
}
linear_op = OMP_LINEAR_UVAL;
has_modifiers = true;
if (close_paren)
break;
continue;
}
close_paren = gfc_match ("ref )") == MATCH_YES;
if (close_paren || gfc_match ("ref , ") == MATCH_YES)
{
if (linear_op != OMP_LINEAR_DEFAULT)
{
duplicate_mod = true;
break;
}
linear_op = OMP_LINEAR_REF;
has_modifiers = true;
if (close_paren)
break;
continue;
}
close_paren = (gfc_match ("step ( %e ) )", &step)
== MATCH_YES);
if (close_paren
|| gfc_match ("step ( %e ) , ", &step) == MATCH_YES)
{
if (has_step)
{
duplicate_step = true;
break;
}
has_modifiers = has_step = true;
if (close_paren)
break;
continue;
}
if (!has_modifiers
&& gfc_match ("%e )", &step) == MATCH_YES)
{
if ((step->expr_type == EXPR_FUNCTION
|| step->expr_type == EXPR_VARIABLE)
&& strcmp (step->symtree->name, "step") == 0)
{
gfc_current_locus = old_loc;
gfc_match ("step (");
has_error = true;
}
break;
}
has_error = true;
break;
}
if (duplicate_mod || duplicate_step)
{
gfc_error ("Multiple %qs modifiers specified at %C",
duplicate_mod ? "linear" : "step");
has_error = true;
}
if (has_error)
{
gfc_free_omp_namelist (*head, false);
*head = NULL;
goto error;
}
}
if (step == NULL)
{
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 || old_linear_modifier)
for (gfc_omp_namelist *n = *head; n; n = n->next)
{
n->u.linear.op = linear_op;
n->u.linear.old_modifier = old_linear_modifier;
}
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_ASSUMPTIONS)
&& (m = gfc_match_dupl_check (!c->assume
|| !c->assume->no_openmp_routines,
"no_openmp_routines")) == MATCH_YES)
{
if (m == MATCH_ERROR)
goto error;
if (c->assume == NULL)
c->assume = gfc_get_omp_assumptions ();
c->assume->no_openmp_routines = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_ASSUMPTIONS)
&& (m = gfc_match_dupl_check (!c->assume || !c->assume->no_openmp,
"no_openmp")) == MATCH_YES)
{
if (m == MATCH_ERROR)
goto error;
if (c->assume == NULL)
c->assume = gfc_get_omp_assumptions ();
c->assume->no_openmp = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_ASSUMPTIONS)
&& (m = gfc_match_dupl_check (!c->assume
|| !c->assume->no_parallelism,
"no_parallelism")) == MATCH_YES)
{
if (m == MATCH_ERROR)
goto error;
if (c->assume == NULL)
c->assume = gfc_get_omp_assumptions ();
c->assume->no_parallelism = needs_space = true;
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)
{
</