Google Git
Sign in
gnu / gcc / refs/tags/releases/gcc-9.5.0 / . / gcc / fortran / openmp.c
blob: 83b1c4487de7cd4702007815c8792ef6023d8417 [file] [log] [blame]
/* OpenMP directive matching and resolving.
Copyright (C) 2005-2019 Free Software Foundation, Inc.
Contributed by Jakub Jelinek
This file is part of GCC.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "gfortran.h"
#include "arith.h"
#include "match.h"
#include "parse.h"
#include "diagnostic.h"
#include "gomp-constants.h"
/* Match an end of OpenMP directive. End of OpenMP directive is optional
whitespace, followed by '\n' or comment '!'. */
match
gfc_match_omp_eos (void)
{
locus old_loc;
char c;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_ascii_char ();
switch (c)
{
case '!':
do
c = gfc_next_ascii_char ();
while (c != '\n');
/* Fall through */
case '\n':
return MATCH_YES;
}
gfc_current_locus = old_loc;
return MATCH_NO;
}
/* Free an omp_clauses structure. */
void
gfc_free_omp_clauses (gfc_omp_clauses *c)
{
int i;
if (c == NULL)
return;
gfc_free_expr (c->if_expr);
gfc_free_expr (c->final_expr);
gfc_free_expr (c->num_threads);
gfc_free_expr (c->chunk_size);
gfc_free_expr (c->safelen_expr);
gfc_free_expr (c->simdlen_expr);
gfc_free_expr (c->num_teams);
gfc_free_expr (c->device);
gfc_free_expr (c->thread_limit);
gfc_free_expr (c->dist_chunk_size);
gfc_free_expr (c->grainsize);
gfc_free_expr (c->hint);
gfc_free_expr (c->num_tasks);
gfc_free_expr (c->priority);
for (i = 0; i < OMP_IF_LAST; i++)
gfc_free_expr (c->if_exprs[i]);
gfc_free_expr (c->async_expr);
gfc_free_expr (c->gang_num_expr);
gfc_free_expr (c->gang_static_expr);
gfc_free_expr (c->worker_expr);
gfc_free_expr (c->vector_expr);
gfc_free_expr (c->num_gangs_expr);
gfc_free_expr (c->num_workers_expr);
gfc_free_expr (c->vector_length_expr);
for (i = 0; i < OMP_LIST_NUM; i++)
gfc_free_omp_namelist (c->lists[i]);
gfc_free_expr_list (c->wait_list);
gfc_free_expr_list (c->tile_list);
free (CONST_CAST (char *, c->critical_name));
free (c);
}
/* Free oacc_declare structures. */
void
gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc)
{
struct gfc_oacc_declare *decl = oc;
do
{
struct gfc_oacc_declare *next;
next = decl->next;
gfc_free_omp_clauses (decl->clauses);
free (decl);
decl = next;
}
while (decl);
}
/* Free expression list. */
void
gfc_free_expr_list (gfc_expr_list *list)
{
gfc_expr_list *n;
for (; list; list = n)
{
n = list->next;
free (list);
}
}
/* Free an !$omp declare simd construct list. */
void
gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
{
if (ods)
{
gfc_free_omp_clauses (ods->clauses);
free (ods);
}
}
void
gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
{
while (list)
{
gfc_omp_declare_simd *current = list;
list = list->next;
gfc_free_omp_declare_simd (current);
}
}
/* Free an !$omp declare reduction. */
void
gfc_free_omp_udr (gfc_omp_udr *omp_udr)
{
if (omp_udr)
{
gfc_free_omp_udr (omp_udr->next);
gfc_free_namespace (omp_udr->combiner_ns);
if (omp_udr->initializer_ns)
gfc_free_namespace (omp_udr->initializer_ns);
free (omp_udr);
}
}
static gfc_omp_udr *
gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
{
gfc_symtree *st;
if (ns == NULL)
ns = gfc_current_ns;
do
{
gfc_omp_udr *omp_udr;
st = gfc_find_symtree (ns->omp_udr_root, name);
if (st != NULL)
{
for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
if (ts == NULL)
return omp_udr;
else if (gfc_compare_types (&omp_udr->ts, ts))
{
if (ts->type == BT_CHARACTER)
{
if (omp_udr->ts.u.cl->length == NULL)
return omp_udr;
if (ts->u.cl->length == NULL)
continue;
if (gfc_compare_expr (omp_udr->ts.u.cl->length,
ts->u.cl->length,
INTRINSIC_EQ) != 0)
continue;
}
return omp_udr;
}
}
/* Don't escape an interface block. */
if (ns && !ns->has_import_set
&& ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
break;
ns = ns->parent;
}
while (ns != NULL);
return NULL;
}
/* Match a variable/common block list and construct a namelist from it. */
static match
gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
bool allow_common, bool *end_colon = NULL,
gfc_omp_namelist ***headp = NULL,
bool allow_sections = false)
{
gfc_omp_namelist *head, *tail, *p;
locus old_loc, cur_loc;
char n[GFC_MAX_SYMBOL_LEN+1];
gfc_symbol *sym;
match m;
gfc_symtree *st;
head = tail = NULL;
old_loc = gfc_current_locus;
m = gfc_match (str);
if (m != MATCH_YES)
return m;
for (;;)
{
cur_loc = gfc_current_locus;
m = gfc_match_symbol (&sym, 1);
switch (m)
{
case MATCH_YES:
gfc_expr *expr;
expr = NULL;
if (allow_sections && gfc_peek_ascii_char () == '(')
{
gfc_current_locus = cur_loc;
m = gfc_match_variable (&expr, 0);
switch (m)
{
case MATCH_ERROR:
goto cleanup;
case MATCH_NO:
goto syntax;
default:
break;
}
}
gfc_set_sym_referenced (sym);
p = gfc_get_omp_namelist ();
if (head == NULL)
head = tail = p;
else
{
tail->next = p;
tail = tail->next;
}
tail->sym = sym;
tail->expr = expr;
tail->where = cur_loc;
goto next_item;
case MATCH_NO:
break;
case MATCH_ERROR:
goto cleanup;
}
if (!allow_common)
goto syntax;
m = gfc_match (" / %n /", n);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
st = gfc_find_symtree (gfc_current_ns->common_root, n);
if (st == NULL)
{
gfc_error ("COMMON block /%s/ not found at %C", n);
goto cleanup;
}
for (sym = st->n.common->head; sym; sym = sym->common_next)
{
gfc_set_sym_referenced (sym);
p = gfc_get_omp_namelist ();
if (head == NULL)
head = tail = p;
else
{
tail->next = p;
tail = tail->next;
}
tail->sym = sym;
tail->where = cur_loc;
}
next_item:
if (end_colon && gfc_match_char (':') == MATCH_YES)
{
*end_colon = true;
break;
}
if (gfc_match_char (')') == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
while (*list)
list = &(*list)->next;
*list = head;
if (headp)
*headp = list;
return MATCH_YES;
syntax:
gfc_error ("Syntax error in OpenMP variable list at %C");
cleanup:
gfc_free_omp_namelist (head);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
/* Match a variable/procedure/common block list and construct a namelist
from it. */
static match
gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
{
gfc_omp_namelist *head, *tail, *p;
locus old_loc, cur_loc;
char n[GFC_MAX_SYMBOL_LEN+1];
gfc_symbol *sym;
match m;
gfc_symtree *st;
head = tail = NULL;
old_loc = gfc_current_locus;
m = gfc_match (str);
if (m != MATCH_YES)
return m;
for (;;)
{
cur_loc = gfc_current_locus;
m = gfc_match_symbol (&sym, 1);
switch (m)
{
case MATCH_YES:
p = gfc_get_omp_namelist ();
if (head == NULL)
head = tail = p;
else
{
tail->next = p;
tail = tail->next;
}
tail->sym = sym;
tail->where = cur_loc;
goto next_item;
case MATCH_NO:
break;
case MATCH_ERROR:
goto cleanup;
}
m = gfc_match (" / %n /", n);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
st = gfc_find_symtree (gfc_current_ns->common_root, n);
if (st == NULL)
{
gfc_error ("COMMON block /%s/ not found at %C", n);
goto cleanup;
}
p = gfc_get_omp_namelist ();
if (head == NULL)
head = tail = p;
else
{
tail->next = p;
tail = tail->next;
}
tail->u.common = st->n.common;
tail->where = cur_loc;
next_item:
if (gfc_match_char (')') == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
while (*list)
list = &(*list)->next;
*list = head;
return MATCH_YES;
syntax:
gfc_error ("Syntax error in OpenMP variable list at %C");
cleanup:
gfc_free_omp_namelist (head);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
/* Match depend(sink : ...) construct a namelist from it. */
static match
gfc_match_omp_depend_sink (gfc_omp_namelist **list)
{
gfc_omp_namelist *head, *tail, *p;
locus old_loc, cur_loc;
gfc_symbol *sym;
head = tail = NULL;
old_loc = gfc_current_locus;
for (;;)
{
cur_loc = gfc_current_locus;
switch (gfc_match_symbol (&sym, 1))
{
case MATCH_YES:
gfc_set_sym_referenced (sym);
p = gfc_get_omp_namelist ();
if (head == NULL)
{
head = tail = p;
head->u.depend_op = OMP_DEPEND_SINK_FIRST;
}
else
{
tail->next = p;
tail = tail->next;
tail->u.depend_op = OMP_DEPEND_SINK;
}
tail->sym = sym;
tail->expr = NULL;
tail->where = cur_loc;
if (gfc_match_char ('+') == MATCH_YES)
{
if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
goto syntax;
}
else if (gfc_match_char ('-') == MATCH_YES)
{
if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
goto syntax;
tail->expr = gfc_uminus (tail->expr);
}
break;
case MATCH_NO:
goto syntax;
case MATCH_ERROR:
goto cleanup;
}
if (gfc_match_char (')') == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
while (*list)
list = &(*list)->next;
*list = head;
return MATCH_YES;
syntax:
gfc_error ("Syntax error in OpenMP DEPEND SINK list at %C");
cleanup:
gfc_free_omp_namelist (head);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
static match
match_oacc_expr_list (const char *str, gfc_expr_list **list,
bool allow_asterisk)
{
gfc_expr_list *head, *tail, *p;
locus old_loc;
gfc_expr *expr;
match m;
head = tail = NULL;
old_loc = gfc_current_locus;
m = gfc_match (str);
if (m != MATCH_YES)
return m;
for (;;)
{
m = gfc_match_expr (&expr);
if (m == MATCH_YES || allow_asterisk)
{
p = gfc_get_expr_list ();
if (head == NULL)
head = tail = p;
else
{
tail->next = p;
tail = tail->next;
}
if (m == MATCH_YES)
tail->expr = expr;
else if (gfc_match (" *") != MATCH_YES)
goto syntax;
goto next_item;
}
if (m == MATCH_ERROR)
goto cleanup;
goto syntax;
next_item:
if (gfc_match_char (')') == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
while (*list)
list = &(*list)->next;
*list = head;
return MATCH_YES;
syntax:
gfc_error ("Syntax error in OpenACC expression list at %C");
cleanup:
gfc_free_expr_list (head);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
static match
match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
{
match ret = MATCH_YES;
if (gfc_match (" ( ") != MATCH_YES)
return MATCH_NO;
if (gwv == GOMP_DIM_GANG)
{
/* The gang clause accepts two optional arguments, num and static.
The num argument may either be explicit (num: <val>) or
implicit without (<val> without num:). */
while (ret == MATCH_YES)
{
if (gfc_match (" static :") == MATCH_YES)
{
if (cp->gang_static)
return MATCH_ERROR;
else
cp->gang_static = true;
if (gfc_match_char ('*') == MATCH_YES)
cp->gang_static_expr = NULL;
else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
return MATCH_ERROR;
}
else
{
if (cp->gang_num_expr)
return MATCH_ERROR;
/* The 'num' argument is optional. */
gfc_match (" num :");
if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
return MATCH_ERROR;
}
ret = gfc_match (" , ");
}
}
else if (gwv == GOMP_DIM_WORKER)
{
/* The 'num' argument is optional. */
gfc_match (" num :");
if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
return MATCH_ERROR;
}
else if (gwv == GOMP_DIM_VECTOR)
{
/* The 'length' argument is optional. */
gfc_match (" length :");
if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
return MATCH_ERROR;
}
else
gfc_fatal_error ("Unexpected OpenACC parallelism.");
return gfc_match (" )");
}
static match
gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
{
gfc_omp_namelist *head = NULL;
gfc_omp_namelist *tail, *p;
locus old_loc;
char n[GFC_MAX_SYMBOL_LEN+1];
gfc_symbol *sym;
match m;
gfc_symtree *st;
old_loc = gfc_current_locus;
m = gfc_match (str);
if (m != MATCH_YES)
return m;
m = gfc_match (" (");
for (;;)
{
m = gfc_match_symbol (&sym, 0);
switch (m)
{
case MATCH_YES:
if (sym->attr.in_common)
{
gfc_error_now ("Variable at %C is an element of a COMMON block");
goto cleanup;
}
gfc_set_sym_referenced (sym);
p = gfc_get_omp_namelist ();
if (head == NULL)
head = tail = p;
else
{
tail->next = p;
tail = tail->next;
}
tail->sym = sym;
tail->expr = NULL;
tail->where = gfc_current_locus;
goto next_item;
case MATCH_NO:
break;
case MATCH_ERROR:
goto cleanup;
}
m = gfc_match (" / %n /", n);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO || n[0] == '\0')
goto syntax;
st = gfc_find_symtree (gfc_current_ns->common_root, n);
if (st == NULL)
{
gfc_error ("COMMON block /%s/ not found at %C", n);
goto cleanup;
}
for (sym = st->n.common->head; sym; sym = sym->common_next)
{
gfc_set_sym_referenced (sym);
p = gfc_get_omp_namelist ();
if (head == NULL)
head = tail = p;
else
{
tail->next = p;
tail = tail->next;
}
tail->sym = sym;
tail->where = gfc_current_locus;
}
next_item:
if (gfc_match_char (')') == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
goto cleanup;
}
while (*list)
list = &(*list)->next;
*list = head;
return MATCH_YES;
syntax:
gfc_error ("Syntax error in !$ACC DECLARE list at %C");
cleanup:
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
/* OpenMP 4.5 clauses. */
enum omp_mask1
{
OMP_CLAUSE_PRIVATE,
OMP_CLAUSE_FIRSTPRIVATE,
OMP_CLAUSE_LASTPRIVATE,
OMP_CLAUSE_COPYPRIVATE,
OMP_CLAUSE_SHARED,
OMP_CLAUSE_COPYIN,
OMP_CLAUSE_REDUCTION,
OMP_CLAUSE_IF,
OMP_CLAUSE_NUM_THREADS,
OMP_CLAUSE_SCHEDULE,
OMP_CLAUSE_DEFAULT,
OMP_CLAUSE_ORDERED,
OMP_CLAUSE_COLLAPSE,
OMP_CLAUSE_UNTIED,
OMP_CLAUSE_FINAL,
OMP_CLAUSE_MERGEABLE,
OMP_CLAUSE_ALIGNED,
OMP_CLAUSE_DEPEND,
OMP_CLAUSE_INBRANCH,
OMP_CLAUSE_LINEAR,
OMP_CLAUSE_NOTINBRANCH,
OMP_CLAUSE_PROC_BIND,
OMP_CLAUSE_SAFELEN,
OMP_CLAUSE_SIMDLEN,
OMP_CLAUSE_UNIFORM,
OMP_CLAUSE_DEVICE,
OMP_CLAUSE_MAP,
OMP_CLAUSE_TO,
OMP_CLAUSE_FROM,
OMP_CLAUSE_NUM_TEAMS,
OMP_CLAUSE_THREAD_LIMIT,
OMP_CLAUSE_DIST_SCHEDULE,
OMP_CLAUSE_DEFAULTMAP,
OMP_CLAUSE_GRAINSIZE,
OMP_CLAUSE_HINT,
OMP_CLAUSE_IS_DEVICE_PTR,
OMP_CLAUSE_LINK,
OMP_CLAUSE_NOGROUP,
OMP_CLAUSE_NUM_TASKS,
OMP_CLAUSE_PRIORITY,
OMP_CLAUSE_SIMD,
OMP_CLAUSE_THREADS,
OMP_CLAUSE_USE_DEVICE_PTR,
OMP_CLAUSE_NOWAIT,
/* This must come last. */
OMP_MASK1_LAST
};
/* OpenACC 2.0 specific clauses. */
enum omp_mask2
{
OMP_CLAUSE_ASYNC,
OMP_CLAUSE_NUM_GANGS,
OMP_CLAUSE_NUM_WORKERS,
OMP_CLAUSE_VECTOR_LENGTH,
OMP_CLAUSE_COPY,
OMP_CLAUSE_COPYOUT,
OMP_CLAUSE_CREATE,
OMP_CLAUSE_PRESENT,
OMP_CLAUSE_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,
/* This must come last. */
OMP_MASK2_LAST
};
struct omp_inv_mask;
/* Customized bitset for up to 128-bits.
The two enums above provide bit numbers to use, and which of the
two enums it is determines which of the two mask fields is used.
Supported operations are defining a mask, like:
#define XXX_CLAUSES \
(omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
oring such bitsets together or removing selected bits:
(XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
and testing individual bits:
if (mask & OMP_CLAUSE_UUU) */
struct omp_mask {
const uint64_t mask1;
const uint64_t mask2;
inline omp_mask ();
inline omp_mask (omp_mask1);
inline omp_mask (omp_mask2);
inline omp_mask (uint64_t, uint64_t);
inline omp_mask operator| (omp_mask1) const;
inline omp_mask operator| (omp_mask2) const;
inline omp_mask operator| (omp_mask) const;
inline omp_mask operator& (const omp_inv_mask &) const;
inline bool operator& (omp_mask1) const;
inline bool operator& (omp_mask2) const;
inline omp_inv_mask operator~ () const;
};
struct omp_inv_mask : public omp_mask {
inline omp_inv_mask (const omp_mask &);
};
omp_mask::omp_mask () : mask1 (0), mask2 (0)
{
}
omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
{
}
omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
{
}
omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
{
}
omp_mask
omp_mask::operator| (omp_mask1 m) const
{
return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
}
omp_mask
omp_mask::operator| (omp_mask2 m) const
{
return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
}
omp_mask
omp_mask::operator| (omp_mask m) const
{
return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
}
omp_mask
omp_mask::operator& (const omp_inv_mask &m) const
{
return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
}
bool
omp_mask::operator& (omp_mask1 m) const
{
return (mask1 & (((uint64_t) 1) << m)) != 0;
}
bool
omp_mask::operator& (omp_mask2 m) const
{
return (mask2 & (((uint64_t) 1) << m)) != 0;
}
omp_inv_mask
omp_mask::operator~ () const
{
return omp_inv_mask (*this);
}
omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
{
}
/* Helper function for OpenACC and OpenMP clauses involving memory
mapping. */
static bool
gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op)
{
gfc_omp_namelist **head = NULL;
if (gfc_match_omp_variable_list ("", list, false, NULL, &head, true)
== MATCH_YES)
{
gfc_omp_namelist *n;
for (n = *head; n; n = n->next)
n->u.map_op = map_op;
return true;
}
return false;
}
/* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
clauses that are allowed for a particular directive. */
static match
gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
bool first = true, bool needs_space = true,
bool openacc = false)
{
gfc_omp_clauses *c = gfc_get_omp_clauses ();
locus old_loc;
gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
*cp = NULL;
while (1)
{
if ((first || gfc_match_char (',') != MATCH_YES)
&& (needs_space && gfc_match_space () != MATCH_YES))
break;
needs_space = false;
first = false;
gfc_gobble_whitespace ();
bool end_colon;
gfc_omp_namelist **head;
old_loc = gfc_current_locus;
char pc = gfc_peek_ascii_char ();
switch (pc)
{
case 'a':
end_colon = false;
head = NULL;
if ((mask & OMP_CLAUSE_ALIGNED)
&& gfc_match_omp_variable_list ("aligned (",
&c->lists[OMP_LIST_ALIGNED],
false, &end_colon,
&head) == MATCH_YES)
{
gfc_expr *alignment = NULL;
gfc_omp_namelist *n;
if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
{
gfc_free_omp_namelist (*head);
gfc_current_locus = old_loc;
*head = NULL;
break;
}
for (n = *head; n; n = n->next)
if (n->next && alignment)
n->expr = gfc_copy_expr (alignment);
else
n->expr = alignment;
continue;
}
if ((mask & OMP_CLAUSE_ASYNC)
&& !c->async
&& gfc_match ("async") == MATCH_YES)
{
c->async = true;
match m = gfc_match (" ( %e )", &c->async_expr);
if (m == MATCH_ERROR)
{
gfc_current_locus = old_loc;
break;
}
else if (m == MATCH_NO)
{
c->async_expr
= gfc_get_constant_expr (BT_INTEGER,
gfc_default_integer_kind,
&gfc_current_locus);
mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
needs_space = true;
}
continue;
}
if ((mask & OMP_CLAUSE_AUTO)
&& !c->par_auto
&& gfc_match ("auto") == MATCH_YES)
{
c->par_auto = true;
needs_space = true;
continue;
}
break;
case 'c':
if ((mask & OMP_CLAUSE_COLLAPSE)
&& !c->collapse)
{
gfc_expr *cexpr = NULL;
match m = gfc_match ("collapse ( %e )", &cexpr);
if (m == MATCH_YES)
{
int collapse;
if (gfc_extract_int (cexpr, &collapse, -1))
collapse = 1;
else if (collapse <= 0)
{
gfc_error_now ("COLLAPSE clause argument not"
" constant positive integer at %C");
collapse = 1;
}
c->collapse = collapse;
gfc_free_expr (cexpr);
continue;
}
}
if ((mask & OMP_CLAUSE_COPY)
&& gfc_match ("copy ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_TOFROM))
continue;
if (mask & OMP_CLAUSE_COPYIN)
{
if (openacc)
{
if (gfc_match ("copyin ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_TO))
continue;
}
else if (gfc_match_omp_variable_list ("copyin (",
&c->lists[OMP_LIST_COPYIN],
true) == MATCH_YES)
continue;
}
if ((mask & OMP_CLAUSE_COPYOUT)
&& gfc_match ("copyout ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_FROM))
continue;
if ((mask & OMP_CLAUSE_COPYPRIVATE)
&& gfc_match_omp_variable_list ("copyprivate (",
&c->lists[OMP_LIST_COPYPRIVATE],
true) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_CREATE)
&& gfc_match ("create ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_ALLOC))
continue;
break;
case 'd':
if ((mask & OMP_CLAUSE_DEFAULT)
&& c->default_sharing == OMP_DEFAULT_UNKNOWN)
{
if (gfc_match ("default ( none )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_NONE;
else if (openacc)
{
if (gfc_match ("default ( present )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_PRESENT;
}
else
{
if (gfc_match ("default ( firstprivate )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
else if (gfc_match ("default ( private )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_PRIVATE;
else if (gfc_match ("default ( shared )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_SHARED;
}
if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
continue;
}
if ((mask & OMP_CLAUSE_DEFAULTMAP)
&& !c->defaultmap
&& gfc_match ("defaultmap ( tofrom : scalar )") == MATCH_YES)
{
c->defaultmap = true;
continue;
}
if ((mask & OMP_CLAUSE_DELETE)
&& gfc_match ("delete ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_RELEASE))
continue;
if ((mask & OMP_CLAUSE_DEPEND)
&& gfc_match ("depend ( ") == MATCH_YES)
{
match m = MATCH_YES;
gfc_omp_depend_op depend_op = OMP_DEPEND_OUT;
if (gfc_match ("inout") == MATCH_YES)
depend_op = OMP_DEPEND_INOUT;
else if (gfc_match ("in") == MATCH_YES)
depend_op = OMP_DEPEND_IN;
else if (gfc_match ("out") == MATCH_YES)
depend_op = OMP_DEPEND_OUT;
else if (!c->depend_source
&& gfc_match ("source )") == MATCH_YES)
{
c->depend_source = true;
continue;
}
else if (gfc_match ("sink : ") == MATCH_YES)
{
if (gfc_match_omp_depend_sink (&c->lists[OMP_LIST_DEPEND])
== MATCH_YES)
continue;
m = MATCH_NO;
}
else
m = MATCH_NO;
head = NULL;
if (m == MATCH_YES
&& gfc_match_omp_variable_list (" : ",
&c->lists[OMP_LIST_DEPEND],
false, NULL, &head,
true) == MATCH_YES)
{
gfc_omp_namelist *n;
for (n = *head; n; n = n->next)
n->u.depend_op = depend_op;
continue;
}
else
gfc_current_locus = old_loc;
}
if ((mask & OMP_CLAUSE_DEVICE)
&& !openacc
&& c->device == NULL
&& gfc_match ("device ( %e )", &c->device) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_DEVICE)
&& openacc
&& gfc_match ("device ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_FORCE_TO))
continue;
if ((mask & OMP_CLAUSE_DEVICEPTR)
&& gfc_match ("deviceptr ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_FORCE_DEVICEPTR))
continue;
if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
&& gfc_match_omp_variable_list
("device_resident (",
&c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
&& c->dist_sched_kind == OMP_SCHED_NONE
&& gfc_match ("dist_schedule ( static") == MATCH_YES)
{
match m = MATCH_NO;
c->dist_sched_kind = OMP_SCHED_STATIC;
m = gfc_match (" , %e )", &c->dist_chunk_size);
if (m != MATCH_YES)
m = gfc_match_char (')');
if (m != MATCH_YES)
{
c->dist_sched_kind = OMP_SCHED_NONE;
gfc_current_locus = old_loc;
}
else
continue;
}
break;
case 'f':
if ((mask & OMP_CLAUSE_FINAL)
&& c->final_expr == NULL
&& gfc_match ("final ( %e )", &c->final_expr) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_FINALIZE)
&& !c->finalize
&& gfc_match ("finalize") == MATCH_YES)
{
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)
&& !c->gang
&& gfc_match ("gang") == MATCH_YES)
{
c->gang = true;
match m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
if (m == MATCH_ERROR)
{
gfc_current_locus = old_loc;
break;
}
else if (m == MATCH_NO)
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_GRAINSIZE)
&& c->grainsize == NULL
&& gfc_match ("grainsize ( %e )", &c->grainsize) == MATCH_YES)
continue;
break;
case 'h':
if ((mask & OMP_CLAUSE_HINT)
&& c->hint == NULL
&& gfc_match ("hint ( %e )", &c->hint) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_HOST_SELF)
&& gfc_match ("host ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_FORCE_FROM))
continue;
break;
case 'i':
if ((mask & OMP_CLAUSE_IF)
&& c->if_expr == NULL
&& gfc_match ("if ( ") == MATCH_YES)
{
if (gfc_match ("%e )", &c->if_expr) == MATCH_YES)
continue;
if (!openacc)
{
/* This should match the enum gfc_omp_if_kind order. */
static const char *ifs[OMP_IF_LAST] = {
" parallel : %e )",
" task : %e )",
" taskloop : %e )",
" target : %e )",
" target data : %e )",
" target update : %e )",
" target enter data : %e )",
" target exit data : %e )" };
int i;
for (i = 0; i < OMP_IF_LAST; i++)
if (c->if_exprs[i] == NULL
&& gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
break;
if (i < OMP_IF_LAST)
continue;
}
gfc_current_locus = old_loc;
}
if ((mask & OMP_CLAUSE_IF_PRESENT)
&& !c->if_present
&& gfc_match ("if_present") == MATCH_YES)
{
c->if_present = true;
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_INBRANCH)
&& !c->inbranch
&& !c->notinbranch
&& gfc_match ("inbranch") == MATCH_YES)
{
c->inbranch = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_INDEPENDENT)
&& !c->independent
&& gfc_match ("independent") == MATCH_YES)
{
c->independent = true;
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
&& gfc_match_omp_variable_list
("is_device_ptr (",
&c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
continue;
break;
case 'l':
if ((mask & OMP_CLAUSE_LASTPRIVATE)
&& gfc_match_omp_variable_list ("lastprivate (",
&c->lists[OMP_LIST_LASTPRIVATE],
true) == MATCH_YES)
continue;
end_colon = false;
head = NULL;
if ((mask & OMP_CLAUSE_LINEAR)
&& gfc_match ("linear (") == MATCH_YES)
{
gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
gfc_expr *step = NULL;
if (gfc_match_omp_variable_list (" ref (",
&c->lists[OMP_LIST_LINEAR],
false, NULL, &head)
== MATCH_YES)
linear_op = OMP_LINEAR_REF;
else if (gfc_match_omp_variable_list (" val (",
&c->lists[OMP_LIST_LINEAR],
false, NULL, &head)
== MATCH_YES)
linear_op = OMP_LINEAR_VAL;
else if (gfc_match_omp_variable_list (" uval (",
&c->lists[OMP_LIST_LINEAR],
false, NULL, &head)
== MATCH_YES)
linear_op = OMP_LINEAR_UVAL;
else if (gfc_match_omp_variable_list ("",
&c->lists[OMP_LIST_LINEAR],
false, &end_colon, &head)
== MATCH_YES)
linear_op = OMP_LINEAR_DEFAULT;
else
{
gfc_current_locus = old_loc;
break;
}
if (linear_op != OMP_LINEAR_DEFAULT)
{
if (gfc_match (" :") == MATCH_YES)
end_colon = true;
else if (gfc_match (" )") != MATCH_YES)
{
gfc_free_omp_namelist (*head);
gfc_current_locus = old_loc;
*head = NULL;
break;
}
}
if (end_colon && gfc_match (" %e )", &step) != MATCH_YES)
{
gfc_free_omp_namelist (*head);
gfc_current_locus = old_loc;
*head = NULL;
break;
}
else if (!end_colon)
{
step = gfc_get_constant_expr (BT_INTEGER,
gfc_default_integer_kind,
&old_loc);
mpz_set_si (step->value.integer, 1);
}
(*head)->expr = step;
if (linear_op != OMP_LINEAR_DEFAULT)
for (gfc_omp_namelist *n = *head; n; n = n->next)
n->u.linear_op = linear_op;
continue;
}
if ((mask & OMP_CLAUSE_LINK)
&& openacc
&& (gfc_match_oacc_clause_link ("link (",
&c->lists[OMP_LIST_LINK])
== MATCH_YES))
continue;
else if ((mask & OMP_CLAUSE_LINK)
&& !openacc
&& (gfc_match_omp_to_link ("link (",
&c->lists[OMP_LIST_LINK])
== MATCH_YES))
continue;
break;
case 'm':
if ((mask & OMP_CLAUSE_MAP)
&& gfc_match ("map ( ") == MATCH_YES)
{
locus old_loc2 = gfc_current_locus;
bool always = false;
gfc_omp_map_op map_op = OMP_MAP_TOFROM;
if (gfc_match ("always , ") == MATCH_YES)
always = true;
if (gfc_match ("alloc : ") == MATCH_YES)
map_op = OMP_MAP_ALLOC;
else if (gfc_match ("tofrom : ") == MATCH_YES)
map_op = always ? OMP_MAP_ALWAYS_TOFROM : OMP_MAP_TOFROM;
else if (gfc_match ("to : ") == MATCH_YES)
map_op = always ? OMP_MAP_ALWAYS_TO : OMP_MAP_TO;
else if (gfc_match ("from : ") == MATCH_YES)
map_op = always ? OMP_MAP_ALWAYS_FROM : OMP_MAP_FROM;
else if (gfc_match ("release : ") == MATCH_YES)
map_op = OMP_MAP_RELEASE;
else if (gfc_match ("delete : ") == MATCH_YES)
map_op = OMP_MAP_DELETE;
else if (always)
{
gfc_current_locus = old_loc2;
always = false;
}
head = NULL;
if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
false, NULL, &head,
true) == MATCH_YES)
{
gfc_omp_namelist *n;
for (n = *head; n; n = n->next)
n->u.map_op = map_op;
continue;
}
else
gfc_current_locus = old_loc;
}
if ((mask & OMP_CLAUSE_MERGEABLE) && !c->mergeable
&& gfc_match ("mergeable") == MATCH_YES)
{
c->mergeable = needs_space = true;
continue;
}
break;
case 'n':
if ((mask & OMP_CLAUSE_NOGROUP)
&& !c->nogroup
&& gfc_match ("nogroup") == MATCH_YES)
{
c->nogroup = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_NOTINBRANCH)
&& !c->notinbranch
&& !c->inbranch
&& gfc_match ("notinbranch") == MATCH_YES)
{
c->notinbranch = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_NOWAIT)
&& !c->nowait
&& gfc_match ("nowait") == MATCH_YES)
{
c->nowait = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_NUM_GANGS)
&& c->num_gangs_expr == NULL
&& gfc_match ("num_gangs ( %e )",
&c->num_gangs_expr) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_NUM_TASKS)
&& c->num_tasks == NULL
&& gfc_match ("num_tasks ( %e )", &c->num_tasks) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_NUM_TEAMS)
&& c->num_teams == NULL
&& gfc_match ("num_teams ( %e )", &c->num_teams) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_NUM_THREADS)
&& c->num_threads == NULL
&& (gfc_match ("num_threads ( %e )", &c->num_threads)
== MATCH_YES))
continue;
if ((mask & OMP_CLAUSE_NUM_WORKERS)
&& c->num_workers_expr == NULL
&& gfc_match ("num_workers ( %e )",
&c->num_workers_expr) == MATCH_YES)
continue;
break;
case 'o':
if ((mask & OMP_CLAUSE_ORDERED)
&& !c->ordered
&& gfc_match ("ordered") == MATCH_YES)
{
gfc_expr *cexpr = NULL;
match m = gfc_match (" ( %e )", &cexpr);
c->ordered = true;
if (m == MATCH_YES)
{
int ordered = 0;
if (gfc_extract_int (cexpr, &ordered, -1))
ordered = 0;
else if (ordered <= 0)
{
gfc_error_now ("ORDERED clause argument not"
" constant positive integer at %C");
ordered = 0;
}
c->orderedc = ordered;
gfc_free_expr (cexpr);
continue;
}
needs_space = true;
continue;
}
break;
case 'p':
if ((mask & OMP_CLAUSE_COPY)
&& gfc_match ("pcopy ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_TOFROM))
continue;
if ((mask & OMP_CLAUSE_COPYIN)
&& gfc_match ("pcopyin ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_TO))
continue;
if ((mask & OMP_CLAUSE_COPYOUT)
&& gfc_match ("pcopyout ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_FROM))
continue;
if ((mask & OMP_CLAUSE_CREATE)
&& gfc_match ("pcreate ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_ALLOC))
continue;
if ((mask & OMP_CLAUSE_PRESENT)
&& gfc_match ("present ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_FORCE_PRESENT))
continue;
if ((mask & OMP_CLAUSE_COPY)
&& gfc_match ("present_or_copy ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_TOFROM))
continue;
if ((mask & OMP_CLAUSE_COPYIN)
&& gfc_match ("present_or_copyin ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_TO))
continue;
if ((mask & OMP_CLAUSE_COPYOUT)
&& gfc_match ("present_or_copyout ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_FROM))
continue;
if ((mask & OMP_CLAUSE_CREATE)
&& gfc_match ("present_or_create ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_ALLOC))
continue;
if ((mask & OMP_CLAUSE_PRIORITY)
&& c->priority == NULL
&& gfc_match ("priority ( %e )", &c->priority) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_PRIVATE)
&& gfc_match_omp_variable_list ("private (",
&c->lists[OMP_LIST_PRIVATE],
true) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_PROC_BIND)
&& c->proc_bind == OMP_PROC_BIND_UNKNOWN)
{
if (gfc_match ("proc_bind ( master )") == MATCH_YES)
c->proc_bind = OMP_PROC_BIND_MASTER;
else if (gfc_match ("proc_bind ( spread )") == MATCH_YES)
c->proc_bind = OMP_PROC_BIND_SPREAD;
else if (gfc_match ("proc_bind ( close )") == MATCH_YES)
c->proc_bind = OMP_PROC_BIND_CLOSE;
if (c->proc_bind != OMP_PROC_BIND_UNKNOWN)
continue;
}
break;
case 'r':
if ((mask & OMP_CLAUSE_REDUCTION)
&& gfc_match ("reduction ( ") == MATCH_YES)
{
gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
char buffer[GFC_MAX_SYMBOL_LEN + 3];
if (gfc_match_char ('+') == MATCH_YES)
rop = OMP_REDUCTION_PLUS;
else if (gfc_match_char ('*') == MATCH_YES)
rop = OMP_REDUCTION_TIMES;
else if (gfc_match_char ('-') == MATCH_YES)
rop = OMP_REDUCTION_MINUS;
else if (gfc_match (".and.") == MATCH_YES)
rop = OMP_REDUCTION_AND;
else if (gfc_match (".or.") == MATCH_YES)
rop = OMP_REDUCTION_OR;
else if (gfc_match (".eqv.") == MATCH_YES)
rop = OMP_REDUCTION_EQV;
else if (gfc_match (".neqv.") == MATCH_YES)
rop = OMP_REDUCTION_NEQV;
if (rop != OMP_REDUCTION_NONE)
snprintf (buffer, sizeof buffer, "operator %s",
gfc_op2string ((gfc_intrinsic_op) rop));
else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
{
buffer[0] = '.';
strcat (buffer, ".");
}
else if (gfc_match_name (buffer) == MATCH_YES)
{
gfc_symbol *sym;
const char *n = buffer;
gfc_find_symbol (buffer, NULL, 1, &sym);
if (sym != NULL)
{
if (sym->attr.intrinsic)
n = sym->name;
else if ((sym->attr.flavor != FL_UNKNOWN
&& sym->attr.flavor != FL_PROCEDURE)
|| sym->attr.external
|| sym->attr.generic
|| sym->attr.entry
|| sym->attr.result
|| sym->attr.dummy
|| sym->attr.subroutine
|| sym->attr.pointer
|| sym->attr.target
|| sym->attr.cray_pointer
|| sym->attr.cray_pointee
|| (sym->attr.proc != PROC_UNKNOWN
&& sym->attr.proc != PROC_INTRINSIC)
|| sym->attr.if_source != IFSRC_UNKNOWN
|| sym == sym->ns->proc_name)
{
sym = NULL;
n = NULL;
}
else
n = sym->name;
}
if (n == NULL)
rop = OMP_REDUCTION_NONE;
else if (strcmp (n, "max") == 0)
rop = OMP_REDUCTION_MAX;
else if (strcmp (n, "min") == 0)
rop = OMP_REDUCTION_MIN;
else if (strcmp (n, "iand") == 0)
rop = OMP_REDUCTION_IAND;
else if (strcmp (n, "ior") == 0)
rop = OMP_REDUCTION_IOR;
else if (strcmp (n, "ieor") == 0)
rop = OMP_REDUCTION_IEOR;
if (rop != OMP_REDUCTION_NONE
&& sym != NULL
&& ! sym->attr.intrinsic
&& ! sym->attr.use_assoc
&& ((sym->attr.flavor == FL_UNKNOWN
&& !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
sym->name, NULL))
|| !gfc_add_intrinsic (&sym->attr, NULL)))
rop = OMP_REDUCTION_NONE;
}
else
buffer[0] = '\0';
gfc_omp_udr *udr
= (buffer[0]
? gfc_find_omp_udr (gfc_current_ns, buffer, NULL) : NULL);
gfc_omp_namelist **head = NULL;
if (rop == OMP_REDUCTION_NONE && udr)
rop = OMP_REDUCTION_USER;
if (gfc_match_omp_variable_list (" :",
&c->lists[OMP_LIST_REDUCTION],
false, NULL, &head,
openacc) == MATCH_YES)
{
gfc_omp_namelist *n;
if (rop == OMP_REDUCTION_NONE)
{
n = *head;
*head = NULL;
gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
"at %L", buffer, &old_loc);
gfc_free_omp_namelist (n);
}
else
for (n = *head; n; n = n->next)
{
n->u.reduction_op = rop;
if (udr)
{
n->udr = gfc_get_omp_namelist_udr ();
n->udr->udr = udr;
}
}
continue;
}
else
gfc_current_locus = old_loc;
}
break;
case 's':
if ((mask & OMP_CLAUSE_SAFELEN)
&& c->safelen_expr == NULL
&& gfc_match ("safelen ( %e )", &c->safelen_expr) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_SCHEDULE)
&& c->sched_kind == OMP_SCHED_NONE
&& gfc_match ("schedule ( ") == MATCH_YES)
{
int nmodifiers = 0;
locus old_loc2 = gfc_current_locus;
do
{
if (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)
{
match m = MATCH_NO;
if (c->sched_kind != OMP_SCHED_RUNTIME
&& c->sched_kind != OMP_SCHED_AUTO)
m = gfc_match (" , %e )", &c->chunk_size);
if (m != MATCH_YES)
m = gfc_match_char (')');
if (m != MATCH_YES)
c->sched_kind = OMP_SCHED_NONE;
}
if (c->sched_kind != OMP_SCHED_NONE)
continue;
else
gfc_current_locus = old_loc;
}
if ((mask & OMP_CLAUSE_HOST_SELF)
&& gfc_match ("self ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_FORCE_FROM))
continue;
if ((mask & OMP_CLAUSE_SEQ)
&& !c->seq
&& gfc_match ("seq") == MATCH_YES)
{
c->seq = true;
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_SHARED)
&& gfc_match_omp_variable_list ("shared (",
&c->lists[OMP_LIST_SHARED],
true) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_SIMDLEN)
&& c->simdlen_expr == NULL
&& gfc_match ("simdlen ( %e )", &c->simdlen_expr) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_SIMD)
&& !c->simd
&& gfc_match ("simd") == MATCH_YES)
{
c->simd = needs_space = true;
continue;
}
break;
case 't':
if ((mask & OMP_CLAUSE_THREAD_LIMIT)
&& c->thread_limit == NULL
&& gfc_match ("thread_limit ( %e )",
&c->thread_limit) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_THREADS)
&& !c->threads
&& gfc_match ("threads") == MATCH_YES)
{
c->threads = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_TILE)
&& !c->tile_list
&& match_oacc_expr_list ("tile (", &c->tile_list,
true) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
{
if (gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO])
== MATCH_YES)
continue;
}
else if ((mask & OMP_CLAUSE_TO)
&& gfc_match_omp_variable_list ("to (",
&c->lists[OMP_LIST_TO], false,
NULL, &head, true) == MATCH_YES)
continue;
break;
case 'u':
if ((mask & OMP_CLAUSE_UNIFORM)
&& gfc_match_omp_variable_list ("uniform (",
&c->lists[OMP_LIST_UNIFORM],
false) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_UNTIED)
&& !c->untied
&& gfc_match ("untied") == MATCH_YES)
{
c->untied = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_USE_DEVICE)
&& gfc_match_omp_variable_list ("use_device (",
&c->lists[OMP_LIST_USE_DEVICE],
true) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
&& gfc_match_omp_variable_list
("use_device_ptr (",
&c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
continue;
break;
case 'v':
/* VECTOR_LENGTH must be matched before VECTOR, because the latter
doesn't unconditionally match '('. */
if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
&& c->vector_length_expr == NULL
&& (gfc_match ("vector_length ( %e )", &c->vector_length_expr)
== MATCH_YES))
continue;
if ((mask & OMP_CLAUSE_VECTOR)
&& !c->vector
&& gfc_match ("vector") == MATCH_YES)
{
c->vector = true;
match m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
if (m == MATCH_ERROR)
{
gfc_current_locus = old_loc;
break;
}
if (m == MATCH_NO)
needs_space = true;
continue;
}
break;
case 'w':
if ((mask & OMP_CLAUSE_WAIT)
&& gfc_match ("wait") == MATCH_YES)
{
match m = match_oacc_expr_list (" (", &c->wait_list, false);
if (m == MATCH_ERROR)
{
gfc_current_locus = old_loc;
break;
}
else if (m == MATCH_NO)
{
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_WORKER)
&& !c->worker
&& gfc_match ("worker") == MATCH_YES)
{
c->worker = true;
match m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
if (m == MATCH_ERROR)
{
gfc_current_locus = old_loc;
break;
}
else if (m == MATCH_NO)
needs_space = true;
continue;
}
break;
}
break;
}
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_free_omp_clauses (c);
return MATCH_ERROR;
}
*cp = c;
return MATCH_YES;
}
#define OACC_PARALLEL_CLAUSES \
(omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
| OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
| OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
| OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_DEVICEPTR \
| OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULT \
| OMP_CLAUSE_WAIT)
#define OACC_KERNELS_CLAUSES \
(omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
| OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
| OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
| OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_DEFAULT \
| OMP_CLAUSE_WAIT)
#define OACC_DATA_CLAUSES \
(omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
| OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
| OMP_CLAUSE_PRESENT)
#define OACC_LOOP_CLAUSES \
(omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
| OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
| OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
| OMP_CLAUSE_TILE)
#define OACC_PARALLEL_LOOP_CLAUSES \
(OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
#define OACC_KERNELS_LOOP_CLAUSES \
(OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
#define OACC_HOST_DATA_CLAUSES omp_mask (OMP_CLAUSE_USE_DEVICE)
#define OACC_DECLARE_CLAUSES \
(omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
| OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
| OMP_CLAUSE_PRESENT \
| OMP_CLAUSE_LINK)
#define OACC_UPDATE_CLAUSES \
(omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \
| OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT)
#define OACC_ENTER_DATA_CLAUSES \
(omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
| OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE)
#define OACC_EXIT_DATA_CLAUSES \
(omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
| OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE)
#define OACC_WAIT_CLAUSES \
omp_mask (OMP_CLAUSE_ASYNC)
#define OACC_ROUTINE_CLAUSES \
(omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
| OMP_CLAUSE_SEQ)
static match
match_acc (gfc_exec_op op, const omp_mask mask)
{
gfc_omp_clauses *c;
if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
return MATCH_ERROR;
new_st.op = op;
new_st.ext.omp_clauses = c;
return MATCH_YES;
}
match
gfc_match_oacc_parallel_loop (void)
{
return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
}
match
gfc_match_oacc_parallel (void)
{
return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
}
match
gfc_match_oacc_kernels_loop (void)
{
return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
}
match
gfc_match_oacc_kernels (void)
{
return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
}
match
gfc_match_oacc_data (void)
{
return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
}
match
gfc_match_oacc_host_data (void)
{
return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
}
match
gfc_match_oacc_loop (void)
{
return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
}
match
gfc_match_oacc_declare (void)
{
gfc_omp_clauses *c;
gfc_omp_namelist *n;
gfc_namespace *ns = gfc_current_ns;
gfc_oacc_declare *new_oc;
bool module_var = false;
locus where = gfc_current_locus;
if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
!= MATCH_YES)
return MATCH_ERROR;
for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
n->sym->attr.oacc_declare_device_resident = 1;
for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
n->sym->attr.oacc_declare_link = 1;
for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
{
gfc_symbol *s = n->sym;
if (s->ns->proc_name && s->ns->proc_name->attr.proc == PROC_MODULE)
{
if (n->u.map_op != OMP_MAP_ALLOC && n->u.map_op != OMP_MAP_TO)
{
gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
&where);
return MATCH_ERROR;
}
module_var = true;
}
if (s->attr.use_assoc)
{
gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
&where);
return MATCH_ERROR;
}
if ((s->attr.dimension || s->attr.codimension)
&& s->attr.dummy && s->as->type != AS_EXPLICIT)
{
gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
&where);
return MATCH_ERROR;
}
switch (n->u.map_op)
{
case OMP_MAP_FORCE_ALLOC:
case OMP_MAP_ALLOC:
s->attr.oacc_declare_create = 1;
break;
case OMP_MAP_FORCE_TO:
case OMP_MAP_TO:
s->attr.oacc_declare_copyin = 1;
break;
case OMP_MAP_FORCE_DEVICEPTR:
s->attr.oacc_declare_deviceptr = 1;
break;
default:
break;
}
}
new_oc = gfc_get_oacc_declare ();
new_oc->next = ns->oacc_declare;
new_oc->module_var = module_var;
new_oc->clauses = c;
new_oc->loc = gfc_current_locus;
ns->oacc_declare = new_oc;
return MATCH_YES;
}
match
gfc_match_oacc_update (void)
{
gfc_omp_clauses *c;
locus here = gfc_current_locus;
if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
!= MATCH_YES)
return MATCH_ERROR;
if (!c->lists[OMP_LIST_MAP])
{
gfc_error ("%<acc update%> must contain at least one "
"%<device%> or %<host%> or %<self%> clause at %L", &here);
return MATCH_ERROR;
}
new_st.op = EXEC_OACC_UPDATE;
new_st.ext.omp_clauses = c;
return MATCH_YES;
}
match
gfc_match_oacc_enter_data (void)
{
return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
}
match
gfc_match_oacc_exit_data (void)
{
return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
}
match
gfc_match_oacc_wait (void)
{
gfc_omp_clauses *c = gfc_get_omp_clauses ();
gfc_expr_list *wait_list = NULL, *el;
bool space = true;
match m;
m = match_oacc_expr_list (" (", &wait_list, true);
if (m == MATCH_ERROR)
return m;
else if (m == MATCH_YES)
space = false;
if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
== MATCH_ERROR)
return MATCH_ERROR;
if (wait_list)
for (el = wait_list; el; el = el->next)
{
if (el->expr == NULL)
{
gfc_error ("Invalid argument to !$ACC WAIT at %C");
return MATCH_ERROR;
}
if (!gfc_resolve_expr (el->expr)
|| el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
{
gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
&el->expr->where);
return MATCH_ERROR;
}
}
c->wait_list = wait_list;
new_st.op = EXEC_OACC_WAIT;
new_st.ext.omp_clauses = c;
return MATCH_YES;
}
match
gfc_match_oacc_cache (void)
{
gfc_omp_clauses *c = gfc_get_omp_clauses ();
/* The OpenACC cache directive explicitly only allows "array elements or
subarrays", which we're currently not checking here. Either check this
after the call of gfc_match_omp_variable_list, or add something like a
only_sections variant next to its allow_sections parameter. */
match m = gfc_match_omp_variable_list (" (",
&c->lists[OMP_LIST_CACHE], true,
NULL, NULL, true);
if (m != MATCH_YES)
{
gfc_free_omp_clauses(c);
return m;
}
if (gfc_current_state() != COMP_DO
&& gfc_current_state() != COMP_DO_CONCURRENT)
{
gfc_error ("ACC CACHE directive must be inside of loop %C");
gfc_free_omp_clauses(c);
return MATCH_ERROR;
}
new_st.op = EXEC_OACC_CACHE;
new_st.ext.omp_clauses = c;
return MATCH_YES;
}
/* Determine the OpenACC 'routine' directive's level of parallelism. */
static oacc_routine_lop
gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
{
oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
if (clauses)
{
unsigned n_lop_clauses = 0;
if (clauses->gang)
{
++n_lop_clauses;
ret = OACC_ROUTINE_LOP_GANG;
}
if (clauses->worker)
{
++n_lop_clauses;
ret = OACC_ROUTINE_LOP_WORKER;
}
if (clauses->vector)
{
++n_lop_clauses;
ret = OACC_ROUTINE_LOP_VECTOR;
}
if (clauses->seq)
{
++n_lop_clauses;
ret = OACC_ROUTINE_LOP_SEQ;
}
if (n_lop_clauses > 1)
ret = OACC_ROUTINE_LOP_ERROR;
}
return ret;
}
match
gfc_match_oacc_routine (void)
{
locus old_loc;
match m;
gfc_intrinsic_sym *isym = NULL;
gfc_symbol *sym = NULL;
gfc_omp_clauses *c = NULL;
gfc_oacc_routine_name *n = NULL;
oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
old_loc = gfc_current_locus;
m = gfc_match (" (");
if (gfc_current_ns->proc_name
&& gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
&& m == MATCH_YES)
{
gfc_error ("Only the !$ACC ROUTINE form without "
"list is allowed in interface block at %C");
goto cleanup;
}
if (m == MATCH_YES)
{
char buffer[GFC_MAX_SYMBOL_LEN + 1];
m = gfc_match_name (buffer);
if (m == MATCH_YES)
{
gfc_symtree *st = NULL;
/* First look for an intrinsic symbol. */
isym = gfc_find_function (buffer);
if (!isym)
isym = gfc_find_subroutine (buffer);
/* If no intrinsic symbol found, search the current namespace. */
if (!isym)
st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
if (st)
{
sym = st->n.sym;
/* If the name in a 'routine' directive refers to the containing
subroutine or function, then make sure that we'll later handle
this accordingly. */
if (gfc_current_ns->proc_name != NULL
&& strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
sym = NULL;
}
if (isym == NULL && st == NULL)
{
gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
buffer);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
}
else
{
gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
if (gfc_match_char (')') != MATCH_YES)
{
gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
" ')' after NAME");
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
}
if (gfc_match_omp_eos () != MATCH_YES
&& (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
!= MATCH_YES))
return MATCH_ERROR;
lop = gfc_oacc_routine_lop (c);
if (lop == OACC_ROUTINE_LOP_ERROR)
{
gfc_error ("Multiple loop axes specified for routine at %C");
goto cleanup;
}
if (isym != NULL)
{
/* Diagnose any OpenACC 'routine' directive that doesn't match the
(implicit) one with a 'seq' clause. */
if (c && (c->gang || c->worker || c->vector))
{
gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
" at %C marked with incompatible GANG, WORKER, or VECTOR"
" clause");
goto cleanup;
}
}
else if (sym != NULL)
{
bool add = true;
/* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
match the first one. */
for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
n_p;
n_p = n_p->next)
if (n_p->sym == sym)
{
add = false;
if (lop != gfc_oacc_routine_lop (n_p->clauses))
{
gfc_error ("!$ACC ROUTINE already applied at %C");
goto cleanup;
}
}
if (add)
{
sym->attr.oacc_routine_lop = lop;
n = gfc_get_oacc_routine_name ();
n->sym = sym;
n->clauses = c;
n->next = gfc_current_ns->oacc_routine_names;
n->loc = old_loc;
gfc_current_ns->oacc_routine_names = n;
}
}
else if (gfc_current_ns->proc_name)
{
/* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
match the first one. */
oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
if (lop_p != OACC_ROUTINE_LOP_NONE
&& lop != lop_p)
{
gfc_error ("!$ACC ROUTINE already applied at %C");
goto cleanup;
}
if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
gfc_current_ns->proc_name->name,
&old_loc))
goto cleanup;
gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
}
else
/* Something has gone wrong, possibly a syntax error. */
goto cleanup;
if (n)
n->clauses = c;
else if (gfc_current_ns->oacc_routine)
gfc_current_ns->oacc_routine_clauses = c;
new_st.op = EXEC_OACC_ROUTINE;
new_st.ext.omp_clauses = c;
return MATCH_YES;
cleanup:
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
#define OMP_PARALLEL_CLAUSES \
(omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
| OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
| OMP_CLAUSE_PROC_BIND)
#define OMP_DECLARE_SIMD_CLAUSES \
(omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
| OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
| OMP_CLAUSE_NOTINBRANCH)
#define OMP_DO_CLAUSES \
(omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
| OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
| OMP_CLAUSE_LINEAR)
#define OMP_SECTIONS_CLAUSES \
(omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
#define OMP_SIMD_CLAUSES \
(omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
| OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
| OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN)
#define OMP_TASK_CLAUSES \
(omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
| OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
| OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY)
#define OMP_TASKLOOP_CLAUSES \
(omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
| OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
| OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
| OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP)
#define OMP_TARGET_CLAUSES \
(omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
| OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
| OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
| OMP_CLAUSE_IS_DEVICE_PTR)
#define OMP_TARGET_DATA_CLAUSES \
(omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
| OMP_CLAUSE_USE_DEVICE_PTR)
#define OMP_TARGET_ENTER_DATA_CLAUSES \
(omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
| OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
#define OMP_TARGET_EXIT_DATA_CLAUSES \
(omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
| OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
#define OMP_TARGET_UPDATE_CLAUSES \
(omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
| OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
#define OMP_TEAMS_CLAUSES \
(omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
| OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION)
#define OMP_DISTRIBUTE_CLAUSES \
(omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE)
#define OMP_SINGLE_CLAUSES \
(omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE)
#define OMP_ORDERED_CLAUSES \
(omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
#define OMP_DECLARE_TARGET_CLAUSES \
(omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK)
static match
match_omp (gfc_exec_op op, const omp_mask mask)
{
gfc_omp_clauses *c;
if (gfc_match_omp_clauses (&c, mask) != MATCH_YES)
return MATCH_ERROR;
new_st.op = op;
new_st.ext.omp_clauses = c;
return MATCH_YES;
}
match
gfc_match_omp_critical (void)
{
char n[GFC_MAX_SYMBOL_LEN+1];
gfc_omp_clauses *c = NULL;
if (gfc_match (" ( %n )", n) != MATCH_YES)
{
n[0] = '\0';
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
return MATCH_ERROR;
}
}
else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT)) != MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_CRITICAL;
new_st.ext.omp_clauses = c;
if (n[0])
c->critical_name = xstrdup (n);
return MATCH_YES;
}
match
gfc_match_omp_end_critical (void)
{
char n[GFC_MAX_SYMBOL_LEN+1];
if (gfc_match (" ( %n )", n) != MATCH_YES)
n[0] = '\0';
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
return MATCH_ERROR;
}
new_st.op = EXEC_OMP_END_CRITICAL;
new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
return MATCH_YES;
}
match
gfc_match_omp_distribute (void)
{
return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
}
match
gfc_match_omp_distribute_parallel_do (void)
{
return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
(OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES)
& ~(omp_mask (OMP_CLAUSE_ORDERED))
& ~(omp_mask (OMP_CLAUSE_LINEAR)));
}
match
gfc_match_omp_distribute_parallel_do_simd (void)
{
return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
(OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
& ~(omp_mask (OMP_CLAUSE_ORDERED)));
}
match
gfc_match_omp_distribute_simd (void)
{
return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
}
match
gfc_match_omp_do (void)
{
return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
}
match
gfc_match_omp_do_simd (void)
{
return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
}
match
gfc_match_omp_flush (void)
{
gfc_omp_namelist *list = NULL;
gfc_match_omp_variable_list (" (", &list, true);
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
gfc_free_omp_namelist (list);
return MATCH_ERROR;
}
new_st.op = EXEC_OMP_FLUSH;
new_st.ext.omp_namelist = list;
return MATCH_YES;
}
match
gfc_match_omp_declare_simd (void)
{
locus where = gfc_current_locus;
gfc_symbol *proc_name;
gfc_omp_clauses *c;
gfc_omp_declare_simd *ods;
bool needs_space = false;
switch (gfc_match (" ( %s ) ", &proc_name))
{
case MATCH_YES: break;
case MATCH_NO: proc_name = NULL; needs_space = true; break;
case MATCH_ERROR: return MATCH_ERROR;
}
if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
needs_space) != MATCH_YES)
return MATCH_ERROR;
if (gfc_current_ns->is_block_data)
{
gfc_free_omp_clauses (c);
return MATCH_YES;
}
ods = gfc_get_omp_declare_simd ();
ods->where = where;
ods->proc_name = proc_name;
ods->clauses = c;
ods->next = gfc_current_ns->omp_declare_simd;
gfc_current_ns->omp_declare_simd = ods;
return MATCH_YES;
}
static bool
match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
{
match m;
locus old_loc = gfc_current_locus;
char sname[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
gfc_namespace *ns = gfc_current_ns;
gfc_expr *lvalue = NULL, *rvalue = NULL;
gfc_symtree *st;
gfc_actual_arglist *arglist;
m = gfc_match (" %v =", &lvalue);
if (m != MATCH_YES)
gfc_current_locus = old_loc;
else
{
m = gfc_match (" %e )", &rvalue);
if (m == MATCH_YES)
{
ns->code = gfc_get_code (EXEC_ASSIGN);
ns->code->expr1 = lvalue;
ns->code->expr2 = rvalue;
ns->code->loc = old_loc;
return true;
}
gfc_current_locus = old_loc;
gfc_free_expr (lvalue);
}
m = gfc_match (" %n", sname);
if (m != MATCH_YES)
return false;
if (strcmp (sname, omp_sym1->name) == 0
|| strcmp (sname, omp_sym2->name) == 0)
return false;
gfc_current_ns = ns->parent;
if (gfc_get_ha_sym_tree (sname, &st))
return false;
sym = st->n.sym;
if (sym->attr.flavor != FL_PROCEDURE
&& sym->attr.flavor != FL_UNKNOWN)
return false;
if (!sym->attr.generic
&& !sym->attr.subroutine
&& !sym->attr.function)
{
if (!(sym->attr.external && !sym->attr.referenced))
{
/* ...create a symbol in this scope... */
if (sym->ns != gfc_current_ns
&& gfc_get_sym_tree (sname, NULL, &st, false) == 1)
return false;
if (sym != st->n.sym)
sym = st->n.sym;
}
/* ...and then to try to make the symbol into a subroutine. */
if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
return false;
}
gfc_set_sym_referenced (sym);
gfc_gobble_whitespace ();
if (gfc_peek_ascii_char () != '(')
return false;
gfc_current_ns = ns;
m = gfc_match_actual_arglist (1, &arglist);
if (m != MATCH_YES)
return false;
if (gfc_match_char (')') != MATCH_YES)
return false;
ns->code = gfc_get_code (EXEC_CALL);
ns->code->symtree = st;
ns->code->ext.actual = arglist;
ns->code->loc = old_loc;
return true;
}
static bool
gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
gfc_typespec *ts, const char **n)
{
if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
return false;
switch (rop)
{
case OMP_REDUCTION_PLUS:
case OMP_REDUCTION_MINUS:
case OMP_REDUCTION_TIMES:
return ts->type != BT_LOGICAL;
case OMP_REDUCTION_AND:
case OMP_REDUCTION_OR:
case OMP_REDUCTION_EQV:
case OMP_REDUCTION_NEQV:
return ts->type == BT_LOGICAL;
case OMP_REDUCTION_USER:
if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
{
gfc_symbol *sym;
gfc_find_symbol (name, NULL, 1, &sym);
if (sym != NULL)
{
if (sym->attr.intrinsic)
*n = sym->name;
else if ((sym->attr.flavor != FL_UNKNOWN
&& sym->attr.flavor != FL_PROCEDURE)
|| sym->attr.external
|| sym->attr.generic
|| sym->attr.entry
|| sym->attr.result
|| sym->attr.dummy
|| sym->attr.subroutine
|| sym->attr.pointer
|| sym->attr.target
|| sym->attr.cray_pointer
|| sym->attr.cray_pointee
|| (sym->attr.proc != PROC_UNKNOWN
&& sym->attr.proc != PROC_INTRINSIC)
|| sym->attr.if_source != IFSRC_UNKNOWN
|| sym == sym->ns->proc_name)
*n = NULL;
else
*n = sym->name;
}
else
*n = name;
if (*n
&& (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
return true;
else if (*n
&& ts->type == BT_INTEGER
&& (strcmp (*n, "iand") == 0
|| strcmp (*n, "ior") == 0
|| strcmp (*n, "ieor") == 0))
return true;
}
break;
default:
break;
}
return false;
}
gfc_omp_udr *
gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
{
gfc_omp_udr *omp_udr;
if (st == NULL)
return NULL;
for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
if (omp_udr->ts.type == ts->type
|| ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
&& (ts->type == BT_DERIVED || ts->type == BT_CLASS)))
{
if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
{
if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
return omp_udr;
}
else if (omp_udr->ts.kind == ts->kind)
{
if (omp_udr->ts.type == BT_CHARACTER)
{
if (omp_udr->ts.u.cl->length == NULL
|| ts->u.cl->length == NULL)
return omp_udr;
if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
return omp_udr;
if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
return omp_udr;
if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
return omp_udr;
if (ts->u.cl->length->ts.type != BT_INTEGER)
return omp_udr;
if (gfc_compare_expr (omp_udr->ts.u.cl->length,
ts->u.cl->length, INTRINSIC_EQ) != 0)
continue;
}
return omp_udr;
}
}
return NULL;
}
match
gfc_match_omp_declare_reduction (void)
{
match m;
gfc_intrinsic_op op;
char name[GFC_MAX_SYMBOL_LEN + 3];
auto_vec<gfc_typespec, 5> tss;
gfc_typespec ts;
unsigned int i;
gfc_symtree *st;
locus where = gfc_current_locus;
locus end_loc = gfc_current_locus;
bool end_loc_set = false;
gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
if (gfc_match_char ('(') != MATCH_YES)
return MATCH_ERROR;
m = gfc_match (" %o : ", &op);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_YES)
{
snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
rop = (gfc_omp_reduction_op) op;
}
else
{
m = gfc_match_defined_op_name (name + 1, 1);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_YES)
{
name[0] = '.';
strcat (name, ".");
if (gfc_match (" : ") != MATCH_YES)
return MATCH_ERROR;
}
else
{
if (gfc_match (" %n : ", name) != MATCH_YES)
return MATCH_ERROR;
}
rop = OMP_REDUCTION_USER;
}
m = gfc_match_type_spec (&ts);
if (m != MATCH_YES)
return MATCH_ERROR;
/* Treat len=: the same as len=*. */
if (ts.type == BT_CHARACTER)
ts.deferred = false;
tss.safe_push (ts);
while (gfc_match_char (',') == MATCH_YES)
{
m = gfc_match_type_spec (&ts);
if (m != MATCH_YES)
return MATCH_ERROR;
tss.safe_push (ts);
}
if (gfc_match_char (':') != MATCH_YES)
return MATCH_ERROR;
st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
for (i = 0; i < tss.length (); i++)
{
gfc_symtree *omp_out, *omp_in;
gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
gfc_namespace *combiner_ns, *initializer_ns = NULL;
gfc_omp_udr *prev_udr, *omp_udr;
const char *predef_name = NULL;
omp_udr = gfc_get_omp_udr ();
omp_udr->name = gfc_get_string ("%s", name);
omp_udr->rop = rop;
omp_udr->ts = tss[i];
omp_udr->where = where;
gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
combiner_ns->proc_name = combiner_ns->parent->proc_name;
gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
combiner_ns->omp_udr_ns = 1;
omp_out->n.sym->ts = tss[i];
omp_in->n.sym->ts = tss[i];
omp_out->n.sym->attr.omp_udr_artificial_var = 1;
omp_in->n.sym->attr.omp_udr_artificial_var = 1;
omp_out->n.sym->attr.flavor = FL_VARIABLE;
omp_in->n.sym->attr.flavor = FL_VARIABLE;
gfc_commit_symbols ();
omp_udr->combiner_ns = combiner_ns;
omp_udr->omp_out = omp_out->n.sym;
omp_udr->omp_in = omp_in->n.sym;
locus old_loc = gfc_current_locus;
if (!match_udr_expr (omp_out, omp_in))
{
syntax:
gfc_current_locus = old_loc;
gfc_current_ns = combiner_ns->parent;
gfc_undo_symbols ();
gfc_free_omp_udr (omp_udr);
return MATCH_ERROR;
}
if (gfc_match (" initializer ( ") == MATCH_YES)
{
gfc_current_ns = combiner_ns->parent;
initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
gfc_current_ns = initializer_ns;
initializer_ns->proc_name = initializer_ns->parent->proc_name;
gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
initializer_ns->omp_udr_ns = 1;
omp_priv->n.sym->ts = tss[i];
omp_orig->n.sym->ts = tss[i];
omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
omp_priv->n.sym->attr.flavor = FL_VARIABLE;
omp_orig->n.sym->attr.flavor = FL_VARIABLE;
gfc_commit_symbols ();
omp_udr->initializer_ns = initializer_ns;
omp_udr->omp_priv = omp_priv->n.sym;
omp_udr->omp_orig = omp_orig->n.sym;
if (!match_udr_expr (omp_priv, omp_orig))
goto syntax;
}
gfc_current_ns = combiner_ns->parent;
if (!end_loc_set)
{
end_loc_set = true;
end_loc = gfc_current_locus;
}
gfc_current_locus = old_loc;
prev_udr = gfc_omp_udr_find (st, &tss[i]);
if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
/* Don't error on !$omp declare reduction (min : integer : ...)
just yet, there could be integer :: min afterwards,
making it valid. When the UDR is resolved, we'll get
to it again. */
&& (rop != OMP_REDUCTION_USER || name[0] == '.'))
{
if (predef_name)
gfc_error_now ("Redefinition of predefined %s "
"!$OMP DECLARE REDUCTION at %L",
predef_name, &where);
else
gfc_error_now ("Redefinition of predefined "
"!$OMP DECLARE REDUCTION at %L", &where);
}
else if (prev_udr)
{
gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
&where);
gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
&prev_udr->where);
}
else if (st)
{
omp_udr->next = st->n.omp_udr;
st->n.omp_udr = omp_udr;
}
else
{
st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
st->n.omp_udr = omp_udr;
}
}
if (end_loc_set)
{
gfc_current_locus = end_loc;
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
gfc_current_locus = where;
return MATCH_ERROR;
}
return MATCH_YES;
}
gfc_clear_error ();
return MATCH_ERROR;
}
match
gfc_match_omp_declare_target (void)
{
locus old_loc;
match m<