int parser(char *format, t_env *e)
{
int i;
i = 1;
flags(format, &i, e);
minimum_field_width(format, &i, e);
parser_precision(format, &i, e);
lenght_modifier(format, &i, e);
if (format[i] != '\0' && is_conversion(format[i]))
set_conversion(format[i++], e);
return (i);
}
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->expr1->expr_type != EXPR_VARIABLE
|| code->expr1->symtree == NULL
|| code->expr1->rank != 0
|| (code->expr1->ts.type != BT_INTEGER
&& code->expr1->ts.type != BT_REAL
&& code->expr1->ts.type != BT_COMPLEX
&& code->expr1->ts.type != BT_LOGICAL))
{
gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
"intrinsic type at %L", &code->loc);
return;
}
var = code->expr1->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.op;
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;
}
/* Check for var = var op expr resp. var = expr op var where
expr doesn't reference var and var op expr is mathematically
equivalent to var op (expr) resp. expr op var equivalent to
(expr) op var. We rely here on the fact that the matcher
for x op1 y op2 z where op1 and op2 have equal precedence
returns (x op1 y) op2 z. */
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.op != op
&& e->value.op.op != 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.op)
{
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;
}
/* Canonicalize into var = var op (expr). */
*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->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)
{
/* Canonicalize, so that var comes first. */
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);
}
