2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 static char expression_syntax[] = N_("Syntax error in expression at %C");
31 /* Match a user-defined operator name. This is a normal name with a
32 few restrictions. The error_flag controls whether an error is
33 raised if 'true' or 'false' are used or not. */
36 gfc_match_defined_op_name (char *result, int error_flag)
38 static const char * const badops[] = {
39 "and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt",
43 char name[GFC_MAX_SYMBOL_LEN + 1];
48 old_loc = gfc_current_locus;
50 m = gfc_match (" . %n .", name);
54 /* .true. and .false. have interpretations as constants. Trying to
55 use these as operators will fail at a later time. */
57 if (strcmp (name, "true") == 0 || strcmp (name, "false") == 0)
61 gfc_current_locus = old_loc;
65 for (i = 0; badops[i]; i++)
66 if (strcmp (badops[i], name) == 0)
69 for (i = 0; name[i]; i++)
70 if (!ISALPHA (name[i]))
72 gfc_error ("Bad character '%c' in OPERATOR name at %C", name[i]);
76 strcpy (result, name);
80 gfc_error ("The name '%s' cannot be used as a defined operator at %C",
83 gfc_current_locus = old_loc;
88 /* Match a user defined operator. The symbol found must be an
92 match_defined_operator (gfc_user_op **result)
94 char name[GFC_MAX_SYMBOL_LEN + 1];
97 m = gfc_match_defined_op_name (name, 0);
101 *result = gfc_get_uop (name);
106 /* Check to see if the given operator is next on the input. If this
107 is not the case, the parse pointer remains where it was. */
110 next_operator (gfc_intrinsic_op t)
115 old_loc = gfc_current_locus;
116 if (gfc_match_intrinsic_op (&u) == MATCH_YES && t == u)
119 gfc_current_locus = old_loc;
124 /* Call the INTRINSIC_PARENTHESES function. This is both
125 used explicitly, as below, or by resolve.c to generate
129 gfc_get_parentheses (gfc_expr *e)
133 /* This is a temporary fix, awaiting the patch for various
134 other character problems. The resolution and translation
135 of substrings and concatenations are so kludged up that
136 putting parentheses around them breaks everything. */
137 if (e->ts.type == BT_CHARACTER && e->ref)
141 e2->expr_type = EXPR_OP;
144 e2->where = e->where;
145 e2->value.op.operator = INTRINSIC_PARENTHESES;
146 e2->value.op.op1 = e;
147 e2->value.op.op2 = NULL;
152 /* Match a primary expression. */
155 match_primary (gfc_expr **result)
161 m = gfc_match_literal_constant (result, 0);
165 m = gfc_match_array_constructor (result);
169 m = gfc_match_rvalue (result);
173 /* Match an expression in parentheses. */
174 where = gfc_current_locus;
176 if (gfc_match_char ('(') != MATCH_YES)
179 m = gfc_match_expr (&e);
182 if (m == MATCH_ERROR)
185 m = gfc_match_char (')');
187 gfc_error ("Expected a right parenthesis in expression at %C");
189 /* Now we have the expression inside the parentheses, build the
190 expression pointing to it. By 7.1.7.2, any expression in
191 parentheses shall be treated as a data entity. */
192 *result = gfc_get_parentheses (e);
196 gfc_free_expr (*result);
203 gfc_error (expression_syntax);
208 /* Build an operator expression node. */
211 build_node (gfc_intrinsic_op operator, locus *where,
212 gfc_expr *op1, gfc_expr *op2)
216 new = gfc_get_expr ();
217 new->expr_type = EXPR_OP;
218 new->value.op.operator = operator;
221 new->value.op.op1 = op1;
222 new->value.op.op2 = op2;
228 /* Match a level 1 expression. */
231 match_level_1 (gfc_expr **result)
238 where = gfc_current_locus;
240 m = match_defined_operator (&uop);
241 if (m == MATCH_ERROR)
244 m = match_primary (&e);
252 f = build_node (INTRINSIC_USER, &where, e, NULL);
253 f->value.op.uop = uop;
261 /* As a GNU extension we support an expanded level-2 expression syntax.
262 Via this extension we support (arbitrary) nesting of unary plus and
263 minus operations following unary and binary operators, such as **.
264 The grammar of section 7.1.1.3 is effectively rewitten as:
266 R704 mult-operand is level-1-expr [ power-op ext-mult-operand ]
267 R704' ext-mult-operand is add-op ext-mult-operand
269 R705 add-operand is add-operand mult-op ext-mult-operand
271 R705' ext-add-operand is add-op ext-add-operand
273 R706 level-2-expr is [ level-2-expr ] add-op ext-add-operand
277 static match match_ext_mult_operand (gfc_expr **result);
278 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
634 && i != INTRINSIC_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS
635 && i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS)
637 gfc_current_locus = old_loc;
642 where = gfc_current_locus;
644 m = match_level_3 (&right);
646 gfc_error (expression_syntax);
649 gfc_free_expr (left);
656 case INTRINSIC_EQ_OS:
657 r = gfc_eq (left, right, i);
661 case INTRINSIC_NE_OS:
662 r = gfc_ne (left, right, i);
666 case INTRINSIC_LT_OS:
667 r = gfc_lt (left, right, i);
671 case INTRINSIC_LE_OS:
672 r = gfc_le (left, right, i);
676 case INTRINSIC_GT_OS:
677 r = gfc_gt (left, right, i);
681 case INTRINSIC_GE_OS:
682 r = gfc_ge (left, right, i);
686 gfc_internal_error ("match_level_4(): Bad operator");
691 gfc_free_expr (left);
692 gfc_free_expr (right);
704 match_and_operand (gfc_expr **result)
711 i = next_operator (INTRINSIC_NOT);
712 where = gfc_current_locus;
714 m = match_level_4 (&e);
737 match_or_operand (gfc_expr **result)
739 gfc_expr *all, *e, *total;
743 m = match_and_operand (&all);
749 if (!next_operator (INTRINSIC_AND))
751 where = gfc_current_locus;
753 m = match_and_operand (&e);
755 gfc_error (expression_syntax);
762 total = gfc_and (all, e);
780 match_equiv_operand (gfc_expr **result)
782 gfc_expr *all, *e, *total;
786 m = match_or_operand (&all);
792 if (!next_operator (INTRINSIC_OR))
794 where = gfc_current_locus;
796 m = match_or_operand (&e);
798 gfc_error (expression_syntax);
805 total = gfc_or (all, e);
822 /* Match a level 5 expression. */
825 match_level_5 (gfc_expr **result)
827 gfc_expr *all, *e, *total;
832 m = match_equiv_operand (&all);
838 if (next_operator (INTRINSIC_EQV))
842 if (next_operator (INTRINSIC_NEQV))
848 where = gfc_current_locus;
850 m = match_equiv_operand (&e);
852 gfc_error (expression_syntax);
859 if (i == INTRINSIC_EQV)
860 total = gfc_eqv (all, e);
862 total = gfc_neqv (all, e);
880 /* Match an expression. At this level, we are stringing together
881 level 5 expressions separated by binary operators. */
884 gfc_match_expr (gfc_expr **result)
891 m = match_level_5 (&all);
898 m = match_defined_operator (&uop);
901 if (m == MATCH_ERROR)
907 where = gfc_current_locus;
909 m = match_level_5 (&e);
911 gfc_error (expression_syntax);
918 all = build_node (INTRINSIC_USER, &where, all, e);
919 all->value.op.uop = uop;