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
)
134 e2
->expr_type
= EXPR_OP
;
137 e2
->where
= e
->where
;
138 e2
->value
.op
.op
= INTRINSIC_PARENTHESES
;
139 e2
->value
.op
.op1
= e
;
140 e2
->value
.op
.op2
= NULL
;
145 /* Match a primary expression. */
148 match_primary (gfc_expr
**result
)
154 m
= gfc_match_literal_constant (result
, 0);
158 m
= gfc_match_array_constructor (result
);
162 m
= gfc_match_rvalue (result
);
166 /* Match an expression in parentheses. */
167 where
= gfc_current_locus
;
169 if (gfc_match_char ('(') != MATCH_YES
)
172 m
= gfc_match_expr (&e
);
175 if (m
== MATCH_ERROR
)
178 m
= gfc_match_char (')');
180 gfc_error ("Expected a right parenthesis in expression at %C");
182 /* Now we have the expression inside the parentheses, build the
183 expression pointing to it. By 7.1.7.2, any expression in
184 parentheses shall be treated as a data entity. */
185 *result
= gfc_get_parentheses (e
);
189 gfc_free_expr (*result
);
196 gfc_error (expression_syntax
);
201 /* Build an operator expression node. */
204 build_node (gfc_intrinsic_op op
, locus
*where
,
205 gfc_expr
*op1
, gfc_expr
*op2
)
209 new_expr
= gfc_get_expr ();
210 new_expr
->expr_type
= EXPR_OP
;
211 new_expr
->value
.op
.op
= op
;
212 new_expr
->where
= *where
;
214 new_expr
->value
.op
.op1
= op1
;
215 new_expr
->value
.op
.op2
= op2
;
221 /* Match a level 1 expression. */
224 match_level_1 (gfc_expr
**result
)
231 where
= gfc_current_locus
;
233 m
= match_defined_operator (&uop
);
234 if (m
== MATCH_ERROR
)
237 m
= match_primary (&e
);
245 f
= build_node (INTRINSIC_USER
, &where
, e
, NULL
);
246 f
->value
.op
.uop
= uop
;
254 /* As a GNU extension we support an expanded level-2 expression syntax.
255 Via this extension we support (arbitrary) nesting of unary plus and
256 minus operations following unary and binary operators, such as **.
257 The grammar of section 7.1.1.3 is effectively rewritten as:
259 R704 mult-operand is level-1-expr [ power-op ext-mult-operand ]
260 R704' ext-mult-operand is add-op ext-mult-operand
262 R705 add-operand is add-operand mult-op ext-mult-operand
264 R705' ext-add-operand is add-op ext-add-operand
266 R706 level-2-expr is [ level-2-expr ] add-op ext-add-operand
270 static match
match_ext_mult_operand (gfc_expr
**result
);
271 static match
match_ext_add_operand (gfc_expr
**result
);
276 if (next_operator (INTRINSIC_MINUS
))
278 if (next_operator (INTRINSIC_PLUS
))
285 match_mult_operand (gfc_expr
**result
)
287 gfc_expr
*e
, *exp
, *r
;
291 m
= match_level_1 (&e
);
295 if (!next_operator (INTRINSIC_POWER
))
301 where
= gfc_current_locus
;
303 m
= match_ext_mult_operand (&exp
);
305 gfc_error ("Expected exponent in expression at %C");
312 r
= gfc_power (e
, exp
);
328 match_ext_mult_operand (gfc_expr
**result
)
335 where
= gfc_current_locus
;
339 return match_mult_operand (result
);
341 if (gfc_notification_std (GFC_STD_GNU
) == ERROR
)
343 gfc_error ("Extension: Unary operator following "
344 "arithmetic operator (use parentheses) at %C");
348 gfc_warning ("Extension: Unary operator following "
349 "arithmetic operator (use parentheses) at %C");
351 m
= match_ext_mult_operand (&e
);
356 all
= gfc_uminus (e
);
373 match_add_operand (gfc_expr
**result
)
375 gfc_expr
*all
, *e
, *total
;
376 locus where
, old_loc
;
380 m
= match_mult_operand (&all
);
386 /* Build up a string of products or quotients. */
388 old_loc
= gfc_current_locus
;
390 if (next_operator (INTRINSIC_TIMES
))
394 if (next_operator (INTRINSIC_DIVIDE
))
395 i
= INTRINSIC_DIVIDE
;
400 where
= gfc_current_locus
;
402 m
= match_ext_mult_operand (&e
);
405 gfc_current_locus
= old_loc
;
409 if (m
== MATCH_ERROR
)
415 if (i
== INTRINSIC_TIMES
)
416 total
= gfc_multiply (all
, e
);
418 total
= gfc_divide (all
, e
);
437 match_ext_add_operand (gfc_expr
**result
)
444 where
= gfc_current_locus
;
448 return match_add_operand (result
);
450 if (gfc_notification_std (GFC_STD_GNU
) == ERROR
)
452 gfc_error ("Extension: Unary operator following "
453 "arithmetic operator (use parentheses) at %C");
457 gfc_warning ("Extension: Unary operator following "
458 "arithmetic operator (use parentheses) at %C");
460 m
= match_ext_add_operand (&e
);
465 all
= gfc_uminus (e
);
481 /* Match a level 2 expression. */
484 match_level_2 (gfc_expr
**result
)
486 gfc_expr
*all
, *e
, *total
;
491 where
= gfc_current_locus
;
496 m
= match_ext_add_operand (&e
);
499 gfc_error (expression_syntax
);
504 m
= match_add_operand (&e
);
514 all
= gfc_uminus (e
);
527 /* Append add-operands to the sum. */
531 where
= gfc_current_locus
;
536 m
= match_ext_add_operand (&e
);
538 gfc_error (expression_syntax
);
546 total
= gfc_subtract (all
, e
);
548 total
= gfc_add (all
, e
);
566 /* Match a level three expression. */
569 match_level_3 (gfc_expr
**result
)
571 gfc_expr
*all
, *e
, *total
;
575 m
= match_level_2 (&all
);
581 if (!next_operator (INTRINSIC_CONCAT
))
584 where
= gfc_current_locus
;
586 m
= match_level_2 (&e
);
589 gfc_error (expression_syntax
);
595 total
= gfc_concat (all
, e
);
612 /* Match a level 4 expression. */
615 match_level_4 (gfc_expr
**result
)
617 gfc_expr
*left
, *right
, *r
;
623 m
= match_level_3 (&left
);
627 old_loc
= gfc_current_locus
;
629 if (gfc_match_intrinsic_op (&i
) != MATCH_YES
)
635 if (i
!= INTRINSIC_EQ
&& i
!= INTRINSIC_NE
&& i
!= INTRINSIC_GE
636 && i
!= INTRINSIC_LE
&& i
!= INTRINSIC_LT
&& i
!= INTRINSIC_GT
637 && i
!= INTRINSIC_EQ_OS
&& i
!= INTRINSIC_NE_OS
&& i
!= INTRINSIC_GE_OS
638 && i
!= INTRINSIC_LE_OS
&& i
!= INTRINSIC_LT_OS
&& i
!= INTRINSIC_GT_OS
)
640 gfc_current_locus
= old_loc
;
645 where
= gfc_current_locus
;
647 m
= match_level_3 (&right
);
649 gfc_error (expression_syntax
);
652 gfc_free_expr (left
);
659 case INTRINSIC_EQ_OS
:
660 r
= gfc_eq (left
, right
, i
);
664 case INTRINSIC_NE_OS
:
665 r
= gfc_ne (left
, right
, i
);
669 case INTRINSIC_LT_OS
:
670 r
= gfc_lt (left
, right
, i
);
674 case INTRINSIC_LE_OS
:
675 r
= gfc_le (left
, right
, i
);
679 case INTRINSIC_GT_OS
:
680 r
= gfc_gt (left
, right
, i
);
684 case INTRINSIC_GE_OS
:
685 r
= gfc_ge (left
, right
, i
);
689 gfc_internal_error ("match_level_4(): Bad operator");
694 gfc_free_expr (left
);
695 gfc_free_expr (right
);
707 match_and_operand (gfc_expr
**result
)
714 i
= next_operator (INTRINSIC_NOT
);
715 where
= gfc_current_locus
;
717 m
= match_level_4 (&e
);
740 match_or_operand (gfc_expr
**result
)
742 gfc_expr
*all
, *e
, *total
;
746 m
= match_and_operand (&all
);
752 if (!next_operator (INTRINSIC_AND
))
754 where
= gfc_current_locus
;
756 m
= match_and_operand (&e
);
758 gfc_error (expression_syntax
);
765 total
= gfc_and (all
, e
);
783 match_equiv_operand (gfc_expr
**result
)
785 gfc_expr
*all
, *e
, *total
;
789 m
= match_or_operand (&all
);
795 if (!next_operator (INTRINSIC_OR
))
797 where
= gfc_current_locus
;
799 m
= match_or_operand (&e
);
801 gfc_error (expression_syntax
);
808 total
= gfc_or (all
, e
);
825 /* Match a level 5 expression. */
828 match_level_5 (gfc_expr
**result
)
830 gfc_expr
*all
, *e
, *total
;
835 m
= match_equiv_operand (&all
);
841 if (next_operator (INTRINSIC_EQV
))
845 if (next_operator (INTRINSIC_NEQV
))
851 where
= gfc_current_locus
;
853 m
= match_equiv_operand (&e
);
855 gfc_error (expression_syntax
);
862 if (i
== INTRINSIC_EQV
)
863 total
= gfc_eqv (all
, e
);
865 total
= gfc_neqv (all
, e
);
883 /* Match an expression. At this level, we are stringing together
884 level 5 expressions separated by binary operators. */
887 gfc_match_expr (gfc_expr
**result
)
894 m
= match_level_5 (&all
);
901 m
= match_defined_operator (&uop
);
904 if (m
== MATCH_ERROR
)
910 where
= gfc_current_locus
;
912 m
= match_level_5 (&e
);
914 gfc_error (expression_syntax
);
921 all
= build_node (INTRINSIC_USER
, &where
, all
, e
);
922 all
->value
.op
.uop
= uop
;