2 Copyright (C) 2000-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
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 e2 = gfc_get_operator_expr (&e->where, INTRINSIC_PARENTHESES, e, NULL);
141 /* Match a primary expression. */
144 match_primary (gfc_expr **result)
149 m = gfc_match_literal_constant (result, 0);
153 m = gfc_match_array_constructor (result);
157 m = gfc_match_rvalue (result);
161 /* Match an expression in parentheses. */
162 if (gfc_match_char ('(') != MATCH_YES)
165 m = gfc_match_expr (&e);
168 if (m == MATCH_ERROR)
171 m = gfc_match_char (')');
173 gfc_error ("Expected a right parenthesis in expression at %C");
175 /* Now we have the expression inside the parentheses, build the
176 expression pointing to it. By 7.1.7.2, any expression in
177 parentheses shall be treated as a data entity. */
178 *result = gfc_get_parentheses (e);
182 gfc_free_expr (*result);
189 gfc_error (expression_syntax);
194 /* Match a level 1 expression. */
197 match_level_1 (gfc_expr **result)
204 gfc_gobble_whitespace ();
205 where = gfc_current_locus;
207 m = match_defined_operator (&uop);
208 if (m == MATCH_ERROR)
211 m = match_primary (&e);
219 f = gfc_get_operator_expr (&where, INTRINSIC_USER, e, NULL);
220 f->value.op.uop = uop;
228 /* As a GNU extension we support an expanded level-2 expression syntax.
229 Via this extension we support (arbitrary) nesting of unary plus and
230 minus operations following unary and binary operators, such as **.
231 The grammar of section 7.1.1.3 is effectively rewritten as:
233 R704 mult-operand is level-1-expr [ power-op ext-mult-operand ]
234 R704' ext-mult-operand is add-op ext-mult-operand
236 R705 add-operand is add-operand mult-op ext-mult-operand
238 R705' ext-add-operand is add-op ext-add-operand
240 R706 level-2-expr is [ level-2-expr ] add-op ext-add-operand
244 static match match_ext_mult_operand (gfc_expr **result);
245 static match match_ext_add_operand (gfc_expr **result);
250 if (next_operator (INTRINSIC_MINUS))
252 if (next_operator (INTRINSIC_PLUS))
259 match_mult_operand (gfc_expr **result)
261 gfc_expr *e, *exp, *r;
265 m = match_level_1 (&e);
269 if (!next_operator (INTRINSIC_POWER))
275 where = gfc_current_locus;
277 m = match_ext_mult_operand (&exp);
279 gfc_error ("Expected exponent in expression at %C");
286 r = gfc_power (e, exp);
302 match_ext_mult_operand (gfc_expr **result)
309 where = gfc_current_locus;
313 return match_mult_operand (result);
315 if (gfc_notification_std (GFC_STD_GNU) == ERROR)
317 gfc_error ("Extension: Unary operator following "
318 "arithmetic operator (use parentheses) at %C");
322 gfc_warning ("Extension: Unary operator following "
323 "arithmetic operator (use parentheses) at %C");
325 m = match_ext_mult_operand (&e);
330 all = gfc_uminus (e);
347 match_add_operand (gfc_expr **result)
349 gfc_expr *all, *e, *total;
350 locus where, old_loc;
354 m = match_mult_operand (&all);
360 /* Build up a string of products or quotients. */
362 old_loc = gfc_current_locus;
364 if (next_operator (INTRINSIC_TIMES))
368 if (next_operator (INTRINSIC_DIVIDE))
369 i = INTRINSIC_DIVIDE;
374 where = gfc_current_locus;
376 m = match_ext_mult_operand (&e);
379 gfc_current_locus = old_loc;
383 if (m == MATCH_ERROR)
389 if (i == INTRINSIC_TIMES)
390 total = gfc_multiply (all, e);
392 total = gfc_divide (all, e);
411 match_ext_add_operand (gfc_expr **result)
418 where = gfc_current_locus;
422 return match_add_operand (result);
424 if (gfc_notification_std (GFC_STD_GNU) == ERROR)
426 gfc_error ("Extension: Unary operator following "
427 "arithmetic operator (use parentheses) at %C");
431 gfc_warning ("Extension: Unary operator following "
432 "arithmetic operator (use parentheses) at %C");
434 m = match_ext_add_operand (&e);
439 all = gfc_uminus (e);
455 /* Match a level 2 expression. */
458 match_level_2 (gfc_expr **result)
460 gfc_expr *all, *e, *total;
465 where = gfc_current_locus;
470 m = match_ext_add_operand (&e);
473 gfc_error (expression_syntax);
478 m = match_add_operand (&e);
488 all = gfc_uminus (e);
501 /* Append add-operands to the sum. */
505 where = gfc_current_locus;
510 m = match_ext_add_operand (&e);
512 gfc_error (expression_syntax);
520 total = gfc_subtract (all, e);
522 total = gfc_add (all, e);
540 /* Match a level three expression. */
543 match_level_3 (gfc_expr **result)
545 gfc_expr *all, *e, *total = NULL;
549 m = match_level_2 (&all);
555 if (!next_operator (INTRINSIC_CONCAT))
558 where = gfc_current_locus;
560 m = match_level_2 (&e);
562 gfc_error (expression_syntax);
569 total = gfc_concat (all, e);
586 /* Match a level 4 expression. */
589 match_level_4 (gfc_expr **result)
591 gfc_expr *left, *right, *r;
597 m = match_level_3 (&left);
601 old_loc = gfc_current_locus;
603 if (gfc_match_intrinsic_op (&i) != MATCH_YES)
609 if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE
610 && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT
611 && i != INTRINSIC_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS
612 && i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS)
614 gfc_current_locus = old_loc;
619 where = gfc_current_locus;
621 m = match_level_3 (&right);
623 gfc_error (expression_syntax);
626 gfc_free_expr (left);
633 case INTRINSIC_EQ_OS:
634 r = gfc_eq (left, right, i);
638 case INTRINSIC_NE_OS:
639 r = gfc_ne (left, right, i);
643 case INTRINSIC_LT_OS:
644 r = gfc_lt (left, right, i);
648 case INTRINSIC_LE_OS:
649 r = gfc_le (left, right, i);
653 case INTRINSIC_GT_OS:
654 r = gfc_gt (left, right, i);
658 case INTRINSIC_GE_OS:
659 r = gfc_ge (left, right, i);
663 gfc_internal_error ("match_level_4(): Bad operator");
668 gfc_free_expr (left);
669 gfc_free_expr (right);
681 match_and_operand (gfc_expr **result)
688 i = next_operator (INTRINSIC_NOT);
689 where = gfc_current_locus;
691 m = match_level_4 (&e);
714 match_or_operand (gfc_expr **result)
716 gfc_expr *all, *e, *total;
720 m = match_and_operand (&all);
726 if (!next_operator (INTRINSIC_AND))
728 where = gfc_current_locus;
730 m = match_and_operand (&e);
732 gfc_error (expression_syntax);
739 total = gfc_and (all, e);
757 match_equiv_operand (gfc_expr **result)
759 gfc_expr *all, *e, *total;
763 m = match_or_operand (&all);
769 if (!next_operator (INTRINSIC_OR))
771 where = gfc_current_locus;
773 m = match_or_operand (&e);
775 gfc_error (expression_syntax);
782 total = gfc_or (all, e);
799 /* Match a level 5 expression. */
802 match_level_5 (gfc_expr **result)
804 gfc_expr *all, *e, *total;
809 m = match_equiv_operand (&all);
815 if (next_operator (INTRINSIC_EQV))
819 if (next_operator (INTRINSIC_NEQV))
825 where = gfc_current_locus;
827 m = match_equiv_operand (&e);
829 gfc_error (expression_syntax);
836 if (i == INTRINSIC_EQV)
837 total = gfc_eqv (all, e);
839 total = gfc_neqv (all, e);
857 /* Match an expression. At this level, we are stringing together
858 level 5 expressions separated by binary operators. */
861 gfc_match_expr (gfc_expr **result)
868 m = match_level_5 (&all);
875 m = match_defined_operator (&uop);
878 if (m == MATCH_ERROR)
884 where = gfc_current_locus;
886 m = match_level_5 (&e);
888 gfc_error (expression_syntax);
895 all = gfc_get_operator_expr (&where, INTRINSIC_USER, all, e);
896 all->value.op.uop = uop;