match
gfc_match_generic_spec (interface_type * type,
char *name,
gfc_intrinsic_op *operator)
{
char buffer[GFC_MAX_SYMBOL_LEN + 1];
match m;
gfc_intrinsic_op i;
if (gfc_match (" assignment ( = )") == MATCH_YES)
{
*type = INTERFACE_INTRINSIC_OP;
*operator = INTRINSIC_ASSIGN;
return MATCH_YES;
}
if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
{ /* Operator i/f */
*type = INTERFACE_INTRINSIC_OP;
*operator = fold_unary (i);
return MATCH_YES;
}
if (gfc_match (" operator ( ") == MATCH_YES)
{
m = gfc_match_defined_op_name (buffer, 1);
if (m == MATCH_NO)
goto syntax;
if (m != MATCH_YES)
return MATCH_ERROR;
m = gfc_match_char (')');
if (m == MATCH_NO)
goto syntax;
if (m != MATCH_YES)
return MATCH_ERROR;
strcpy (name, buffer);
*type = INTERFACE_USER_OP;
return MATCH_YES;
}
if (gfc_match_name (buffer) == MATCH_YES)
{
strcpy (name, buffer);
*type = INTERFACE_GENERIC;
return MATCH_YES;
}
*type = INTERFACE_NAMELESS;
return MATCH_YES;
syntax:
gfc_error ("Syntax error in generic specification at %C");
return MATCH_ERROR;
}
match
gfc_match_omp_atomic (void)
{
gfc_omp_atomic_op op = GFC_OMP_ATOMIC_UPDATE;
if (gfc_match ("% update") == MATCH_YES)
op = GFC_OMP_ATOMIC_UPDATE;
else if (gfc_match ("% read") == MATCH_YES)
op = GFC_OMP_ATOMIC_READ;
else if (gfc_match ("% write") == MATCH_YES)
op = GFC_OMP_ATOMIC_WRITE;
else if (gfc_match ("% capture") == MATCH_YES)
op = GFC_OMP_ATOMIC_CAPTURE;
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
return MATCH_ERROR;
}
new_st.op = EXEC_OMP_ATOMIC;
new_st.ext.omp_atomic = op;
return MATCH_YES;
}
match
gfc_match_defined_op_name (char *result, int error_flag)
{
static const char * const badops[] = {
"and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt",
NULL
};
char name[GFC_MAX_SYMBOL_LEN + 1];
locus old_loc;
match m;
int i;
old_loc = gfc_current_locus;
m = gfc_match (" . %n .", name);
if (m != MATCH_YES)
return m;
/* .true. and .false. have interpretations as constants. Trying to
use these as operators will fail at a later time. */
if (strcmp (name, "true") == 0 || strcmp (name, "false") == 0)
{
if (error_flag)
goto error;
gfc_current_locus = old_loc;
return MATCH_NO;
}
for (i = 0; badops[i]; i++)
if (strcmp (badops[i], name) == 0)
goto error;
for (i = 0; name[i]; i++)
if (!ISALPHA (name[i]))
{
gfc_error ("Bad character %qc in OPERATOR name at %C", name[i]);
return MATCH_ERROR;
}
strcpy (result, name);
return MATCH_YES;
error:
gfc_error ("The name %qs cannot be used as a defined operator at %C",
name);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
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)
{
gfc_error ("Unexpected junk after NOWAIT clause at %C");
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;
}
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)
{
gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
return MATCH_ERROR;
}
new_st.op = EXEC_OMP_CRITICAL;
new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
return MATCH_YES;
}
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;
}
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;
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;
}
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;
else if (gfc_match ("default ( firstprivate )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
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;
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_ORDERED) && !c->ordered
&& gfc_match ("ordered") == MATCH_YES)
{
c->ordered = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_UNTIED) && !c->untied
&& gfc_match ("untied") == MATCH_YES)
{
c->untied = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse)
{
gfc_expr *cexpr = NULL;
match m = gfc_match ("collapse ( %e )", &cexpr);
if (m == MATCH_YES)
{
int collapse;
const char *p = gfc_extract_int (cexpr, &collapse);
if (p)
{
gfc_error_now (p);
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;
}
}
break;
}
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_free_omp_clauses (c);
return MATCH_ERROR;
}
*cp = c;
return MATCH_YES;
}