static match
match_primary (gfc_expr **result)
{
match m;
gfc_expr *e;
m = gfc_match_literal_constant (result, 0);
if (m != MATCH_NO)
return m;
m = gfc_match_array_constructor (result);
if (m != MATCH_NO)
return m;
m = gfc_match_rvalue (result);
if (m != MATCH_NO)
return m;
/* Match an expression in parentheses. */
if (gfc_match_char ('(') != MATCH_YES)
return MATCH_NO;
m = gfc_match_expr (&e);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
return m;
m = gfc_match_char (')');
if (m == MATCH_NO)
gfc_error ("Expected a right parenthesis in expression at %C");
/* Now we have the expression inside the parentheses, build the
expression pointing to it. By 7.1.7.2, any expression in
parentheses shall be treated as a data entity. */
*result = gfc_get_parentheses (e);
if (m != MATCH_YES)
{
gfc_free_expr (*result);
return MATCH_ERROR;
}
return MATCH_YES;
syntax:
gfc_error (expression_syntax);
return MATCH_ERROR;
}
match
gfc_match_array_ref (gfc_array_ref * ar, gfc_array_spec * as, int init)
{
match m;
memset (ar, '\0', sizeof (ar));
ar->where = gfc_current_locus;
ar->as = as;
if (gfc_match_char ('(') != MATCH_YES)
{
ar->type = AR_FULL;
ar->dimen = 0;
return MATCH_YES;
}
ar->type = AR_UNKNOWN;
for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
{
m = match_subscript (ar, init);
if (m == MATCH_ERROR)
goto error;
if (gfc_match_char (')') == MATCH_YES)
goto matched;
if (gfc_match_char (',') != MATCH_YES)
{
gfc_error ("Invalid form of array reference at %C");
goto error;
}
}
gfc_error ("Array reference at %C cannot have more than %d dimensions",
GFC_MAX_DIMENSIONS);
error:
return MATCH_ERROR;
matched:
ar->dimen++;
return MATCH_YES;
}
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;
}
static match
match_primary (gfc_expr ** result)
{
match m;
m = gfc_match_literal_constant (result, 0);
if (m != MATCH_NO)
return m;
m = gfc_match_array_constructor (result);
if (m != MATCH_NO)
return m;
m = gfc_match_rvalue (result);
if (m != MATCH_NO)
return m;
/* Match an expression in parenthesis. */
if (gfc_match_char ('(') != MATCH_YES)
return MATCH_NO;
m = gfc_match_expr (result);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
return m;
m = gfc_match_char (')');
if (m == MATCH_NO)
gfc_error ("Expected a right parenthesis in expression at %C");
if (m != MATCH_YES)
{
gfc_free_expr (*result);
return MATCH_ERROR;
}
return MATCH_YES;
syntax:
gfc_error (expression_syntax);
return MATCH_ERROR;
}
static match
match_subscript (gfc_array_ref * ar, int init)
{
match m;
int i;
i = ar->dimen;
ar->c_where[i] = gfc_current_locus;
ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
/* We can't be sure of the difference between DIMEN_ELEMENT and
DIMEN_VECTOR until we know the type of the element itself at
resolution time. */
ar->dimen_type[i] = DIMEN_UNKNOWN;
if (gfc_match_char (':') == MATCH_YES)
goto end_element;
/* Get start element. */
if (init)
m = gfc_match_init_expr (&ar->start[i]);
else
m = gfc_match_expr (&ar->start[i]);
if (m == MATCH_NO)
gfc_error ("Expected array subscript at %C");
if (m != MATCH_YES)
return MATCH_ERROR;
if (gfc_match_char (':') == MATCH_NO)
return MATCH_YES;
/* Get an optional end element. Because we've seen the colon, we
definitely have a range along this dimension. */
end_element:
ar->dimen_type[i] = DIMEN_RANGE;
if (init)
m = gfc_match_init_expr (&ar->end[i]);
else
m = gfc_match_expr (&ar->end[i]);
if (m == MATCH_ERROR)
return MATCH_ERROR;
/* See if we have an optional stride. */
if (gfc_match_char (':') == MATCH_YES)
{
m = init ? gfc_match_init_expr (&ar->stride[i])
: gfc_match_expr (&ar->stride[i]);
if (m == MATCH_NO)
gfc_error ("Expected array subscript stride at %C");
if (m != MATCH_YES)
return MATCH_ERROR;
}
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;
}