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 /* Call the INTRINSIC_PARENTHESES function. This is both
127 used explicitly, as below, or by resolve.c to generate
130 gfc_get_parentheses (gfc_expr
*e
)
135 e2
->expr_type
= EXPR_OP
;
138 e2
->where
= e
->where
;
139 e2
->value
.op
.operator = INTRINSIC_PARENTHESES
;
140 e2
->value
.op
.op1
= e
;
141 e2
->value
.op
.op2
= NULL
;
146 /* Match a primary expression. */
149 match_primary (gfc_expr
** result
)
155 m
= gfc_match_literal_constant (result
, 0);
159 m
= gfc_match_array_constructor (result
);
163 m
= gfc_match_rvalue (result
);
167 /* Match an expression in parentheses. */
168 where
= gfc_current_locus
;
170 if (gfc_match_char ('(') != MATCH_YES
)
173 m
= gfc_match_expr (&e
);
176 if (m
== MATCH_ERROR
)
179 m
= gfc_match_char (')');
181 gfc_error ("Expected a right parenthesis in expression at %C");
183 /* Now we have the expression inside the parentheses, build the
184 expression pointing to it. By 7.1.7.2 the integrity of
185 parentheses is only conserved in numerical calculations, so we
186 don't bother to keep the parentheses otherwise. */
187 if(!gfc_numeric_ts(&e
->ts
))
190 *result
= gfc_get_parentheses (e
);
194 gfc_free_expr (*result
);
201 gfc_error (expression_syntax
);
206 /* Build an operator expression node. */
209 build_node (gfc_intrinsic_op
operator, locus
* where
,
210 gfc_expr
* op1
, gfc_expr
* op2
)
214 new = gfc_get_expr ();
215 new->expr_type
= EXPR_OP
;
216 new->value
.op
.operator = operator;
219 new->value
.op
.op1
= op1
;
220 new->value
.op
.op2
= op2
;
226 /* Match a level 1 expression. */
229 match_level_1 (gfc_expr
** result
)
236 where
= gfc_current_locus
;
238 m
= match_defined_operator (&uop
);
239 if (m
== MATCH_ERROR
)
242 m
= match_primary (&e
);
250 f
= build_node (INTRINSIC_USER
, &where
, e
, NULL
);
251 f
->value
.op
.uop
= uop
;
259 /* As a GNU extension we support an expanded level-2 expression syntax.
260 Via this extension we support (arbitrary) nesting of unary plus and
261 minus operations following unary and binary operators, such as **.
262 The grammar of section 7.1.1.3 is effectively rewitten as:
264 R704 mult-operand is level-1-expr [ power-op ext-mult-operand ]
265 R704' ext-mult-operand is add-op ext-mult-operand
267 R705 add-operand is add-operand mult-op ext-mult-operand
269 R705' ext-add-operand is add-op ext-add-operand
271 R706 level-2-expr is [ level-2-expr ] add-op ext-add-operand
275 static match
match_ext_mult_operand (gfc_expr
** result
);
276 static match
match_ext_add_operand (gfc_expr
** result
);
283 if (next_operator (INTRINSIC_MINUS
))
285 if (next_operator (INTRINSIC_PLUS
))
292 match_mult_operand (gfc_expr
** result
)
294 gfc_expr
*e
, *exp
, *r
;
298 m
= match_level_1 (&e
);
302 if (!next_operator (INTRINSIC_POWER
))
308 where
= gfc_current_locus
;
310 m
= match_ext_mult_operand (&exp
);
312 gfc_error ("Expected exponent in expression at %C");
319 r
= gfc_power (e
, exp
);
335 match_ext_mult_operand (gfc_expr
** result
)
342 where
= gfc_current_locus
;
346 return match_mult_operand (result
);
348 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Unary operator following"
349 " arithmetic operator (use parentheses) at %C")
353 m
= match_ext_mult_operand (&e
);
358 all
= gfc_uminus (e
);
375 match_add_operand (gfc_expr
** result
)
377 gfc_expr
*all
, *e
, *total
;
378 locus where
, old_loc
;
382 m
= match_mult_operand (&all
);
388 /* Build up a string of products or quotients. */
390 old_loc
= gfc_current_locus
;
392 if (next_operator (INTRINSIC_TIMES
))
396 if (next_operator (INTRINSIC_DIVIDE
))
397 i
= INTRINSIC_DIVIDE
;
402 where
= gfc_current_locus
;
404 m
= match_ext_mult_operand (&e
);
407 gfc_current_locus
= old_loc
;
411 if (m
== MATCH_ERROR
)
417 if (i
== INTRINSIC_TIMES
)
418 total
= gfc_multiply (all
, e
);
420 total
= gfc_divide (all
, e
);
439 match_ext_add_operand (gfc_expr
** result
)
446 where
= gfc_current_locus
;
450 return match_add_operand (result
);
452 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Unary operator following"
453 " arithmetic operator (use parentheses) at %C")
457 m
= match_ext_add_operand (&e
);
462 all
= gfc_uminus (e
);
478 /* Match a level 2 expression. */
481 match_level_2 (gfc_expr
** result
)
483 gfc_expr
*all
, *e
, *total
;
488 where
= gfc_current_locus
;
493 m
= match_ext_add_operand (&e
);
496 gfc_error (expression_syntax
);
501 m
= match_add_operand (&e
);
511 all
= gfc_uminus (e
);
524 /* Append add-operands to the sum */
528 where
= gfc_current_locus
;
533 m
= match_ext_add_operand (&e
);
535 gfc_error (expression_syntax
);
543 total
= gfc_subtract (all
, e
);
545 total
= gfc_add (all
, e
);
563 /* Match a level three expression. */
566 match_level_3 (gfc_expr
** result
)
568 gfc_expr
*all
, *e
, *total
;
572 m
= match_level_2 (&all
);
578 if (!next_operator (INTRINSIC_CONCAT
))
581 where
= gfc_current_locus
;
583 m
= match_level_2 (&e
);
586 gfc_error (expression_syntax
);
592 total
= gfc_concat (all
, e
);
609 /* Match a level 4 expression. */
612 match_level_4 (gfc_expr
** result
)
614 gfc_expr
*left
, *right
, *r
;
620 m
= match_level_3 (&left
);
624 old_loc
= gfc_current_locus
;
626 if (gfc_match_intrinsic_op (&i
) != MATCH_YES
)
632 if (i
!= INTRINSIC_EQ
&& i
!= INTRINSIC_NE
&& i
!= INTRINSIC_GE
633 && i
!= INTRINSIC_LE
&& i
!= INTRINSIC_LT
&& i
!= INTRINSIC_GT
)
635 gfc_current_locus
= old_loc
;
640 where
= gfc_current_locus
;
642 m
= match_level_3 (&right
);
644 gfc_error (expression_syntax
);
647 gfc_free_expr (left
);
654 r
= gfc_eq (left
, right
);
658 r
= gfc_ne (left
, right
);
662 r
= gfc_lt (left
, right
);
666 r
= gfc_le (left
, right
);
670 r
= gfc_gt (left
, right
);
674 r
= gfc_ge (left
, right
);
678 gfc_internal_error ("match_level_4(): Bad operator");
683 gfc_free_expr (left
);
684 gfc_free_expr (right
);
696 match_and_operand (gfc_expr
** result
)
703 i
= next_operator (INTRINSIC_NOT
);
704 where
= gfc_current_locus
;
706 m
= match_level_4 (&e
);
729 match_or_operand (gfc_expr
** result
)
731 gfc_expr
*all
, *e
, *total
;
735 m
= match_and_operand (&all
);
741 if (!next_operator (INTRINSIC_AND
))
743 where
= gfc_current_locus
;
745 m
= match_and_operand (&e
);
747 gfc_error (expression_syntax
);
754 total
= gfc_and (all
, e
);
772 match_equiv_operand (gfc_expr
** result
)
774 gfc_expr
*all
, *e
, *total
;
778 m
= match_or_operand (&all
);
784 if (!next_operator (INTRINSIC_OR
))
786 where
= gfc_current_locus
;
788 m
= match_or_operand (&e
);
790 gfc_error (expression_syntax
);
797 total
= gfc_or (all
, e
);
814 /* Match a level 5 expression. */
817 match_level_5 (gfc_expr
** result
)
819 gfc_expr
*all
, *e
, *total
;
824 m
= match_equiv_operand (&all
);
830 if (next_operator (INTRINSIC_EQV
))
834 if (next_operator (INTRINSIC_NEQV
))
840 where
= gfc_current_locus
;
842 m
= match_equiv_operand (&e
);
844 gfc_error (expression_syntax
);
851 if (i
== INTRINSIC_EQV
)
852 total
= gfc_eqv (all
, e
);
854 total
= gfc_neqv (all
, e
);
872 /* Match an expression. At this level, we are stringing together
873 level 5 expressions separated by binary operators. */
876 gfc_match_expr (gfc_expr
** result
)
883 m
= match_level_5 (&all
);
890 m
= match_defined_operator (&uop
);
893 if (m
== MATCH_ERROR
)
899 where
= gfc_current_locus
;
901 m
= match_level_5 (&e
);
903 gfc_error (expression_syntax
);
910 all
= build_node (INTRINSIC_USER
, &where
, all
, e
);
911 all
->value
.op
.uop
= uop
;