static match
match_and_operand (gfc_expr **result)
{
gfc_expr *e, *r;
locus where;
match m;
int i;
i = next_operator (INTRINSIC_NOT);
where = gfc_current_locus;
m = match_level_4 (&e);
if (m != MATCH_YES)
return m;
r = e;
if (i)
{
r = gfc_not (e);
if (r == NULL)
{
gfc_free_expr (e);
return MATCH_ERROR;
}
}
r->where = where;
*result = r;
return MATCH_YES;
}
static int complex(char *s, char *e)
{
char *p = s,
*q;
#ifdef INDIRECTION_PMONOLITH
if (*s == '*') return 0;
#else
if (*s == '*') return complex(s + 1, e);
#endif
while (p = l2r_find('(', p, e))
{
q = fendbe(p);
if (complex(p, q))
{
return 1;
}
p = q;
}
if (next_operator(s, e, "*+\0*-\0", EXCLUDE_OPERATORS)) return 1;
return 0;
}
static match
match_mult_operand (gfc_expr **result)
{
/* Workaround -Wmaybe-uninitialized false positive during
profiledbootstrap by initializing them. */
gfc_expr *e = NULL, *exp, *r;
locus where;
match m;
m = match_level_1 (&e);
if (m != MATCH_YES)
return m;
if (!next_operator (INTRINSIC_POWER))
{
*result = e;
return MATCH_YES;
}
where = gfc_current_locus;
m = match_ext_mult_operand (&exp);
if (m == MATCH_NO)
gfc_error ("Expected exponent in expression at %C");
if (m != MATCH_YES)
{
gfc_free_expr (e);
return MATCH_ERROR;
}
r = gfc_power (e, exp);
if (r == NULL)
{
gfc_free_expr (e);
gfc_free_expr (exp);
return MATCH_ERROR;
}
r->where = where;
*result = r;
return MATCH_YES;
}
static match
match_level_3 (gfc_expr **result)
{
gfc_expr *all, *e, *total = NULL;
locus where;
match m;
m = match_level_2 (&all);
if (m != MATCH_YES)
return m;
for (;;)
{
if (!next_operator (INTRINSIC_CONCAT))
break;
where = gfc_current_locus;
m = match_level_2 (&e);
if (m == MATCH_NO)
gfc_error (expression_syntax);
if (m != MATCH_YES)
{
gfc_free_expr (all);
return MATCH_ERROR;
}
total = gfc_concat (all, e);
if (total == NULL)
{
gfc_free_expr (all);
gfc_free_expr (e);
return MATCH_ERROR;
}
all = total;
all->where = where;
}
*result = all;
return MATCH_YES;
}
static match
match_mult_operand (gfc_expr **result)
{
gfc_expr *e, *exp, *r;
locus where;
match m;
m = match_level_1 (&e);
if (m != MATCH_YES)
return m;
if (!next_operator (INTRINSIC_POWER))
{
*result = e;
return MATCH_YES;
}
where = gfc_current_locus;
m = match_ext_mult_operand (&exp);
if (m == MATCH_NO)
gfc_error ("Expected exponent in expression at %C");
if (m != MATCH_YES)
{
gfc_free_expr (e);
return MATCH_ERROR;
}
r = gfc_power (e, exp);
if (r == NULL)
{
gfc_free_expr (e);
gfc_free_expr (exp);
return MATCH_ERROR;
}
r->where = where;
*result = r;
return MATCH_YES;
}
static t_nbr *read_expr_infix_rec(char *expr, char *end_expr,
t_bistro *bistro)
{
char *tmp;
char *max_op;
max_op = NULL;
tmp = expr;
while ((tmp = next_operator(tmp, end_expr, bistro)))
if (op_val(tmp, bistro) >= op_val(max_op, bistro))
max_op = tmp;
if (!max_op)
{
if (IS_NEG(*expr, bistro))
return negative(read_expr_infix_rec(expr + 1, end_expr, bistro));
if (IS_GRP_BEG(*expr, bistro))
return read_expr_infix_rec(expr + 1, end_expr - 1, bistro);
return read_nbr_infix(expr, end_expr, bistro);
}
return make_calcul_free(read_expr_infix_rec(expr, max_op, bistro),
read_expr_infix_rec(max_op + 1, end_expr, bistro),
*max_op, bistro);
}
static void fp_xpress(char *s, char *e, char *tag)
{
char *p,
*q = s;
int unary = *s;
int x;
if ((unary == '+') || (unary == '-') || (unary == '*')) q++;
if ((p = contains(q, e, "+\0-\0"))
|| (p = contains(q, e, "/\0*\0")))
{
q = p + 1;
if (complex(q, e))
{
fp_xpress(q, e, tag);
switch (*p)
{
case '-':
fpxpress_asmq(" $x_reserve ");
fp_xpress(s, p, tag);
fpxpress_asmq(" $x_retrieve_subtract ");
break;
case '+':
if (complex_beyond(s, p, "+\0-\0*+\0*-\0"))
{
fpxpress_asmq(" $x_reserve ");
fp_xpress(s, p, tag);
fpxpress_asmq(" $x_retrieve_add ");
break;
}
x = PLUS;
while (q = next_operator(s, p, "+\0-\0", 0))
{
trailing_fp_operation(x, s, q, tag);
x = oper_ator(q, p - q);
s = q + ufield[x];
}
trailing_fp_operation(x, s, p, tag);
break;
case '*':
if (complex_beyond(s, p, "*\0/\0*+\0*-\0"))
{
fpxpress_asmq(" $x_reserve ");
fp_xpress(s, p, tag);
fpxpress_asmq(" $x_retrieve_multiply ");
break;
}
x = MULTIPLY;
while (q = next_operator(s, p, "*\0/\0", 0))
{
trailing_fp_operation(x, s, q, tag);
x = oper_ator(q, p - q);
s = q + ufield[x];
}
trailing_fp_operation(x, s, p, tag);
break;
case '/':
fpxpress_asmq(" $x_reserve ");
fp_xpress(s, p, tag);
fpxpress_asmq(" $x_retrieve_divide ");
}
}
else
{
fp_xpress(s, p, tag);
if (*q == '(') q++;
switch(*p)
{
case '-':
fpxpress_assemble(" $x_subtract ", q, e, tag);
break;
case '+':
fpxpress_assemble(" $x_add ", q, e, tag);
break;
case '*':
fpxpress_assemble(" $x_multiply ", q, e, tag);
break;
case '/':
fpxpress_assemble(" $x_divide ", q, e, tag);
}
}
return;
}
if (*s == '(')
{
fp_xpress(s + 1, e, tag);
return;
}
unary = *s;
if ((unary == '+') || (unary == '-'))
{
if (*(s + 1) == '(')
{
fp_xpress(s + 2, e, tag);
if (unary == '-') fpxpress_asmq(" $x_reverse");
return;
}
if (number(s + 1, e) == 0)
{
if (unary == '+') fpxpress_assemble(" $x_load ", s + 1, e, tag);
else fpxpress_assemble(" $x_load_negative ", s + 1, e, tag);
return;
}
}
fpxpress_assemble(" $x_load ", s, e, tag);
}
static match
match_add_operand (gfc_expr **result)
{
gfc_expr *all, *e, *total;
locus where, old_loc;
match m;
gfc_intrinsic_op i;
m = match_mult_operand (&all);
if (m != MATCH_YES)
return m;
for (;;)
{
/* Build up a string of products or quotients. */
old_loc = gfc_current_locus;
if (next_operator (INTRINSIC_TIMES))
i = INTRINSIC_TIMES;
else
{
if (next_operator (INTRINSIC_DIVIDE))
i = INTRINSIC_DIVIDE;
else
break;
}
where = gfc_current_locus;
m = match_ext_mult_operand (&e);
if (m == MATCH_NO)
{
gfc_current_locus = old_loc;
break;
}
if (m == MATCH_ERROR)
{
gfc_free_expr (all);
return MATCH_ERROR;
}
if (i == INTRINSIC_TIMES)
total = gfc_multiply (all, e);
else
total = gfc_divide (all, e);
if (total == NULL)
{
gfc_free_expr (all);
gfc_free_expr (e);
return MATCH_ERROR;
}
all = total;
all->where = where;
}
*result = all;
return MATCH_YES;
}
