Line data Source code
1 : /* Expression parser.
2 : Copyright (C) 2000-2026 Free Software Foundation, Inc.
3 : Contributed by Andy Vaught
4 :
5 : This file is part of GCC.
6 :
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
10 : version.
11 :
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
15 : for more details.
16 :
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/>. */
20 :
21 : #include "config.h"
22 : #include "system.h"
23 : #include "coretypes.h"
24 : #include "gfortran.h"
25 : #include "arith.h"
26 : #include "match.h"
27 :
28 : static const char expression_syntax[] = N_("Syntax error in expression at %C");
29 :
30 :
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. */
34 :
35 : match
36 11810668 : gfc_match_defined_op_name (char *result, int error_flag)
37 : {
38 11810668 : static const char * const badops[] = {
39 : "and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt",
40 : NULL
41 : };
42 :
43 11810668 : char name[GFC_MAX_SYMBOL_LEN + 1];
44 11810668 : locus old_loc;
45 11810668 : match m;
46 11810668 : int i;
47 :
48 11810668 : old_loc = gfc_current_locus;
49 :
50 11810668 : m = gfc_match (" . %n .", name);
51 11810668 : if (m != MATCH_YES)
52 : return m;
53 :
54 : /* .true. and .false. have interpretations as constants. Trying to
55 : use these as operators will fail at a later time. */
56 :
57 57602 : if (strcmp (name, "true") == 0 || strcmp (name, "false") == 0)
58 : {
59 56549 : if (error_flag)
60 0 : goto error;
61 56549 : gfc_current_locus = old_loc;
62 56549 : return MATCH_NO;
63 : }
64 :
65 12635 : for (i = 0; badops[i]; i++)
66 11583 : if (strcmp (badops[i], name) == 0)
67 1 : goto error;
68 :
69 5713 : for (i = 0; name[i]; i++)
70 4697 : if (!ISALPHA (name[i]))
71 : {
72 36 : gfc_error ("Bad character %qc in OPERATOR name at %C", name[i]);
73 36 : return MATCH_ERROR;
74 : }
75 :
76 1016 : strcpy (result, name);
77 1016 : return MATCH_YES;
78 :
79 1 : error:
80 1 : gfc_error ("The name %qs cannot be used as a defined operator at %C",
81 : name);
82 :
83 1 : gfc_current_locus = old_loc;
84 1 : return MATCH_ERROR;
85 : }
86 :
87 :
88 : /* Match a user defined operator. The symbol found must be an
89 : operator already. */
90 :
91 : static match
92 11809173 : match_defined_operator (gfc_user_op **result)
93 : {
94 11809173 : char name[GFC_MAX_SYMBOL_LEN + 1];
95 11809173 : match m;
96 :
97 11809173 : m = gfc_match_defined_op_name (name, 0);
98 11809173 : if (m != MATCH_YES)
99 : return m;
100 :
101 591 : *result = gfc_get_uop (name);
102 591 : return MATCH_YES;
103 : }
104 :
105 :
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. */
108 :
109 : static int
110 76239293 : next_operator (gfc_intrinsic_op t)
111 : {
112 76239293 : gfc_intrinsic_op u;
113 76239293 : locus old_loc;
114 :
115 76239293 : old_loc = gfc_current_locus;
116 76239293 : if (gfc_match_intrinsic_op (&u) == MATCH_YES && t == u)
117 : return 1;
118 :
119 75428066 : gfc_current_locus = old_loc;
120 75428066 : return 0;
121 : }
122 :
123 :
124 : /* Call the INTRINSIC_PARENTHESES function. This is both
125 : used explicitly, as below, or by resolve.cc to generate
126 : temporaries. */
127 :
128 : gfc_expr *
129 57889 : gfc_get_parentheses (gfc_expr *e)
130 : {
131 57889 : gfc_expr *e2;
132 :
133 57889 : e2 = gfc_get_operator_expr (&e->where, INTRINSIC_PARENTHESES, e, NULL);
134 57889 : e2->ts = e->ts;
135 57889 : e2->rank = e->rank;
136 57889 : e2->corank = e->corank;
137 :
138 57889 : return e2;
139 : }
140 :
141 : /* Match a conditional expression. */
142 :
143 : static match
144 58047 : match_conditional (gfc_expr **result)
145 : {
146 58047 : gfc_expr *condition, *true_expr, *false_expr;
147 58047 : locus where;
148 58047 : match m;
149 :
150 58047 : where = gfc_current_locus;
151 :
152 58047 : m = gfc_match_expr (&condition);
153 58047 : if (m != MATCH_YES)
154 : {
155 70 : gfc_error (expression_syntax);
156 70 : return MATCH_ERROR;
157 : }
158 :
159 57977 : m = gfc_match_char ('?');
160 57977 : if (m != MATCH_YES)
161 : {
162 57753 : *result = condition;
163 57753 : return MATCH_YES;
164 : }
165 224 : else if (!gfc_notify_std (GFC_STD_F2023, "Conditional expression at %L",
166 : &where))
167 : {
168 1 : gfc_free_expr (condition);
169 1 : return MATCH_ERROR;
170 : }
171 :
172 223 : gfc_gobble_whitespace ();
173 223 : m = gfc_match_expr (&true_expr);
174 223 : if (m != MATCH_YES)
175 : {
176 0 : gfc_free_expr (condition);
177 0 : return m;
178 : }
179 :
180 223 : m = gfc_match_char (':');
181 223 : if (m != MATCH_YES)
182 : {
183 1 : gfc_error ("Expected ':' in conditional expression at %C");
184 1 : gfc_free_expr (condition);
185 1 : gfc_free_expr (true_expr);
186 1 : return MATCH_ERROR;
187 : }
188 :
189 222 : m = match_conditional (&false_expr);
190 222 : if (m != MATCH_YES)
191 : {
192 0 : gfc_free_expr (condition);
193 0 : gfc_free_expr (true_expr);
194 0 : return m;
195 : }
196 :
197 222 : *result = gfc_get_conditional_expr (&where, condition, true_expr, false_expr);
198 222 : return MATCH_YES;
199 : }
200 :
201 : /* Match a primary expression. */
202 :
203 : static match
204 7033273 : match_primary (gfc_expr **result)
205 : {
206 7033273 : match m;
207 7033273 : gfc_expr *e;
208 :
209 7033273 : m = gfc_match_literal_constant (result, 0);
210 7033273 : if (m != MATCH_NO)
211 : return m;
212 :
213 4334352 : m = gfc_match_array_constructor (result);
214 4334352 : if (m != MATCH_NO)
215 : return m;
216 :
217 4202811 : m = gfc_match_rvalue (result);
218 4202811 : if (m != MATCH_NO)
219 : return m;
220 :
221 : /* Match an expression in parentheses. */
222 202837 : if (gfc_match_char ('(') != MATCH_YES)
223 : return MATCH_NO;
224 :
225 57825 : m = match_conditional (&e);
226 57825 : if (m != MATCH_YES)
227 : return m;
228 :
229 57753 : m = gfc_match_char (')');
230 57753 : if (m == MATCH_NO)
231 2438 : gfc_error ("Expected a right parenthesis in expression at %C");
232 :
233 : /* Now we have the expression inside the parentheses, build the expression
234 : pointing to it. By 7.1.7.2, any expression in parentheses shall be treated
235 : as a data entity.
236 : Note that if the expression is a conditional expression, we will omit the
237 : extra parentheses. */
238 57753 : *result = e->expr_type == EXPR_CONDITIONAL ? e : gfc_get_parentheses (e);
239 :
240 57753 : if (m != MATCH_YES)
241 : {
242 2438 : gfc_free_expr (*result);
243 2438 : return MATCH_ERROR;
244 : }
245 :
246 : return MATCH_YES;
247 : }
248 :
249 :
250 : /* Match a level 1 expression. */
251 :
252 : static match
253 7033273 : match_level_1 (gfc_expr **result)
254 : {
255 7033273 : gfc_user_op *uop;
256 7033273 : gfc_expr *e, *f;
257 7033273 : locus where;
258 7033273 : match m;
259 :
260 7033273 : gfc_gobble_whitespace ();
261 7033273 : where = gfc_current_locus;
262 7033273 : uop = NULL;
263 7033273 : m = match_defined_operator (&uop);
264 7033273 : if (m == MATCH_ERROR)
265 : return m;
266 :
267 7033273 : m = match_primary (&e);
268 7033273 : if (m != MATCH_YES)
269 : return m;
270 :
271 6257696 : if (uop == NULL)
272 6257464 : *result = e;
273 : else
274 : {
275 232 : f = gfc_get_operator_expr (&where, INTRINSIC_USER, e, NULL);
276 232 : f->value.op.uop = uop;
277 232 : *result = f;
278 : }
279 :
280 : return MATCH_YES;
281 : }
282 :
283 :
284 : /* As a GNU extension we support an expanded level-2 expression syntax.
285 : Via this extension we support (arbitrary) nesting of unary plus and
286 : minus operations following unary and binary operators, such as **.
287 : The grammar of section 7.1.1.3 is effectively rewritten as:
288 :
289 : R704 mult-operand is level-1-expr [ power-op ext-mult-operand ]
290 : R704' ext-mult-operand is add-op ext-mult-operand
291 : or mult-operand
292 : R705 add-operand is add-operand mult-op ext-mult-operand
293 : or mult-operand
294 : R705' ext-add-operand is add-op ext-add-operand
295 : or add-operand
296 : R706 level-2-expr is [ level-2-expr ] add-op ext-add-operand
297 : or add-operand
298 : */
299 :
300 : static match match_ext_mult_operand (gfc_expr **result);
301 : static match match_ext_add_operand (gfc_expr **result);
302 :
303 : static int
304 13279833 : match_add_op (void)
305 : {
306 13279833 : if (next_operator (INTRINSIC_MINUS))
307 : return -1;
308 13071948 : if (next_operator (INTRINSIC_PLUS))
309 69427 : return 1;
310 : return 0;
311 : }
312 :
313 :
314 : static match
315 7033273 : match_mult_operand (gfc_expr **result)
316 : {
317 : /* Workaround -Wmaybe-uninitialized false positive during
318 : profiledbootstrap by initializing them. */
319 7033273 : gfc_expr *e = NULL, *exp, *r;
320 7033273 : locus where;
321 7033273 : match m;
322 :
323 7033273 : m = match_level_1 (&e);
324 7033273 : if (m != MATCH_YES)
325 : return m;
326 :
327 6257696 : if (!next_operator (INTRINSIC_POWER))
328 : {
329 6189037 : *result = e;
330 6189037 : return MATCH_YES;
331 : }
332 :
333 68659 : where = gfc_current_locus;
334 :
335 68659 : m = match_ext_mult_operand (&exp);
336 68659 : if (m == MATCH_NO)
337 0 : gfc_error ("Expected exponent in expression at %C");
338 68659 : if (m != MATCH_YES)
339 : {
340 1 : gfc_free_expr (e);
341 1 : return MATCH_ERROR;
342 : }
343 :
344 68658 : r = gfc_power (e, exp);
345 68658 : if (r == NULL)
346 : {
347 0 : gfc_free_expr (e);
348 0 : gfc_free_expr (exp);
349 0 : return MATCH_ERROR;
350 : }
351 :
352 68658 : r->where = where;
353 68658 : *result = r;
354 :
355 68658 : return MATCH_YES;
356 : }
357 :
358 :
359 : static match
360 209128 : match_ext_mult_operand (gfc_expr **result)
361 : {
362 209128 : gfc_expr *all, *e;
363 209128 : locus where;
364 209128 : match m;
365 209128 : int i;
366 :
367 209128 : where = gfc_current_locus;
368 209128 : i = match_add_op ();
369 :
370 209128 : if (i == 0)
371 209115 : return match_mult_operand (result);
372 :
373 13 : if (gfc_notification_std (GFC_STD_GNU) == ERROR)
374 : {
375 0 : gfc_error ("Extension: Unary operator following "
376 : "arithmetic operator (use parentheses) at %C");
377 0 : return MATCH_ERROR;
378 : }
379 : else
380 13 : gfc_warning (0, "Extension: Unary operator following "
381 : "arithmetic operator (use parentheses) at %C");
382 :
383 13 : m = match_ext_mult_operand (&e);
384 13 : if (m != MATCH_YES)
385 : return m;
386 :
387 13 : if (i == -1)
388 7 : all = gfc_uminus (e);
389 : else
390 6 : all = gfc_uplus (e);
391 :
392 13 : if (all == NULL)
393 : {
394 0 : gfc_free_expr (e);
395 0 : return MATCH_ERROR;
396 : }
397 :
398 13 : all->where = where;
399 13 : *result = all;
400 13 : return MATCH_YES;
401 : }
402 :
403 :
404 : static match
405 6824158 : match_add_operand (gfc_expr **result)
406 : {
407 6824158 : gfc_expr *all, *e, *total;
408 6824158 : locus where, old_loc;
409 6824158 : match m;
410 6824158 : gfc_intrinsic_op i;
411 :
412 6824158 : m = match_mult_operand (&all);
413 6824158 : if (m != MATCH_YES)
414 : return m;
415 :
416 6270856 : for (;;)
417 : {
418 : /* Build up a string of products or quotients. */
419 :
420 6189029 : old_loc = gfc_current_locus;
421 :
422 6189029 : if (next_operator (INTRINSIC_TIMES))
423 : i = INTRINSIC_TIMES;
424 : else
425 : {
426 6120425 : if (next_operator (INTRINSIC_DIVIDE))
427 : i = INTRINSIC_DIVIDE;
428 : else
429 : break;
430 : }
431 :
432 140456 : where = gfc_current_locus;
433 :
434 140456 : m = match_ext_mult_operand (&e);
435 140456 : if (m == MATCH_NO)
436 : {
437 58621 : gfc_current_locus = old_loc;
438 58621 : break;
439 : }
440 :
441 81835 : if (m == MATCH_ERROR)
442 : {
443 0 : gfc_free_expr (all);
444 0 : return MATCH_ERROR;
445 : }
446 :
447 81835 : if (i == INTRINSIC_TIMES)
448 68604 : total = gfc_multiply (all, e);
449 : else
450 13231 : total = gfc_divide (all, e);
451 :
452 81835 : if (total == NULL)
453 : {
454 8 : gfc_free_expr (all);
455 8 : gfc_free_expr (e);
456 8 : return MATCH_ERROR;
457 : }
458 :
459 81827 : all = total;
460 81827 : all->where = where;
461 : }
462 :
463 6107194 : *result = all;
464 6107194 : return MATCH_YES;
465 : }
466 :
467 :
468 : static match
469 277299 : match_ext_add_operand (gfc_expr **result)
470 : {
471 277299 : gfc_expr *all, *e;
472 277299 : locus where;
473 277299 : match m;
474 277299 : int i;
475 :
476 277299 : where = gfc_current_locus;
477 277299 : i = match_add_op ();
478 :
479 277299 : if (i == 0)
480 277299 : return match_add_operand (result);
481 :
482 0 : if (gfc_notification_std (GFC_STD_GNU) == ERROR)
483 : {
484 0 : gfc_error ("Extension: Unary operator following "
485 : "arithmetic operator (use parentheses) at %C");
486 0 : return MATCH_ERROR;
487 : }
488 : else
489 0 : gfc_warning (0, "Extension: Unary operator following "
490 : "arithmetic operator (use parentheses) at %C");
491 :
492 0 : m = match_ext_add_operand (&e);
493 0 : if (m != MATCH_YES)
494 : return m;
495 :
496 0 : if (i == -1)
497 0 : all = gfc_uminus (e);
498 : else
499 0 : all = gfc_uplus (e);
500 :
501 0 : if (all == NULL)
502 : {
503 0 : gfc_free_expr (e);
504 0 : return MATCH_ERROR;
505 : }
506 :
507 0 : all->where = where;
508 0 : *result = all;
509 0 : return MATCH_YES;
510 : }
511 :
512 :
513 : /* Match a level 2 expression. */
514 :
515 : static match
516 6686213 : match_level_2 (gfc_expr **result)
517 : {
518 6686213 : gfc_expr *all, *e, *total;
519 6686213 : locus where;
520 6686213 : match m;
521 6686213 : int i;
522 :
523 6686213 : where = gfc_current_locus;
524 6686213 : i = match_add_op ();
525 :
526 6686213 : if (i != 0)
527 : {
528 139354 : m = match_ext_add_operand (&e);
529 139354 : if (m == MATCH_NO)
530 : {
531 8 : gfc_error (expression_syntax);
532 8 : m = MATCH_ERROR;
533 : }
534 : }
535 : else
536 6546859 : m = match_add_operand (&e);
537 :
538 6686213 : if (m != MATCH_YES)
539 716961 : return m;
540 :
541 5969252 : if (i == 0)
542 5829912 : all = e;
543 : else
544 : {
545 139340 : if (i == -1)
546 138970 : all = gfc_uminus (e);
547 : else
548 370 : all = gfc_uplus (e);
549 :
550 139340 : if (all == NULL)
551 : {
552 1 : gfc_free_expr (e);
553 1 : return MATCH_ERROR;
554 : }
555 : }
556 :
557 5969251 : all->where = where;
558 :
559 : /* Append add-operands to the sum. */
560 :
561 6245135 : for (;;)
562 : {
563 6107193 : where = gfc_current_locus;
564 6107193 : i = match_add_op ();
565 6107193 : if (i == 0)
566 : break;
567 :
568 137945 : m = match_ext_add_operand (&e);
569 137945 : if (m == MATCH_NO)
570 0 : gfc_error (expression_syntax);
571 137945 : if (m != MATCH_YES)
572 : {
573 3 : gfc_free_expr (all);
574 3 : return MATCH_ERROR;
575 : }
576 :
577 137942 : if (i == -1)
578 68894 : total = gfc_subtract (all, e);
579 : else
580 69048 : total = gfc_add (all, e);
581 :
582 137942 : if (total == NULL)
583 : {
584 0 : gfc_free_expr (all);
585 0 : gfc_free_expr (e);
586 0 : return MATCH_ERROR;
587 : }
588 :
589 137942 : all = total;
590 137942 : all->where = where;
591 : }
592 :
593 5969248 : *result = all;
594 5969248 : return MATCH_YES;
595 : }
596 :
597 :
598 : /* Match a level three expression. */
599 :
600 : static match
601 6680688 : match_level_3 (gfc_expr **result)
602 : {
603 6680688 : gfc_expr *all, *e, *total = NULL;
604 6680688 : locus where;
605 6680688 : match m;
606 :
607 6680688 : m = match_level_2 (&all);
608 6680688 : if (m != MATCH_YES)
609 : return m;
610 :
611 5974765 : for (;;)
612 : {
613 5969247 : if (!next_operator (INTRINSIC_CONCAT))
614 : break;
615 :
616 5525 : where = gfc_current_locus;
617 :
618 5525 : m = match_level_2 (&e);
619 5525 : if (m == MATCH_NO)
620 0 : gfc_error (expression_syntax);
621 5525 : if (m != MATCH_YES)
622 : {
623 6 : gfc_free_expr (all);
624 6 : return MATCH_ERROR;
625 : }
626 :
627 5519 : total = gfc_concat (all, e);
628 5519 : if (total == NULL)
629 : {
630 1 : gfc_free_expr (all);
631 1 : gfc_free_expr (e);
632 1 : return MATCH_ERROR;
633 : }
634 :
635 5518 : all = total;
636 5518 : all->where = where;
637 : }
638 :
639 5963722 : *result = all;
640 5963722 : return MATCH_YES;
641 : }
642 :
643 :
644 : /* Match a level 4 expression. */
645 :
646 : static match
647 5734594 : match_level_4 (gfc_expr **result)
648 : {
649 5734594 : gfc_expr *left, *right, *r;
650 5734594 : gfc_intrinsic_op i;
651 5734594 : locus old_loc;
652 5734594 : locus where;
653 5734594 : match m;
654 :
655 5734594 : m = match_level_3 (&left);
656 5734594 : if (m != MATCH_YES)
657 : return m;
658 :
659 5017628 : old_loc = gfc_current_locus;
660 :
661 5017628 : if (gfc_match_intrinsic_op (&i) != MATCH_YES)
662 : {
663 3949683 : *result = left;
664 3949683 : return MATCH_YES;
665 : }
666 :
667 1067945 : if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE
668 409132 : && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT
669 364802 : && i != INTRINSIC_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS
670 137545 : && i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS)
671 : {
672 121851 : gfc_current_locus = old_loc;
673 121851 : *result = left;
674 121851 : return MATCH_YES;
675 : }
676 :
677 946094 : where = gfc_current_locus;
678 :
679 946094 : m = match_level_3 (&right);
680 946094 : if (m == MATCH_NO)
681 0 : gfc_error (expression_syntax);
682 946094 : if (m != MATCH_YES)
683 : {
684 0 : gfc_free_expr (left);
685 0 : return MATCH_ERROR;
686 : }
687 :
688 946094 : switch (i)
689 : {
690 33565 : case INTRINSIC_EQ:
691 33565 : case INTRINSIC_EQ_OS:
692 33565 : r = gfc_eq (left, right, i);
693 33565 : break;
694 :
695 847811 : case INTRINSIC_NE:
696 847811 : case INTRINSIC_NE_OS:
697 847811 : r = gfc_ne (left, right, i);
698 847811 : break;
699 :
700 11189 : case INTRINSIC_LT:
701 11189 : case INTRINSIC_LT_OS:
702 11189 : r = gfc_lt (left, right, i);
703 11189 : break;
704 :
705 7395 : case INTRINSIC_LE:
706 7395 : case INTRINSIC_LE_OS:
707 7395 : r = gfc_le (left, right, i);
708 7395 : break;
709 :
710 41440 : case INTRINSIC_GT:
711 41440 : case INTRINSIC_GT_OS:
712 41440 : r = gfc_gt (left, right, i);
713 41440 : break;
714 :
715 4694 : case INTRINSIC_GE:
716 4694 : case INTRINSIC_GE_OS:
717 4694 : r = gfc_ge (left, right, i);
718 4694 : break;
719 :
720 0 : default:
721 0 : gfc_internal_error ("match_level_4(): Bad operator");
722 : }
723 :
724 946094 : if (r == NULL)
725 : {
726 0 : gfc_free_expr (left);
727 0 : gfc_free_expr (right);
728 0 : return MATCH_ERROR;
729 : }
730 :
731 946094 : r->where = where;
732 946094 : *result = r;
733 :
734 946094 : return MATCH_YES;
735 : }
736 :
737 :
738 : static match
739 5734594 : match_and_operand (gfc_expr **result)
740 : {
741 5734594 : gfc_expr *e, *r;
742 5734594 : locus where;
743 5734594 : match m;
744 5734594 : int i;
745 :
746 5734594 : i = next_operator (INTRINSIC_NOT);
747 5734594 : where = gfc_current_locus;
748 :
749 5734594 : m = match_level_4 (&e);
750 5734594 : if (m != MATCH_YES)
751 : return m;
752 :
753 5017628 : r = e;
754 5017628 : if (i)
755 : {
756 77547 : r = gfc_not (e);
757 77547 : if (r == NULL)
758 : {
759 0 : gfc_free_expr (e);
760 0 : return MATCH_ERROR;
761 : }
762 : }
763 :
764 5017628 : r->where = where;
765 5017628 : *result = r;
766 :
767 5017628 : return MATCH_YES;
768 : }
769 :
770 :
771 : static match
772 5717537 : match_or_operand (gfc_expr **result)
773 : {
774 5717537 : gfc_expr *all, *e, *total;
775 5717537 : locus where;
776 5717537 : match m;
777 :
778 5717537 : m = match_and_operand (&all);
779 5717537 : if (m != MATCH_YES)
780 : return m;
781 :
782 5034685 : for (;;)
783 : {
784 5017628 : if (!next_operator (INTRINSIC_AND))
785 : break;
786 17057 : where = gfc_current_locus;
787 :
788 17057 : m = match_and_operand (&e);
789 17057 : if (m == MATCH_NO)
790 0 : gfc_error (expression_syntax);
791 17057 : if (m != MATCH_YES)
792 : {
793 0 : gfc_free_expr (all);
794 0 : return MATCH_ERROR;
795 : }
796 :
797 17057 : total = gfc_and (all, e);
798 17057 : if (total == NULL)
799 : {
800 0 : gfc_free_expr (all);
801 0 : gfc_free_expr (e);
802 0 : return MATCH_ERROR;
803 : }
804 :
805 17057 : all = total;
806 17057 : all->where = where;
807 : }
808 :
809 5000571 : *result = all;
810 5000571 : return MATCH_YES;
811 : }
812 :
813 :
814 : static match
815 5517117 : match_equiv_operand (gfc_expr **result)
816 : {
817 5517117 : gfc_expr *all, *e, *total;
818 5517117 : locus where;
819 5517117 : match m;
820 :
821 5517117 : m = match_or_operand (&all);
822 5517117 : if (m != MATCH_YES)
823 : return m;
824 :
825 5200991 : for (;;)
826 : {
827 5000571 : if (!next_operator (INTRINSIC_OR))
828 : break;
829 200420 : where = gfc_current_locus;
830 :
831 200420 : m = match_or_operand (&e);
832 200420 : if (m == MATCH_NO)
833 0 : gfc_error (expression_syntax);
834 200420 : if (m != MATCH_YES)
835 : {
836 0 : gfc_free_expr (all);
837 0 : return MATCH_ERROR;
838 : }
839 :
840 200420 : total = gfc_or (all, e);
841 200420 : if (total == NULL)
842 : {
843 0 : gfc_free_expr (all);
844 0 : gfc_free_expr (e);
845 0 : return MATCH_ERROR;
846 : }
847 :
848 200420 : all = total;
849 200420 : all->where = where;
850 : }
851 :
852 4800151 : *result = all;
853 4800151 : return MATCH_YES;
854 : }
855 :
856 :
857 : /* Match a level 5 expression. */
858 :
859 : static match
860 5492866 : match_level_5 (gfc_expr **result)
861 : {
862 5492866 : gfc_expr *all, *e, *total;
863 5492866 : locus where;
864 5492866 : match m;
865 5492866 : gfc_intrinsic_op i;
866 :
867 5492866 : m = match_equiv_operand (&all);
868 5492866 : if (m != MATCH_YES)
869 : return m;
870 :
871 4824402 : for (;;)
872 : {
873 4800151 : if (next_operator (INTRINSIC_EQV))
874 : i = INTRINSIC_EQV;
875 : else
876 : {
877 4798171 : if (next_operator (INTRINSIC_NEQV))
878 : i = INTRINSIC_NEQV;
879 : else
880 : break;
881 : }
882 :
883 24251 : where = gfc_current_locus;
884 :
885 24251 : m = match_equiv_operand (&e);
886 24251 : if (m == MATCH_NO)
887 0 : gfc_error (expression_syntax);
888 24251 : if (m != MATCH_YES)
889 : {
890 0 : gfc_free_expr (all);
891 0 : return MATCH_ERROR;
892 : }
893 :
894 24251 : if (i == INTRINSIC_EQV)
895 1980 : total = gfc_eqv (all, e);
896 : else
897 22271 : total = gfc_neqv (all, e);
898 :
899 24251 : if (total == NULL)
900 : {
901 0 : gfc_free_expr (all);
902 0 : gfc_free_expr (e);
903 0 : return MATCH_ERROR;
904 : }
905 :
906 24251 : all = total;
907 24251 : all->where = where;
908 : }
909 :
910 4775900 : *result = all;
911 4775900 : return MATCH_YES;
912 : }
913 :
914 :
915 : /* Match an expression. At this level, we are stringing together
916 : level 5 expressions separated by binary operators. */
917 :
918 : match
919 5492508 : gfc_match_expr (gfc_expr **result)
920 : {
921 5492508 : gfc_expr *all, *e;
922 5492508 : gfc_user_op *uop;
923 5492508 : locus where;
924 5492508 : match m;
925 :
926 5492508 : m = match_level_5 (&all);
927 5492508 : if (m != MATCH_YES)
928 : return m;
929 :
930 4776258 : for (;;)
931 : {
932 4775900 : uop = NULL;
933 4775900 : m = match_defined_operator (&uop);
934 4775900 : if (m == MATCH_NO)
935 : break;
936 394 : if (m == MATCH_ERROR)
937 : {
938 36 : gfc_free_expr (all);
939 36 : return MATCH_ERROR;
940 : }
941 :
942 358 : where = gfc_current_locus;
943 :
944 358 : m = match_level_5 (&e);
945 358 : if (m == MATCH_NO)
946 0 : gfc_error (expression_syntax);
947 358 : if (m != MATCH_YES)
948 : {
949 0 : gfc_free_expr (all);
950 0 : return MATCH_ERROR;
951 : }
952 :
953 358 : all = gfc_get_operator_expr (&where, INTRINSIC_USER, all, e);
954 358 : all->value.op.uop = uop;
955 : }
956 :
957 4775506 : *result = all;
958 4775506 : return MATCH_YES;
959 : }
|
