MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
24109c9f28
8sa1-gcc/gcc/fortran/matchexp.c
Tobias Schlüter 63645982e7 gfortran.h (gfc_current_locus, [...]): Remove. 
* gfortran.h (gfc_current_locus, gfc_set_locus): Remove.
(gfc_current_locus): Declare new global variable.
* scanner.c (gfc_current_locus, gfc_set_locus): Remove.
(gfc_current_locus1): Rename ...
(gfc_current_locus): ... to this.
(gfc_at_eof, gfc_at_bol, gfc_at_eol, gfc_advance_line, next_char,
skip_fixed_comments, skip_free_comments, gfc_next_char_literal,
gfc_peek_char, gfc_gobble_whitespace, gfc_new_file): Use
gfc_current_locus instead of gfc_current_locus1, gfc_set_locus()
and gfc_current_locus(), respectively.
* array.c (match_subscript, gfc_match_array_ref, match_array_list,
match_array_cons_element, gfc_match_array_constructor):
Read/modify gfc_current_locus instead of calling gfc_set_locus()
and gfc_current_locus().
* decl.c (gfc_match_null, variable_decl, gfc_match_kind_spec,
match_attr_spec, gfc_match_function_decl, gfc_match_end,
attr_decl1, gfc_match_save): Likewise.
* error.c (error_print, gfc_internal_error): Likewise.
* expr.c (gfc_int_expr, gfc_default_logical_kind): Likewise.
* interface.c (gfc_add_interface): Likewise.
* io.c (gfc_match_format, match_dt_format, match_dt_element,
match_io_iterator, match_io): Likewise.
* match.c (gfc_match_space, gfc_match_eos,
gfc_match_small_literal_int, gfc_match_st_label,
gfc_match_strings, gfc_match_name, gfc_match_iterator,
gfc_match_char, gfc_match, gfc_match_assignment,
gfc_match_pointer_assignment, gfc_match_if, gfc_match_do,
gfc_match_nullify, gfc_match_call, match_implicit_range,
gfc_match_implicit, gfc_match_data, match_case_selector,
gfc_match_case, match_forall_iterator): Likewise.
* matchexp.c (gfc_match_defined_op_name, next_operator,
match_level_1, match_mult_operand, match_ext_mult_operand,
match_add_operand, match_ext_add_operand, match_level_2,
match_level_3, match_level_4, match_and_operand, match_or_operand,
match_equiv_operand, match_level_5, gfc_match_expr): Likewise.
* module.c (gfc_match_use, mio_array_ref, mio_expr): Likewise.
* parse.c (match_word, decode_statement, next_free, next_fixed,
add_statement, verify_st_order, parse_if_block, gfc_parse_file):
Likewise.
* primary.c (match_digits, match_integer_constant,
match_boz_constant, match_real_constant, match_substring,
next_string_char, match_charkind_name, match_string_constant,
match_logical_constant, match_const_complex_part,
match_complex_constant, match_actual_arg, match_keyword_arg,
gfc_match_actual_arglist, gfc_match_structure_constructor,
gfc_match_rvalue, gfc_match_variable): Likewise.
* st.c (gfc_get_code): Likewise.
* symbol.c (check_conflict, check_used, check_done,
duplicate_attr, add_flavor, gfc_add_procedure, gfc_add_intent,
gfc_add_access, gfc_add_explicit_interface, gfc_add_type,
gfc_add_component, gfc_reference_st_label, gfc_new_symbol): Likewise.

From-SVN: r82320
2004-05-27 14:35:12 +02:00

882 lines
15 KiB
C
Raw Blame History

/* Expression parser.
Copyright (C) 2000, 2001, 2002, 2004 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING. If not, write to the Free
Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA. */
#include "config.h"
#include <string.h>
#include "gfortran.h"
#include "arith.h"
#include "match.h"
static char expression_syntax[] = "Syntax error in expression at %C";
/* Match a user-defined operator name. This is a normal name with a
few restrictions. The error_flag controls whether an error is
raised if 'true' or 'false' are used or not. */
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 '%c' in OPERATOR name at %C", name[i]);
return MATCH_ERROR;
}
strcpy (result, name);
return MATCH_YES;
error:
gfc_error ("The name '%s' cannot be used as a defined operator at %C",
name);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
/* Match a user defined operator. The symbol found must be an
operator already. */
static match
match_defined_operator (gfc_user_op ** result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
match m;
m = gfc_match_defined_op_name (name, 0);
if (m != MATCH_YES)
return m;
*result = gfc_get_uop (name);
return MATCH_YES;
}
/* Check to see if the given operator is next on the input. If this
is not the case, the parse pointer remains where it was. */
static int
next_operator (gfc_intrinsic_op t)
{
gfc_intrinsic_op u;
locus old_loc;
old_loc = gfc_current_locus;
if (gfc_match_intrinsic_op (&u) == MATCH_YES && t == u)
return 1;
gfc_current_locus = old_loc;
return 0;
}
/* Match a primary expression. */
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;
}
/* Build an operator expression node. */
static gfc_expr *
build_node (gfc_intrinsic_op operator, locus * where,
gfc_expr * op1, gfc_expr * op2)
{
gfc_expr *new;
new = gfc_get_expr ();
new->expr_type = EXPR_OP;
new->operator = operator;
new->where = *where;
new->op1 = op1;
new->op2 = op2;
return new;
}
/* Match a level 1 expression. */
static match
match_level_1 (gfc_expr ** result)
{
gfc_user_op *uop;
gfc_expr *e, *f;
locus where;
match m;
where = gfc_current_locus;
uop = NULL;
m = match_defined_operator (&uop);
if (m == MATCH_ERROR)
return m;
m = match_primary (&e);
if (m != MATCH_YES)
return m;
if (uop == NULL)
*result = e;
else
{
f = build_node (INTRINSIC_USER, &where, e, NULL);
f->uop = uop;
*result = f;
}
return MATCH_YES;
}
/* As a GNU extension we support an expanded level-2 expression syntax.
Via this extension we support (arbitrary) nesting of unary plus and
minus operations following unary and binary operators, such as **.
The grammar of section 7.1.1.3 is effectively rewitten as:
R704 mult-operand is level-1-expr [ power-op ext-mult-operand ]
R704' ext-mult-operand is add-op ext-mult-operand
or mult-operand
R705 add-operand is add-operand mult-op ext-mult-operand
or mult-operand
R705' ext-add-operand is add-op ext-add-operand
or add-operand
R706 level-2-expr is [ level-2-expr ] add-op ext-add-operand
or add-operand
*/
static match match_ext_mult_operand (gfc_expr ** result);
static match match_ext_add_operand (gfc_expr ** result);
static int
match_add_op (void)
{
if (next_operator (INTRINSIC_MINUS))
return -1;
if (next_operator (INTRINSIC_PLUS))
return 1;
return 0;
}
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 match
match_ext_mult_operand (gfc_expr ** result)
{
gfc_expr *all, *e;
locus where;
match m;
int i;
where = gfc_current_locus;
i = match_add_op ();
if (i == 0)
return match_mult_operand (result);
if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following"
" arithmetic operator (use parentheses) at %C")
== FAILURE)
return MATCH_ERROR;
m = match_ext_mult_operand (&e);
if (m != MATCH_YES)
return m;
if (i == -1)
all = gfc_uminus (e);
else
all = gfc_uplus (e);
if (all == NULL)
{
gfc_free_expr (e);
return MATCH_ERROR;
}
all->where = where;
*result = all;
return MATCH_YES;
}
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;
}
static match
match_ext_add_operand (gfc_expr ** result)
{
gfc_expr *all, *e;
locus where;
match m;
int i;
where = gfc_current_locus;
i = match_add_op ();
if (i == 0)
return match_add_operand (result);
if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following"
" arithmetic operator (use parentheses) at %C")
== FAILURE)
return MATCH_ERROR;
m = match_ext_add_operand (&e);
if (m != MATCH_YES)
return m;
if (i == -1)
all = gfc_uminus (e);
else
all = gfc_uplus (e);
if (all == NULL)
{
gfc_free_expr (e);
return MATCH_ERROR;
}
all->where = where;
*result = all;
return MATCH_YES;
}
/* Match a level 2 expression. */
static match
match_level_2 (gfc_expr ** result)
{
gfc_expr *all, *e, *total;
locus where;
match m;
int i;
where = gfc_current_locus;
i = match_add_op ();
if (i != 0)
{
m = match_ext_add_operand (&e);
if (m == MATCH_NO)
{
gfc_error (expression_syntax);
m = MATCH_ERROR;
}
}
else
m = match_add_operand (&e);
if (m != MATCH_YES)
return m;
if (i == 0)
all = e;
else
{
if (i == -1)
all = gfc_uminus (e);
else
all = gfc_uplus (e);
if (all == NULL)
{
gfc_free_expr (e);
return MATCH_ERROR;
}
}
all->where = where;
/* Append add-operands to the sum */
for (;;)
{
where = gfc_current_locus;
i = match_add_op ();
if (i == 0)
break;
m = match_ext_add_operand (&e);
if (m == MATCH_NO)
gfc_error (expression_syntax);
if (m != MATCH_YES)
{
gfc_free_expr (all);
return MATCH_ERROR;
}
if (i == -1)
total = gfc_subtract (all, e);
else
total = gfc_add (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;
}
/* Match a level three expression. */
static match
match_level_3 (gfc_expr ** result)
{
gfc_expr *all, *e, *total;
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);
gfc_free_expr (all);
}
if (m != MATCH_YES)
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;
}
/* Match a level 4 expression. */
static match
match_level_4 (gfc_expr ** result)
{
gfc_expr *left, *right, *r;
gfc_intrinsic_op i;
locus old_loc;
locus where;
match m;
m = match_level_3 (&left);
if (m != MATCH_YES)
return m;
old_loc = gfc_current_locus;
if (gfc_match_intrinsic_op (&i) != MATCH_YES)
{
*result = left;
return MATCH_YES;
}
if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE
&& i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT)
{
gfc_current_locus = old_loc;
*result = left;
return MATCH_YES;
}
where = gfc_current_locus;
m = match_level_3 (&right);
if (m == MATCH_NO)
gfc_error (expression_syntax);
if (m != MATCH_YES)
{
gfc_free_expr (left);
return MATCH_ERROR;
}
switch (i)
{
case INTRINSIC_EQ:
r = gfc_eq (left, right);
break;
case INTRINSIC_NE:
r = gfc_ne (left, right);
break;
case INTRINSIC_LT:
r = gfc_lt (left, right);
break;
case INTRINSIC_LE:
r = gfc_le (left, right);
break;
case INTRINSIC_GT:
r = gfc_gt (left, right);
break;
case INTRINSIC_GE:
r = gfc_ge (left, right);
break;
default:
gfc_internal_error ("match_level_4(): Bad operator");
}
if (r == NULL)
{
gfc_free_expr (left);
gfc_free_expr (right);
return MATCH_ERROR;
}
r->where = where;
*result = r;
return MATCH_YES;
}
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 match
match_or_operand (gfc_expr ** result)
{
gfc_expr *all, *e, *total;
locus where;
match m;
m = match_and_operand (&all);
if (m != MATCH_YES)
return m;
for (;;)
{
if (!next_operator (INTRINSIC_AND))
break;
where = gfc_current_locus;
m = match_and_operand (&e);
if (m == MATCH_NO)
gfc_error (expression_syntax);
if (m != MATCH_YES)
{
gfc_free_expr (all);
return MATCH_ERROR;
}
total = gfc_and (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_equiv_operand (gfc_expr ** result)
{
gfc_expr *all, *e, *total;
locus where;
match m;
m = match_or_operand (&all);
if (m != MATCH_YES)
return m;
for (;;)
{
if (!next_operator (INTRINSIC_OR))
break;
where = gfc_current_locus;
m = match_or_operand (&e);
if (m == MATCH_NO)
gfc_error (expression_syntax);
if (m != MATCH_YES)
{
gfc_free_expr (all);
return MATCH_ERROR;
}
total = gfc_or (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;
}
/* Match a level 5 expression. */
static match
match_level_5 (gfc_expr ** result)
{
gfc_expr *all, *e, *total;
locus where;
match m;
gfc_intrinsic_op i;
m = match_equiv_operand (&all);
if (m != MATCH_YES)
return m;
for (;;)
{
if (next_operator (INTRINSIC_EQV))
i = INTRINSIC_EQV;
else
{
if (next_operator (INTRINSIC_NEQV))
i = INTRINSIC_NEQV;
else
break;
}
where = gfc_current_locus;
m = match_equiv_operand (&e);
if (m == MATCH_NO)
gfc_error (expression_syntax);
if (m != MATCH_YES)
{
gfc_free_expr (all);
return MATCH_ERROR;
}
if (i == INTRINSIC_EQV)
total = gfc_eqv (all, e);
else
total = gfc_neqv (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;
}
/* Match an expression. At this level, we are stringing together
level 5 expressions separated by binary operators. */
match
gfc_match_expr (gfc_expr ** result)
{
gfc_expr *all, *e;
gfc_user_op *uop;
locus where;
match m;
m = match_level_5 (&all);
if (m != MATCH_YES)
return m;
for (;;)
{
m = match_defined_operator (&uop);
if (m == MATCH_NO)
break;
if (m == MATCH_ERROR)
{
gfc_free_expr (all);
return MATCH_ERROR;
}
where = gfc_current_locus;
m = match_level_5 (&e);
if (m == MATCH_NO)
gfc_error (expression_syntax);
if (m != MATCH_YES)
{
gfc_free_expr (all);
return MATCH_ERROR;
}
all = build_node (INTRINSIC_USER, &where, all, e);
all->uop = uop;
}
*result = all;
return MATCH_YES;
}
Reference in New Issue View Git Blame Copy Permalink