2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
30 static char expression_syntax
[] = N_("Syntax error in expression at %C");
33 /* Match a user-defined operator name. This is a normal name with a
34 few restrictions. The error_flag controls whether an error is
35 raised if 'true' or 'false' are used or not. */
38 gfc_match_defined_op_name (char *result
, int error_flag
)
40 static const char * const badops
[] = {
41 "and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt",
45 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
50 old_loc
= gfc_current_locus
;
52 m
= gfc_match (" . %n .", name
);
56 /* .true. and .false. have interpretations as constants. Trying to
57 use these as operators will fail at a later time. */
59 if (strcmp (name
, "true") == 0 || strcmp (name
, "false") == 0)
63 gfc_current_locus
= old_loc
;
67 for (i
= 0; badops
[i
]; i
++)
68 if (strcmp (badops
[i
], name
) == 0)
71 for (i
= 0; name
[i
]; i
++)
72 if (!ISALPHA (name
[i
]))
74 gfc_error ("Bad character '%c' in OPERATOR name at %C", name
[i
]);
78 strcpy (result
, name
);
82 gfc_error ("The name '%s' cannot be used as a defined operator at %C",
85 gfc_current_locus
= old_loc
;
90 /* Match a user defined operator. The symbol found must be an
94 match_defined_operator (gfc_user_op
** result
)
96 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
99 m
= gfc_match_defined_op_name (name
, 0);
103 *result
= gfc_get_uop (name
);
108 /* Check to see if the given operator is next on the input. If this
109 is not the case, the parse pointer remains where it was. */
112 next_operator (gfc_intrinsic_op t
)
117 old_loc
= gfc_current_locus
;
118 if (gfc_match_intrinsic_op (&u
) == MATCH_YES
&& t
== u
)
121 gfc_current_locus
= old_loc
;
126 /* Match a primary expression. */
129 match_primary (gfc_expr
** result
)
135 m
= gfc_match_literal_constant (result
, 0);
139 m
= gfc_match_array_constructor (result
);
143 m
= gfc_match_rvalue (result
);
147 /* Match an expression in parentheses. */
148 where
= gfc_current_locus
;
150 if (gfc_match_char ('(') != MATCH_YES
)
153 m
= gfc_match_expr (&e
);
156 if (m
== MATCH_ERROR
)
159 m
= gfc_match_char (')');
161 gfc_error ("Expected a right parenthesis in expression at %C");
163 /* Now we have the expression inside the parentheses, build the
164 expression pointing to it. By 7.1.7.2 the integrity of
165 parentheses is only conserved in numerical calculations, so we
166 don't bother to keep the parentheses otherwise. */
167 if(!gfc_numeric_ts(&e
->ts
))
171 gfc_expr
*e2
= gfc_get_expr();
173 e2
->expr_type
= EXPR_OP
;
177 e2
->value
.op
.operator = INTRINSIC_PARENTHESES
;
178 e2
->value
.op
.op1
= e
;
179 e2
->value
.op
.op2
= NULL
;
185 gfc_free_expr (*result
);
192 gfc_error (expression_syntax
);
197 /* Build an operator expression node. */
200 build_node (gfc_intrinsic_op
operator, locus
* where
,
201 gfc_expr
* op1
, gfc_expr
* op2
)
205 new = gfc_get_expr ();
206 new->expr_type
= EXPR_OP
;
207 new->value
.op
.operator = operator;
210 new->value
.op
.op1
= op1
;
211 new->value
.op
.op2
= op2
;
217 /* Match a level 1 expression. */
220 match_level_1 (gfc_expr
** result
)
227 where
= gfc_current_locus
;
229 m
= match_defined_operator (&uop
);
230 if (m
== MATCH_ERROR
)
233 m
= match_primary (&e
);
241 f
= build_node (INTRINSIC_USER
, &where
, e
, NULL
);
242 f
->value
.op
.uop
= uop
;
250 /* As a GNU extension we support an expanded level-2 expression syntax.
251 Via this extension we support (arbitrary) nesting of unary plus and
252 minus operations following unary and binary operators, such as **.
253 The grammar of section 7.1.1.3 is effectively rewitten as:
255 R704 mult-operand is level-1-expr [ power-op ext-mult-operand ]
256 R704' ext-mult-operand is add-op ext-mult-operand
258 R705 add-operand is add-operand mult-op ext-mult-operand
260 R705' ext-add-operand is add-op ext-add-operand
262 R706 level-2-expr is [ level-2-expr ] add-op ext-add-operand
266 static match
match_ext_mult_operand (gfc_expr
** result
);
267 static match
match_ext_add_operand (gfc_expr
** result
);
274 if (next_operator (INTRINSIC_MINUS
))
276 if (next_operator (INTRINSIC_PLUS
))
283 match_mult_operand (gfc_expr
** result
)
285 gfc_expr
*e
, *exp
, *r
;
289 m
= match_level_1 (&e
);
293 if (!next_operator (INTRINSIC_POWER
))
299 where
= gfc_current_locus
;
301 m
= match_ext_mult_operand (&exp
);
303 gfc_error ("Expected exponent in expression at %C");
310 r
= gfc_power (e
, exp
);
326 match_ext_mult_operand (gfc_expr
** result
)
333 where
= gfc_current_locus
;
337 return match_mult_operand (result
);
339 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Unary operator following"
340 " arithmetic operator (use parentheses) at %C")
344 m
= match_ext_mult_operand (&e
);
349 all
= gfc_uminus (e
);
366 match_add_operand (gfc_expr
** result
)
368 gfc_expr
*all
, *e
, *total
;
369 locus where
, old_loc
;
373 m
= match_mult_operand (&all
);
379 /* Build up a string of products or quotients. */
381 old_loc
= gfc_current_locus
;
383 if (next_operator (INTRINSIC_TIMES
))
387 if (next_operator (INTRINSIC_DIVIDE
))
388 i
= INTRINSIC_DIVIDE
;
393 where
= gfc_current_locus
;
395 m
= match_ext_mult_operand (&e
);
398 gfc_current_locus
= old_loc
;
402 if (m
== MATCH_ERROR
)
408 if (i
== INTRINSIC_TIMES
)
409 total
= gfc_multiply (all
, e
);
411 total
= gfc_divide (all
, e
);
430 match_ext_add_operand (gfc_expr
** result
)
437 where
= gfc_current_locus
;
441 return match_add_operand (result
);
443 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Unary operator following"
444 " arithmetic operator (use parentheses) at %C")
448 m
= match_ext_add_operand (&e
);
453 all
= gfc_uminus (e
);
469 /* Match a level 2 expression. */
472 match_level_2 (gfc_expr
** result
)
474 gfc_expr
*all
, *e
, *total
;
479 where
= gfc_current_locus
;
484 m
= match_ext_add_operand (&e
);
487 gfc_error (expression_syntax
);
492 m
= match_add_operand (&e
);
502 all
= gfc_uminus (e
);
515 /* Append add-operands to the sum */
519 where
= gfc_current_locus
;
524 m
= match_ext_add_operand (&e
);
526 gfc_error (expression_syntax
);
534 total
= gfc_subtract (all
, e
);
536 total
= gfc_add (all
, e
);
554 /* Match a level three expression. */
557 match_level_3 (gfc_expr
** result
)
559 gfc_expr
*all
, *e
, *total
;
563 m
= match_level_2 (&all
);
569 if (!next_operator (INTRINSIC_CONCAT
))
572 where
= gfc_current_locus
;
574 m
= match_level_2 (&e
);
577 gfc_error (expression_syntax
);
583 total
= gfc_concat (all
, e
);
600 /* Match a level 4 expression. */
603 match_level_4 (gfc_expr
** result
)
605 gfc_expr
*left
, *right
, *r
;
611 m
= match_level_3 (&left
);
615 old_loc
= gfc_current_locus
;
617 if (gfc_match_intrinsic_op (&i
) != MATCH_YES
)
623 if (i
!= INTRINSIC_EQ
&& i
!= INTRINSIC_NE
&& i
!= INTRINSIC_GE
624 && i
!= INTRINSIC_LE
&& i
!= INTRINSIC_LT
&& i
!= INTRINSIC_GT
)
626 gfc_current_locus
= old_loc
;
631 where
= gfc_current_locus
;
633 m
= match_level_3 (&right
);
635 gfc_error (expression_syntax
);
638 gfc_free_expr (left
);
645 r
= gfc_eq (left
, right
);
649 r
= gfc_ne (left
, right
);
653 r
= gfc_lt (left
, right
);
657 r
= gfc_le (left
, right
);
661 r
= gfc_gt (left
, right
);
665 r
= gfc_ge (left
, right
);
669 gfc_internal_error ("match_level_4(): Bad operator");
674 gfc_free_expr (left
);
675 gfc_free_expr (right
);
687 match_and_operand (gfc_expr
** result
)
694 i
= next_operator (INTRINSIC_NOT
);
695 where
= gfc_current_locus
;
697 m
= match_level_4 (&e
);
720 match_or_operand (gfc_expr
** result
)
722 gfc_expr
*all
, *e
, *total
;
726 m
= match_and_operand (&all
);
732 if (!next_operator (INTRINSIC_AND
))
734 where
= gfc_current_locus
;
736 m
= match_and_operand (&e
);
738 gfc_error (expression_syntax
);
745 total
= gfc_and (all
, e
);
763 match_equiv_operand (gfc_expr
** result
)
765 gfc_expr
*all
, *e
, *total
;
769 m
= match_or_operand (&all
);
775 if (!next_operator (INTRINSIC_OR
))
777 where
= gfc_current_locus
;
779 m
= match_or_operand (&e
);
781 gfc_error (expression_syntax
);
788 total
= gfc_or (all
, e
);
805 /* Match a level 5 expression. */
808 match_level_5 (gfc_expr
** result
)
810 gfc_expr
*all
, *e
, *total
;
815 m
= match_equiv_operand (&all
);
821 if (next_operator (INTRINSIC_EQV
))
825 if (next_operator (INTRINSIC_NEQV
))
831 where
= gfc_current_locus
;
833 m
= match_equiv_operand (&e
);
835 gfc_error (expression_syntax
);
842 if (i
== INTRINSIC_EQV
)
843 total
= gfc_eqv (all
, e
);
845 total
= gfc_neqv (all
, e
);
863 /* Match an expression. At this level, we are stringing together
864 level 5 expressions separated by binary operators. */
867 gfc_match_expr (gfc_expr
** result
)
874 m
= match_level_5 (&all
);
881 m
= match_defined_operator (&uop
);
884 if (m
== MATCH_ERROR
)
890 where
= gfc_current_locus
;
892 m
= match_level_5 (&e
);
894 gfc_error (expression_syntax
);
901 all
= build_node (INTRINSIC_USER
, &where
, all
, e
);
902 all
->value
.op
.uop
= uop
;