2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
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_notification_std (GFC_STD_GNU
) == ERROR
)
350 gfc_error ("Extension: Unary operator following "
351 "arithmetic operator (use parentheses) at %C");
355 gfc_warning ("Extension: Unary operator following "
356 "arithmetic operator (use parentheses) at %C");
358 m
= match_ext_mult_operand (&e
);
363 all
= gfc_uminus (e
);
380 match_add_operand (gfc_expr
**result
)
382 gfc_expr
*all
, *e
, *total
;
383 locus where
, old_loc
;
387 m
= match_mult_operand (&all
);
393 /* Build up a string of products or quotients. */
395 old_loc
= gfc_current_locus
;
397 if (next_operator (INTRINSIC_TIMES
))
401 if (next_operator (INTRINSIC_DIVIDE
))
402 i
= INTRINSIC_DIVIDE
;
407 where
= gfc_current_locus
;
409 m
= match_ext_mult_operand (&e
);
412 gfc_current_locus
= old_loc
;
416 if (m
== MATCH_ERROR
)
422 if (i
== INTRINSIC_TIMES
)
423 total
= gfc_multiply (all
, e
);
425 total
= gfc_divide (all
, e
);
444 match_ext_add_operand (gfc_expr
**result
)
451 where
= gfc_current_locus
;
455 return match_add_operand (result
);
457 if (gfc_notification_std (GFC_STD_GNU
) == ERROR
)
459 gfc_error ("Extension: Unary operator following "
460 "arithmetic operator (use parentheses) at %C");
464 gfc_warning ("Extension: Unary operator following "
465 "arithmetic operator (use parentheses) at %C");
467 m
= match_ext_add_operand (&e
);
472 all
= gfc_uminus (e
);
488 /* Match a level 2 expression. */
491 match_level_2 (gfc_expr
**result
)
493 gfc_expr
*all
, *e
, *total
;
498 where
= gfc_current_locus
;
503 m
= match_ext_add_operand (&e
);
506 gfc_error (expression_syntax
);
511 m
= match_add_operand (&e
);
521 all
= gfc_uminus (e
);
534 /* Append add-operands to the sum. */
538 where
= gfc_current_locus
;
543 m
= match_ext_add_operand (&e
);
545 gfc_error (expression_syntax
);
553 total
= gfc_subtract (all
, e
);
555 total
= gfc_add (all
, e
);
573 /* Match a level three expression. */
576 match_level_3 (gfc_expr
**result
)
578 gfc_expr
*all
, *e
, *total
;
582 m
= match_level_2 (&all
);
588 if (!next_operator (INTRINSIC_CONCAT
))
591 where
= gfc_current_locus
;
593 m
= match_level_2 (&e
);
596 gfc_error (expression_syntax
);
602 total
= gfc_concat (all
, e
);
619 /* Match a level 4 expression. */
622 match_level_4 (gfc_expr
**result
)
624 gfc_expr
*left
, *right
, *r
;
630 m
= match_level_3 (&left
);
634 old_loc
= gfc_current_locus
;
636 if (gfc_match_intrinsic_op (&i
) != MATCH_YES
)
642 if (i
!= INTRINSIC_EQ
&& i
!= INTRINSIC_NE
&& i
!= INTRINSIC_GE
643 && i
!= INTRINSIC_LE
&& i
!= INTRINSIC_LT
&& i
!= INTRINSIC_GT
644 && i
!= INTRINSIC_EQ_OS
&& i
!= INTRINSIC_NE_OS
&& i
!= INTRINSIC_GE_OS
645 && i
!= INTRINSIC_LE_OS
&& i
!= INTRINSIC_LT_OS
&& i
!= INTRINSIC_GT_OS
)
647 gfc_current_locus
= old_loc
;
652 where
= gfc_current_locus
;
654 m
= match_level_3 (&right
);
656 gfc_error (expression_syntax
);
659 gfc_free_expr (left
);
666 case INTRINSIC_EQ_OS
:
667 r
= gfc_eq (left
, right
, i
);
671 case INTRINSIC_NE_OS
:
672 r
= gfc_ne (left
, right
, i
);
676 case INTRINSIC_LT_OS
:
677 r
= gfc_lt (left
, right
, i
);
681 case INTRINSIC_LE_OS
:
682 r
= gfc_le (left
, right
, i
);
686 case INTRINSIC_GT_OS
:
687 r
= gfc_gt (left
, right
, i
);
691 case INTRINSIC_GE_OS
:
692 r
= gfc_ge (left
, right
, i
);
696 gfc_internal_error ("match_level_4(): Bad operator");
701 gfc_free_expr (left
);
702 gfc_free_expr (right
);
714 match_and_operand (gfc_expr
**result
)
721 i
= next_operator (INTRINSIC_NOT
);
722 where
= gfc_current_locus
;
724 m
= match_level_4 (&e
);
747 match_or_operand (gfc_expr
**result
)
749 gfc_expr
*all
, *e
, *total
;
753 m
= match_and_operand (&all
);
759 if (!next_operator (INTRINSIC_AND
))
761 where
= gfc_current_locus
;
763 m
= match_and_operand (&e
);
765 gfc_error (expression_syntax
);
772 total
= gfc_and (all
, e
);
790 match_equiv_operand (gfc_expr
**result
)
792 gfc_expr
*all
, *e
, *total
;
796 m
= match_or_operand (&all
);
802 if (!next_operator (INTRINSIC_OR
))
804 where
= gfc_current_locus
;
806 m
= match_or_operand (&e
);
808 gfc_error (expression_syntax
);
815 total
= gfc_or (all
, e
);
832 /* Match a level 5 expression. */
835 match_level_5 (gfc_expr
**result
)
837 gfc_expr
*all
, *e
, *total
;
842 m
= match_equiv_operand (&all
);
848 if (next_operator (INTRINSIC_EQV
))
852 if (next_operator (INTRINSIC_NEQV
))
858 where
= gfc_current_locus
;
860 m
= match_equiv_operand (&e
);
862 gfc_error (expression_syntax
);
869 if (i
== INTRINSIC_EQV
)
870 total
= gfc_eqv (all
, e
);
872 total
= gfc_neqv (all
, e
);
890 /* Match an expression. At this level, we are stringing together
891 level 5 expressions separated by binary operators. */
894 gfc_match_expr (gfc_expr
**result
)
901 m
= match_level_5 (&all
);
908 m
= match_defined_operator (&uop
);
911 if (m
== MATCH_ERROR
)
917 where
= gfc_current_locus
;
919 m
= match_level_5 (&e
);
921 gfc_error (expression_syntax
);
928 all
= build_node (INTRINSIC_USER
, &where
, all
, e
);
929 all
->value
.op
.uop
= uop
;