#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
#include "match.h"
#include "parse.h"
#include "pointer-set.h"
#include "target.h"
#include "toplev.h"
match
gfc_match_omp_eos (void)
{
locus old_loc;
int c;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_char ();
switch (c)
{
case '!':
do
c = gfc_next_char ();
while (c != '\n');
case '\n':
return MATCH_YES;
}
gfc_current_locus = old_loc;
return MATCH_NO;
}
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->num_threads);
gfc_free_expr (c->chunk_size);
for (i = 0; i < OMP_LIST_NUM; i++)
gfc_free_namelist (c->lists[i]);
gfc_free (c);
}
static match
gfc_match_omp_variable_list (const char *str, gfc_namelist **list,
bool allow_common)
{
gfc_namelist *head, *tail, *p;
locus old_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 (;;)
{
m = gfc_match_symbol (&sym, 1);
switch (m)
{
case MATCH_YES:
gfc_set_sym_referenced (sym);
p = gfc_get_namelist ();
if (head == NULL)
head = tail = p;
else
{
tail->next = p;
tail = tail->next;
}
tail->sym = sym;
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_namelist ();
if (head == NULL)
head = tail = p;
else
{
tail->next = p;
tail = tail->next;
}
tail->sym = sym;
}
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_namelist (head);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
#define OMP_CLAUSE_PRIVATE (1 << 0)
#define OMP_CLAUSE_FIRSTPRIVATE (1 << 1)
#define OMP_CLAUSE_LASTPRIVATE (1 << 2)
#define OMP_CLAUSE_COPYPRIVATE (1 << 3)
#define OMP_CLAUSE_SHARED (1 << 4)
#define OMP_CLAUSE_COPYIN (1 << 5)
#define OMP_CLAUSE_REDUCTION (1 << 6)
#define OMP_CLAUSE_IF (1 << 7)
#define OMP_CLAUSE_NUM_THREADS (1 << 8)
#define OMP_CLAUSE_SCHEDULE (1 << 9)
#define OMP_CLAUSE_DEFAULT (1 << 10)
#define OMP_CLAUSE_ORDERED (1 << 11)
static match
gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
{
gfc_omp_clauses *c = gfc_get_omp_clauses ();
locus old_loc;
bool needs_space = true, first = true;
*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 ();
if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
&& gfc_match ("if ( %e )", &c->if_expr) == 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_PRIVATE)
&& gfc_match_omp_variable_list ("private (",
&c->lists[OMP_LIST_PRIVATE], true)
== MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
&& gfc_match_omp_variable_list ("firstprivate (",
&c->lists[OMP_LIST_FIRSTPRIVATE],
true)
== MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_LASTPRIVATE)
&& gfc_match_omp_variable_list ("lastprivate (",
&c->lists[OMP_LIST_LASTPRIVATE],
true)
== MATCH_YES)
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_SHARED)
&& gfc_match_omp_variable_list ("shared (",
&c->lists[OMP_LIST_SHARED], true)
== MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_COPYIN)
&& gfc_match_omp_variable_list ("copyin (",
&c->lists[OMP_LIST_COPYIN], true)
== MATCH_YES)
continue;
old_loc = gfc_current_locus;
if ((mask & OMP_CLAUSE_REDUCTION)
&& gfc_match ("reduction ( ") == MATCH_YES)
{
int reduction = OMP_LIST_NUM;
char buffer[GFC_MAX_SYMBOL_LEN + 1];
if (gfc_match_char ('+') == MATCH_YES)
reduction = OMP_LIST_PLUS;
else if (gfc_match_char ('*') == MATCH_YES)
reduction = OMP_LIST_MULT;
else if (gfc_match_char ('-') == MATCH_YES)
reduction = OMP_LIST_SUB;
else if (gfc_match (".and.") == MATCH_YES)
reduction = OMP_LIST_AND;
else if (gfc_match (".or.") == MATCH_YES)
reduction = OMP_LIST_OR;
else if (gfc_match (".eqv.") == MATCH_YES)
reduction = OMP_LIST_EQV;
else if (gfc_match (".neqv.") == MATCH_YES)
reduction = OMP_LIST_NEQV;
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)
{
gfc_error_now ("%s is not INTRINSIC procedure name "
"at %C", buffer);
sym = NULL;
}
else
n = sym->name;
}
if (strcmp (n, "max") == 0)
reduction = OMP_LIST_MAX;
else if (strcmp (n, "min") == 0)
reduction = OMP_LIST_MIN;
else if (strcmp (n, "iand") == 0)
reduction = OMP_LIST_IAND;
else if (strcmp (n, "ior") == 0)
reduction = OMP_LIST_IOR;
else if (strcmp (n, "ieor") == 0)
reduction = OMP_LIST_IEOR;
if (reduction != OMP_LIST_NUM
&& sym != NULL
&& ! sym->attr.intrinsic
&& ! sym->attr.use_assoc
&& ((sym->attr.flavor == FL_UNKNOWN
&& gfc_add_flavor (&sym->attr, FL_PROCEDURE,
sym->name, NULL) == FAILURE)
|| gfc_add_intrinsic (&sym->attr, NULL) == FAILURE))
{
gfc_free_omp_clauses (c);
return MATCH_ERROR;
}
}
if (reduction != OMP_LIST_NUM
&& gfc_match_omp_variable_list (" :", &c->lists[reduction],
false)
== MATCH_YES)
continue;
else
gfc_current_locus = old_loc;
}
if ((mask & OMP_CLAUSE_DEFAULT)
&& c->default_sharing == OMP_DEFAULT_UNKNOWN)
{
if (gfc_match ("default ( shared )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_SHARED;
else if (gfc_match ("default ( private )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_PRIVATE;
else if (gfc_match ("default ( none )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_NONE;
if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
continue;
}
old_loc = gfc_current_locus;
if ((mask & OMP_CLAUSE_SCHEDULE)
&& c->sched_kind == OMP_SCHED_NONE
&& gfc_match ("schedule ( ") == MATCH_YES)
{
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;
if (c->sched_kind != OMP_SCHED_NONE)
{
match m = MATCH_NO;
if (c->sched_kind != OMP_SCHED_RUNTIME)
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_ORDERED) && !c->ordered
&& gfc_match ("ordered") == MATCH_YES)
{
c->ordered = needs_space = true;
continue;
}
break;
}
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_free_omp_clauses (c);
return MATCH_ERROR;
}
*cp = c;
return MATCH_YES;
}
#define OMP_PARALLEL_CLAUSES \
(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)
#define OMP_DO_CLAUSES \
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
| OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED)
#define OMP_SECTIONS_CLAUSES \
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
match
gfc_match_omp_parallel (void)
{
gfc_omp_clauses *c;
if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_PARALLEL;
new_st.ext.omp_clauses = c;
return MATCH_YES;
}
match
gfc_match_omp_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)
return MATCH_ERROR;
new_st.op = EXEC_OMP_CRITICAL;
new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
return MATCH_YES;
}
match
gfc_match_omp_do (void)
{
gfc_omp_clauses *c;
if (gfc_match_omp_clauses (&c, OMP_DO_CLAUSES) != MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_DO;
new_st.ext.omp_clauses = c;
return MATCH_YES;
}
match
gfc_match_omp_flush (void)
{
gfc_namelist *list = NULL;
gfc_match_omp_variable_list (" (", &list, true);
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_free_namelist (list);
return MATCH_ERROR;
}
new_st.op = EXEC_OMP_FLUSH;
new_st.ext.omp_namelist = list;
return MATCH_YES;
}
match
gfc_match_omp_threadprivate (void)
{
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 (" (");
if (m != MATCH_YES)
return m;
if (!targetm.have_tls)
{
sorry ("threadprivate variables not supported in this target");
goto cleanup;
}
for (;;)
{
m = gfc_match_symbol (&sym, 0);
switch (m)
{
case MATCH_YES:
if (sym->attr.in_common)
gfc_error_now ("Threadprivate variable at %C is an element of"
" a COMMON block");
else if (gfc_add_threadprivate (&sym->attr, sym->name,
&sym->declared_at) == FAILURE)
goto cleanup;
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;
}
st->n.common->threadprivate = 1;
for (sym = st->n.common->head; sym; sym = sym->common_next)
if (gfc_add_threadprivate (&sym->attr, sym->name,
&sym->declared_at) == FAILURE)
goto cleanup;
next_item:
if (gfc_match_char (')') == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
return MATCH_YES;
syntax:
gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
cleanup:
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
match
gfc_match_omp_parallel_do (void)
{
gfc_omp_clauses *c;
if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
!= MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_PARALLEL_DO;
new_st.ext.omp_clauses = c;
return MATCH_YES;
}
match
gfc_match_omp_parallel_sections (void)
{
gfc_omp_clauses *c;
if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
!= MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_PARALLEL_SECTIONS;
new_st.ext.omp_clauses = c;
return MATCH_YES;
}
match
gfc_match_omp_parallel_workshare (void)
{
gfc_omp_clauses *c;
if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_PARALLEL_WORKSHARE;
new_st.ext.omp_clauses = c;
return MATCH_YES;
}
match
gfc_match_omp_sections (void)
{
gfc_omp_clauses *c;
if (gfc_match_omp_clauses (&c, OMP_SECTIONS_CLAUSES) != MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_SECTIONS;
new_st.ext.omp_clauses = c;
return MATCH_YES;
}
match
gfc_match_omp_single (void)
{
gfc_omp_clauses *c;
if (gfc_match_omp_clauses (&c, OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE)
!= MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_SINGLE;
new_st.ext.omp_clauses = c;
return MATCH_YES;
}
match
gfc_match_omp_workshare (void)
{
if (gfc_match_omp_eos () != MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_WORKSHARE;
new_st.ext.omp_clauses = gfc_get_omp_clauses ();
return MATCH_YES;
}
match
gfc_match_omp_master (void)
{
if (gfc_match_omp_eos () != MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_MASTER;
new_st.ext.omp_clauses = NULL;
return MATCH_YES;
}
match
gfc_match_omp_ordered (void)
{
if (gfc_match_omp_eos () != MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_ORDERED;
new_st.ext.omp_clauses = NULL;
return MATCH_YES;
}
match
gfc_match_omp_atomic (void)
{
if (gfc_match_omp_eos () != MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_ATOMIC;
new_st.ext.omp_clauses = NULL;
return MATCH_YES;
}
match
gfc_match_omp_barrier (void)
{
if (gfc_match_omp_eos () != MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_BARRIER;
new_st.ext.omp_clauses = NULL;
return MATCH_YES;
}
match
gfc_match_omp_end_nowait (void)
{
bool nowait = false;
if (gfc_match ("% nowait") == MATCH_YES)
nowait = true;
if (gfc_match_omp_eos () != MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_END_NOWAIT;
new_st.ext.omp_bool = nowait;
return MATCH_YES;
}
match
gfc_match_omp_end_single (void)
{
gfc_omp_clauses *c;
if (gfc_match ("% nowait") == MATCH_YES)
{
new_st.op = EXEC_OMP_END_NOWAIT;
new_st.ext.omp_bool = true;
return MATCH_YES;
}
if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_END_SINGLE;
new_st.ext.omp_clauses = c;
return MATCH_YES;
}
static void
resolve_omp_clauses (gfc_code *code)
{
gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
gfc_namelist *n;
int list;
static const char *clause_names[]
= { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
"COPYIN", "REDUCTION" };
if (omp_clauses == NULL)
return;
if (omp_clauses->if_expr)
{
gfc_expr *expr = omp_clauses->if_expr;
if (gfc_resolve_expr (expr) == FAILURE
|| expr->ts.type != BT_LOGICAL || expr->rank != 0)
gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
&expr->where);
}
if (omp_clauses->num_threads)
{
gfc_expr *expr = omp_clauses->num_threads;
if (gfc_resolve_expr (expr) == FAILURE
|| expr->ts.type != BT_INTEGER || expr->rank != 0)
gfc_error ("NUM_THREADS clause at %L requires a scalar"
" INTEGER expression", &expr->where);
}
if (omp_clauses->chunk_size)
{
gfc_expr *expr = omp_clauses->chunk_size;
if (gfc_resolve_expr (expr) == FAILURE
|| expr->ts.type != BT_INTEGER || expr->rank != 0)
gfc_error ("SCHEDULE clause's chunk_size at %L requires"
" a scalar INTEGER expression", &expr->where);
}
for (list = 0; list < OMP_LIST_NUM; list++)
for (n = omp_clauses->lists[list]; n; n = n->next)
n->sym->mark = 0;
for (list = 0; list < OMP_LIST_NUM; list++)
if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE)
for (n = omp_clauses->lists[list]; n; n = n->next)
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
n->sym->name, &code->loc);
else
n->sym->mark = 1;
gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
for (n = omp_clauses->lists[list]; n; n = n->next)
if (n->sym->mark)
{
gfc_error ("Symbol '%s' present on multiple clauses at %L",
n->sym->name, &code->loc);
n->sym->mark = 0;
}
for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
n->sym->name, &code->loc);
else
n->sym->mark = 1;
for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
n->sym->mark = 0;
for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
n->sym->name, &code->loc);
else
n->sym->mark = 1;
for (list = 0; list < OMP_LIST_NUM; list++)
if ((n = omp_clauses->lists[list]) != NULL)
{
const char *name;
if (list < OMP_LIST_REDUCTION_FIRST)
name = clause_names[list];
else if (list <= OMP_LIST_REDUCTION_LAST)
name = clause_names[OMP_LIST_REDUCTION_FIRST];
else
gcc_unreachable ();
switch (list)
{
case OMP_LIST_COPYIN:
for (; n != NULL; n = n->next)
{
if (!n->sym->attr.threadprivate)
gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
" at %L", n->sym->name, &code->loc);
if (n->sym->attr.allocatable)
gfc_error ("COPYIN clause object '%s' is ALLOCATABLE at %L",
n->sym->name, &code->loc);
}
break;
case OMP_LIST_COPYPRIVATE:
for (; n != NULL; n = n->next)
{
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in COPYPRIVATE clause"
" at %L", n->sym->name, &code->loc);
if (n->sym->attr.allocatable)
gfc_error ("COPYPRIVATE clause object '%s' is ALLOCATABLE"
" at %L", n->sym->name, &code->loc);
}
break;
case OMP_LIST_SHARED:
for (; n != NULL; n = n->next)
{
if (n->sym->attr.threadprivate)
gfc_error ("THREADPRIVATE object '%s' in SHARED clause at"
" %L", n->sym->name, &code->loc);
if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in SHARED clause at %L",
n->sym->name, &code->loc);
}
break;
default:
for (; n != NULL; n = n->next)
{
if (n->sym->attr.threadprivate)
gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
n->sym->name, name, &code->loc);
if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in %s clause at %L",
n->sym->name, name, &code->loc);
if (list != OMP_LIST_PRIVATE)
{
if (n->sym->attr.pointer)
gfc_error ("POINTER object '%s' in %s clause at %L",
n->sym->name, name, &code->loc);
if (n->sym->attr.allocatable)
gfc_error ("%s clause object '%s' is ALLOCATABLE at %L",
name, n->sym->name, &code->loc);
if (n->sym->attr.cray_pointer)
gfc_error ("Cray pointer '%s' in %s clause at %L",
n->sym->name, name, &code->loc);
}
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in %s clause at %L",
n->sym->name, name, &code->loc);
if (n->sym->attr.in_namelist
&& (list < OMP_LIST_REDUCTION_FIRST
|| list > OMP_LIST_REDUCTION_LAST))
gfc_error ("Variable '%s' in %s clause is used in"
" NAMELIST statement at %L",
n->sym->name, name, &code->loc);
switch (list)
{
case OMP_LIST_PLUS:
case OMP_LIST_MULT:
case OMP_LIST_SUB:
if (!gfc_numeric_ts (&n->sym->ts))
gfc_error ("%c REDUCTION variable '%s' is %s at %L",
list == OMP_LIST_PLUS ? '+'
: list == OMP_LIST_MULT ? '*' : '-',
n->sym->name, gfc_typename (&n->sym->ts),
&code->loc);
break;
case OMP_LIST_AND:
case OMP_LIST_OR:
case OMP_LIST_EQV:
case OMP_LIST_NEQV:
if (n->sym->ts.type != BT_LOGICAL)
gfc_error ("%s REDUCTION variable '%s' must be LOGICAL"
" at %L",
list == OMP_LIST_AND ? ".AND."
: list == OMP_LIST_OR ? ".OR."
: list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
n->sym->name, &code->loc);
break;
case OMP_LIST_MAX:
case OMP_LIST_MIN:
if (n->sym->ts.type != BT_INTEGER
&& n->sym->ts.type != BT_REAL)
gfc_error ("%s REDUCTION variable '%s' must be"
" INTEGER or REAL at %L",
list == OMP_LIST_MAX ? "MAX" : "MIN",
n->sym->name, &code->loc);
break;
case OMP_LIST_IAND:
case OMP_LIST_IOR:
case OMP_LIST_IEOR:
if (n->sym->ts.type != BT_INTEGER)
gfc_error ("%s REDUCTION variable '%s' must be INTEGER"
" at %L",
list == OMP_LIST_IAND ? "IAND"
: list == OMP_LIST_MULT ? "IOR" : "IEOR",
n->sym->name, &code->loc);
break;
case OMP_LIST_PRIVATE:
gcc_assert (code->op != EXEC_NOP);
default:
break;
}
}
break;
}
}
}
static bool
expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
{
gfc_actual_arglist *arg;
if (e == NULL || e == se)
return false;
switch (e->expr_type)
{
case EXPR_CONSTANT:
case EXPR_NULL:
case EXPR_VARIABLE:
case EXPR_STRUCTURE:
case EXPR_ARRAY:
if (e->symtree != NULL
&& e->symtree->n.sym == s)
return true;
return false;
case EXPR_SUBSTRING:
if (e->ref != NULL
&& (expr_references_sym (e->ref->u.ss.start, s, se)
|| expr_references_sym (e->ref->u.ss.end, s, se)))
return true;
return false;
case EXPR_OP:
if (expr_references_sym (e->value.op.op2, s, se))
return true;
return expr_references_sym (e->value.op.op1, s, se);
case EXPR_FUNCTION:
for (arg = e->value.function.actual; arg; arg = arg->next)
if (expr_references_sym (arg->expr, s, se))
return true;
return false;
default:
gcc_unreachable ();
}
}
static gfc_expr *
is_conversion (gfc_expr *expr, bool widening)
{
gfc_typespec *ts1, *ts2;
if (expr->expr_type != EXPR_FUNCTION
|| expr->value.function.isym == NULL
|| expr->value.function.esym != NULL
|| expr->value.function.isym->generic_id != GFC_ISYM_CONVERSION)
return NULL;
if (widening)
{
ts1 = &expr->ts;
ts2 = &expr->value.function.actual->expr->ts;
}
else
{
ts1 = &expr->value.function.actual->expr->ts;
ts2 = &expr->ts;
}
if (ts1->type > ts2->type
|| (ts1->type == ts2->type && ts1->kind > ts2->kind))
return expr->value.function.actual->expr;
return NULL;
}
static void
resolve_omp_atomic (gfc_code *code)
{
gfc_symbol *var;
gfc_expr *expr2;
code = code->block->next;
gcc_assert (code->op == EXEC_ASSIGN);
gcc_assert (code->next == NULL);
if (code->expr->expr_type != EXPR_VARIABLE
|| code->expr->symtree == NULL
|| code->expr->rank != 0
|| (code->expr->ts.type != BT_INTEGER
&& code->expr->ts.type != BT_REAL
&& code->expr->ts.type != BT_COMPLEX
&& code->expr->ts.type != BT_LOGICAL))
{
gfc_error ("!$OMP ATOMIC statement must set a scalar variable of"
" intrinsic type at %L", &code->loc);
return;
}
var = code->expr->symtree->n.sym;
expr2 = is_conversion (code->expr2, false);
if (expr2 == NULL)
expr2 = code->expr2;
if (expr2->expr_type == EXPR_OP)
{
gfc_expr *v = NULL, *e, *c;
gfc_intrinsic_op op = expr2->value.op.operator;
gfc_intrinsic_op alt_op = INTRINSIC_NONE;
switch (op)
{
case INTRINSIC_PLUS:
alt_op = INTRINSIC_MINUS;
break;
case INTRINSIC_TIMES:
alt_op = INTRINSIC_DIVIDE;
break;
case INTRINSIC_MINUS:
alt_op = INTRINSIC_PLUS;
break;
case INTRINSIC_DIVIDE:
alt_op = INTRINSIC_TIMES;
break;
case INTRINSIC_AND:
case INTRINSIC_OR:
break;
case INTRINSIC_EQV:
alt_op = INTRINSIC_NEQV;
break;
case INTRINSIC_NEQV:
alt_op = INTRINSIC_EQV;
break;
default:
gfc_error ("!$OMP ATOMIC assignment operator must be"
" +, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
&expr2->where);
return;
}
e = expr2->value.op.op2;
if (e->expr_type == EXPR_VARIABLE
&& e->symtree != NULL
&& e->symtree->n.sym == var)
v = e;
else if ((c = is_conversion (e, true)) != NULL
&& c->expr_type == EXPR_VARIABLE
&& c->symtree != NULL
&& c->symtree->n.sym == var)
v = c;
else
{
gfc_expr **p = NULL, **q;
for (q = &expr2->value.op.op1; (e = *q) != NULL; )
if (e->expr_type == EXPR_VARIABLE
&& e->symtree != NULL
&& e->symtree->n.sym == var)
{
v = e;
break;
}
else if ((c = is_conversion (e, true)) != NULL)
q = &e->value.function.actual->expr;
else if (e->expr_type != EXPR_OP
|| (e->value.op.operator != op
&& e->value.op.operator != alt_op)
|| e->rank != 0)
break;
else
{
p = q;
q = &e->value.op.op1;
}
if (v == NULL)
{
gfc_error ("!$OMP ATOMIC assignment must be var = var op expr"
" or var = expr op var at %L", &expr2->where);
return;
}
if (p != NULL)
{
e = *p;
switch (e->value.op.operator)
{
case INTRINSIC_MINUS:
case INTRINSIC_DIVIDE:
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
gfc_error ("!$OMP ATOMIC var = var op expr not"
" mathematically equivalent to var = var op"
" (expr) at %L", &expr2->where);
break;
default:
break;
}
*p = e->value.op.op2;
e->value.op.op2 = expr2;
e->ts = expr2->ts;
if (code->expr2 == expr2)
code->expr2 = expr2 = e;
else
code->expr2->value.function.actual->expr = expr2 = e;
if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
{
for (p = &expr2->value.op.op1; *p != v;
p = &(*p)->value.function.actual->expr)
;
*p = NULL;
gfc_free_expr (expr2->value.op.op1);
expr2->value.op.op1 = v;
gfc_convert_type (v, &expr2->ts, 2);
}
}
}
if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
{
gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr"
" must be scalar and cannot reference var at %L",
&expr2->where);
return;
}
}
else if (expr2->expr_type == EXPR_FUNCTION
&& expr2->value.function.isym != NULL
&& expr2->value.function.esym == NULL
&& expr2->value.function.actual != NULL
&& expr2->value.function.actual->next != NULL)
{
gfc_actual_arglist *arg, *var_arg;
switch (expr2->value.function.isym->generic_id)
{
case GFC_ISYM_MIN:
case GFC_ISYM_MAX:
break;
case GFC_ISYM_IAND:
case GFC_ISYM_IOR:
case GFC_ISYM_IEOR:
if (expr2->value.function.actual->next->next != NULL)
{
gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR"
"or IEOR must have two arguments at %L",
&expr2->where);
return;
}
break;
default:
gfc_error ("!$OMP ATOMIC assignment intrinsic must be"
" MIN, MAX, IAND, IOR or IEOR at %L",
&expr2->where);
return;
}
var_arg = NULL;
for (arg = expr2->value.function.actual; arg; arg = arg->next)
{
if ((arg == expr2->value.function.actual
|| (var_arg == NULL && arg->next == NULL))
&& arg->expr->expr_type == EXPR_VARIABLE
&& arg->expr->symtree != NULL
&& arg->expr->symtree->n.sym == var)
var_arg = arg;
else if (expr_references_sym (arg->expr, var, NULL))
gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not"
" reference '%s' at %L", var->name, &arg->expr->where);
if (arg->expr->rank != 0)
gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar"
" at %L", &arg->expr->where);
}
if (var_arg == NULL)
{
gfc_error ("First or last !$OMP ATOMIC intrinsic argument must"
" be '%s' at %L", var->name, &expr2->where);
return;
}
if (var_arg != expr2->value.function.actual)
{
gcc_assert (var_arg->next == NULL);
for (arg = expr2->value.function.actual;
arg->next != var_arg; arg = arg->next)
;
var_arg->next = expr2->value.function.actual;
expr2->value.function.actual = var_arg;
arg->next = NULL;
}
}
else
gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic"
" on right hand side at %L", &expr2->where);
}
struct omp_context
{
gfc_code *code;
struct pointer_set_t *sharing_clauses;
struct pointer_set_t *private_iterators;
struct omp_context *previous;
} *omp_current_ctx;
gfc_code *omp_current_do_code;
void
gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
{
if (code->block->next && code->block->next->op == EXEC_DO)
omp_current_do_code = code->block->next;
gfc_resolve_blocks (code->block, ns);
}
void
gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
{
struct omp_context ctx;
gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
gfc_namelist *n;
int list;
ctx.code = code;
ctx.sharing_clauses = pointer_set_create ();
ctx.private_iterators = pointer_set_create ();
ctx.previous = omp_current_ctx;
omp_current_ctx = &ctx;
for (list = 0; list < OMP_LIST_NUM; list++)
for (n = omp_clauses->lists[list]; n; n = n->next)
pointer_set_insert (ctx.sharing_clauses, n->sym);
if (code->op == EXEC_OMP_PARALLEL_DO)
gfc_resolve_omp_do_blocks (code, ns);
else
gfc_resolve_blocks (code->block, ns);
omp_current_ctx = ctx.previous;
pointer_set_destroy (ctx.sharing_clauses);
pointer_set_destroy (ctx.private_iterators);
}
void
gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
{
struct omp_context *ctx;
if (sym->attr.threadprivate)
return;
if (code == omp_current_do_code)
return;
for (ctx = omp_current_ctx; ctx; ctx = ctx->previous)
{
if (pointer_set_contains (ctx->sharing_clauses, sym))
continue;
if (! pointer_set_insert (ctx->private_iterators, sym))
{
gfc_omp_clauses *omp_clauses = ctx->code->ext.omp_clauses;
gfc_namelist *p;
p = gfc_get_namelist ();
p->sym = sym;
p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
omp_clauses->lists[OMP_LIST_PRIVATE] = p;
}
}
}
static void
resolve_omp_do (gfc_code *code)
{
gfc_code *do_code;
int list;
gfc_namelist *n;
gfc_symbol *dovar;
if (code->ext.omp_clauses)
resolve_omp_clauses (code);
do_code = code->block->next;
if (do_code->op == EXEC_DO_WHILE)
gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control at %L",
&do_code->loc);
else
{
gcc_assert (do_code->op == EXEC_DO);
if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
&do_code->loc);
dovar = do_code->ext.iterator->var->symtree->n.sym;
if (dovar->attr.threadprivate)
gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE at %L",
&do_code->loc);
if (code->ext.omp_clauses)
for (list = 0; list < OMP_LIST_NUM; list++)
if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
if (dovar == n->sym)
{
gfc_error ("!$OMP DO iteration variable present on clause"
" other than PRIVATE or LASTPRIVATE at %L",
&do_code->loc);
break;
}
}
}
void
gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
{
switch (code->op)
{
case EXEC_OMP_DO:
case EXEC_OMP_PARALLEL_DO:
resolve_omp_do (code);
break;
case EXEC_OMP_WORKSHARE:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
if (code->ext.omp_clauses)
resolve_omp_clauses (code);
break;
case EXEC_OMP_ATOMIC:
resolve_omp_atomic (code);
break;
default:
break;
}
}