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 12121356 : gfc_match_defined_op_name (char *result, int error_flag)
37 : {
38 12121356 : static const char * const badops[] = {
39 : "and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt",
40 : NULL
41 : };
42 :
43 12121356 : char name[GFC_MAX_SYMBOL_LEN + 1];
44 12121356 : locus old_loc;
45 12121356 : match m;
46 12121356 : int i;
47 :
48 12121356 : old_loc = gfc_current_locus;
49 :
50 12121356 : m = gfc_match (" . %n .", name);
51 12121356 : 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 58479 : if (strcmp (name, "true") == 0 || strcmp (name, "false") == 0)
58 : {
59 57376 : if (error_flag)
60 0 : goto error;
61 57376 : gfc_current_locus = old_loc;
62 57376 : return MATCH_NO;
63 : }
64 :
65 13225 : for (i = 0; badops[i]; i++)
66 12124 : if (strcmp (badops[i], name) == 0)
67 2 : goto error;
68 :
69 5915 : for (i = 0; name[i]; i++)
70 4850 : 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 1065 : strcpy (result, name);
77 1065 : return MATCH_YES;
78 :
79 2 : error:
80 2 : gfc_error ("The name %qs cannot be used as a defined operator at %C",
81 : name);
82 :
83 2 : gfc_current_locus = old_loc;
84 2 : 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 12119803 : match_defined_operator (gfc_user_op **result)
93 : {
94 12119803 : char name[GFC_MAX_SYMBOL_LEN + 1];
95 12119803 : match m;
96 :
97 12119803 : m = gfc_match_defined_op_name (name, 0);
98 12119803 : if (m != MATCH_YES)
99 : return m;
100 :
101 618 : *result = gfc_get_uop (name);
102 618 : 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 78205057 : next_operator (gfc_intrinsic_op t)
111 : {
112 78205057 : gfc_intrinsic_op u;
113 78205057 : locus old_loc;
114 :
115 78205057 : old_loc = gfc_current_locus;
116 78205057 : if (gfc_match_intrinsic_op (&u) == MATCH_YES && t == u)
117 : return 1;
118 :
119 77384003 : gfc_current_locus = old_loc;
120 77384003 : 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 58907 : gfc_get_parentheses (gfc_expr *e)
130 : {
131 58907 : gfc_expr *e2;
132 :
133 58907 : e2 = gfc_get_operator_expr (&e->where, INTRINSIC_PARENTHESES, e, NULL);
134 58907 : e2->ts = e->ts;
135 58907 : e2->rank = e->rank;
136 58907 : e2->corank = e->corank;
137 :
138 58907 : return e2;
139 : }
140 :
141 : /* Match a conditional expression. */
142 :
143 : static match
144 59076 : match_conditional (gfc_expr **result)
145 : {
146 59076 : gfc_expr *condition, *true_expr, *false_expr;
147 59076 : locus where;
148 59076 : match m;
149 :
150 59076 : where = gfc_current_locus;
151 :
152 59076 : m = gfc_match_expr (&condition);
153 59076 : if (m != MATCH_YES)
154 : {
155 77 : gfc_error (expression_syntax);
156 77 : return MATCH_ERROR;
157 : }
158 :
159 58999 : m = gfc_match_char ('?');
160 58999 : if (m != MATCH_YES)
161 : {
162 58755 : *result = condition;
163 58755 : return MATCH_YES;
164 : }
165 244 : 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 243 : gfc_gobble_whitespace ();
173 243 : m = gfc_match_expr (&true_expr);
174 243 : if (m != MATCH_YES)
175 : {
176 0 : gfc_free_expr (condition);
177 0 : return m;
178 : }
179 :
180 243 : m = gfc_match_char (':');
181 243 : 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 242 : m = match_conditional (&false_expr);
190 242 : 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 242 : *result = gfc_get_conditional_expr (&where, condition, true_expr, false_expr);
198 242 : return MATCH_YES;
199 : }
200 :
201 : /* Match a primary expression. */
202 :
203 : static match
204 7215339 : match_primary (gfc_expr **result)
205 : {
206 7215339 : match m;
207 7215339 : gfc_expr *e;
208 :
209 7215339 : m = gfc_match_literal_constant (result, 0);
210 7215339 : if (m != MATCH_NO)
211 : return m;
212 :
213 4446470 : m = gfc_match_array_constructor (result);
214 4446470 : if (m != MATCH_NO)
215 : return m;
216 :
217 4309775 : m = gfc_match_rvalue (result);
218 4309774 : if (m != MATCH_NO)
219 : return m;
220 :
221 : /* Match an expression in parentheses. */
222 205656 : if (gfc_match_char ('(') != MATCH_YES)
223 : return MATCH_NO;
224 :
225 58834 : m = match_conditional (&e);
226 58834 : if (m != MATCH_YES)
227 : return m;
228 :
229 58755 : m = gfc_match_char (')');
230 58755 : if (m == MATCH_NO)
231 2721 : 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 58755 : *result = e->expr_type == EXPR_CONDITIONAL ? e : gfc_get_parentheses (e);
239 :
240 58755 : if (m != MATCH_YES)
241 : {
242 2721 : gfc_free_expr (*result);
243 2721 : return MATCH_ERROR;
244 : }
245 :
246 : return MATCH_YES;
247 : }
248 :
249 :
250 : /* Match a level 1 expression. */
251 :
252 : static match
253 7215339 : match_level_1 (gfc_expr **result)
254 : {
255 7215339 : gfc_user_op *uop;
256 7215339 : gfc_expr *e, *f;
257 7215339 : locus where;
258 7215339 : match m;
259 :
260 7215339 : gfc_gobble_whitespace ();
261 7215339 : where = gfc_current_locus;
262 7215339 : uop = NULL;
263 7215339 : m = match_defined_operator (&uop);
264 7215339 : if (m == MATCH_ERROR)
265 : return m;
266 :
267 7215339 : m = match_primary (&e);
268 7215338 : if (m != MATCH_YES)
269 : return m;
270 :
271 6414338 : if (uop == NULL)
272 6414082 : *result = e;
273 : else
274 : {
275 256 : f = gfc_get_operator_expr (&where, INTRINSIC_USER, e, NULL);
276 256 : f->value.op.uop = uop;
277 256 : *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 13617963 : match_add_op (void)
305 : {
306 13617963 : if (next_operator (INTRINSIC_MINUS))
307 : return -1;
308 13406962 : if (next_operator (INTRINSIC_PLUS))
309 70884 : return 1;
310 : return 0;
311 : }
312 :
313 :
314 : static match
315 7215339 : match_mult_operand (gfc_expr **result)
316 : {
317 : /* Workaround -Wmaybe-uninitialized false positive during
318 : profiledbootstrap by initializing them. */
319 7215339 : gfc_expr *e = NULL, *exp, *r;
320 7215339 : locus where;
321 7215339 : match m;
322 :
323 7215339 : m = match_level_1 (&e);
324 7215338 : if (m != MATCH_YES)
325 : return m;
326 :
327 6414338 : if (!next_operator (INTRINSIC_POWER))
328 : {
329 6345625 : *result = e;
330 6345625 : return MATCH_YES;
331 : }
332 :
333 68713 : where = gfc_current_locus;
334 :
335 68713 : m = match_ext_mult_operand (&exp);
336 68713 : if (m == MATCH_NO)
337 0 : gfc_error ("Expected exponent in expression at %C");
338 68713 : if (m != MATCH_YES)
339 : {
340 1 : gfc_free_expr (e);
341 1 : return MATCH_ERROR;
342 : }
343 :
344 68712 : r = gfc_power (e, exp);
345 68712 : if (r == NULL)
346 : {
347 0 : gfc_free_expr (e);
348 0 : gfc_free_expr (exp);
349 0 : return MATCH_ERROR;
350 : }
351 :
352 68712 : r->where = where;
353 68712 : *result = r;
354 :
355 68712 : return MATCH_YES;
356 : }
357 :
358 :
359 : static match
360 211671 : match_ext_mult_operand (gfc_expr **result)
361 : {
362 211671 : gfc_expr *all, *e;
363 211671 : locus where;
364 211671 : match m;
365 211671 : int i;
366 :
367 211671 : where = gfc_current_locus;
368 211671 : i = match_add_op ();
369 :
370 211671 : if (i == 0)
371 211658 : 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 7003681 : match_add_operand (gfc_expr **result)
406 : {
407 7003681 : gfc_expr *all, *e, *total;
408 7003681 : locus where, old_loc;
409 7003681 : match m;
410 7003681 : gfc_intrinsic_op i;
411 :
412 7003681 : m = match_mult_operand (&all);
413 7003680 : if (m != MATCH_YES)
414 : return m;
415 :
416 6429905 : for (;;)
417 : {
418 : /* Build up a string of products or quotients. */
419 :
420 6345617 : old_loc = gfc_current_locus;
421 :
422 6345617 : if (next_operator (INTRINSIC_TIMES))
423 : i = INTRINSIC_TIMES;
424 : else
425 : {
426 6274916 : if (next_operator (INTRINSIC_DIVIDE))
427 : i = INTRINSIC_DIVIDE;
428 : else
429 : break;
430 : }
431 :
432 142945 : where = gfc_current_locus;
433 :
434 142945 : m = match_ext_mult_operand (&e);
435 142945 : if (m == MATCH_NO)
436 : {
437 58649 : gfc_current_locus = old_loc;
438 58649 : break;
439 : }
440 :
441 84296 : if (m == MATCH_ERROR)
442 : {
443 0 : gfc_free_expr (all);
444 0 : return MATCH_ERROR;
445 : }
446 :
447 84296 : if (i == INTRINSIC_TIMES)
448 70701 : total = gfc_multiply (all, e);
449 : else
450 13595 : total = gfc_divide (all, e);
451 :
452 84296 : if (total == NULL)
453 : {
454 8 : gfc_free_expr (all);
455 8 : gfc_free_expr (e);
456 8 : return MATCH_ERROR;
457 : }
458 :
459 84288 : all = total;
460 84288 : all->where = where;
461 : }
462 :
463 6261321 : *result = all;
464 6261321 : return MATCH_YES;
465 : }
466 :
467 :
468 : static match
469 281872 : match_ext_add_operand (gfc_expr **result)
470 : {
471 281872 : gfc_expr *all, *e;
472 281872 : locus where;
473 281872 : match m;
474 281872 : int i;
475 :
476 281872 : where = gfc_current_locus;
477 281872 : i = match_add_op ();
478 :
479 281872 : if (i == 0)
480 281872 : 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 6863100 : match_level_2 (gfc_expr **result)
517 : {
518 6863100 : gfc_expr *all, *e, *total;
519 6863100 : locus where;
520 6863100 : match m;
521 6863100 : int i;
522 :
523 6863100 : where = gfc_current_locus;
524 6863100 : i = match_add_op ();
525 :
526 6863100 : if (i != 0)
527 : {
528 141291 : m = match_ext_add_operand (&e);
529 141291 : if (m == MATCH_NO)
530 : {
531 8 : gfc_error (expression_syntax);
532 8 : m = MATCH_ERROR;
533 : }
534 : }
535 : else
536 6721809 : m = match_add_operand (&e);
537 :
538 6863099 : if (m != MATCH_YES)
539 : return m;
540 :
541 6120743 : if (i == 0)
542 5979466 : all = e;
543 : else
544 : {
545 141277 : if (i == -1)
546 140907 : all = gfc_uminus (e);
547 : else
548 370 : all = gfc_uplus (e);
549 :
550 141277 : if (all == NULL)
551 : {
552 1 : gfc_free_expr (e);
553 1 : return MATCH_ERROR;
554 : }
555 : }
556 :
557 6120742 : all->where = where;
558 :
559 : /* Append add-operands to the sum. */
560 :
561 6401898 : for (;;)
562 : {
563 6261320 : where = gfc_current_locus;
564 6261320 : i = match_add_op ();
565 6261320 : if (i == 0)
566 : break;
567 :
568 140581 : m = match_ext_add_operand (&e);
569 140581 : if (m == MATCH_NO)
570 0 : gfc_error (expression_syntax);
571 140581 : if (m != MATCH_YES)
572 : {
573 3 : gfc_free_expr (all);
574 3 : return MATCH_ERROR;
575 : }
576 :
577 140578 : if (i == -1)
578 70073 : total = gfc_subtract (all, e);
579 : else
580 70505 : total = gfc_add (all, e);
581 :
582 140578 : if (total == NULL)
583 : {
584 0 : gfc_free_expr (all);
585 0 : gfc_free_expr (e);
586 0 : return MATCH_ERROR;
587 : }
588 :
589 140578 : all = total;
590 140578 : all->where = where;
591 : }
592 :
593 6120739 : *result = all;
594 6120739 : return MATCH_YES;
595 : }
596 :
597 :
598 : /* Match a level three expression. */
599 :
600 : static match
601 6857518 : match_level_3 (gfc_expr **result)
602 : {
603 6857518 : gfc_expr *all, *e, *total = NULL;
604 6857518 : locus where;
605 6857518 : match m;
606 :
607 6857518 : m = match_level_2 (&all);
608 6857517 : if (m != MATCH_YES)
609 : return m;
610 :
611 6126313 : for (;;)
612 : {
613 6120738 : if (!next_operator (INTRINSIC_CONCAT))
614 : break;
615 :
616 5582 : where = gfc_current_locus;
617 :
618 5582 : m = match_level_2 (&e);
619 5582 : if (m == MATCH_NO)
620 0 : gfc_error (expression_syntax);
621 5582 : if (m != MATCH_YES)
622 : {
623 6 : gfc_free_expr (all);
624 6 : return MATCH_ERROR;
625 : }
626 :
627 5576 : total = gfc_concat (all, e);
628 5576 : if (total == NULL)
629 : {
630 1 : gfc_free_expr (all);
631 1 : gfc_free_expr (e);
632 1 : return MATCH_ERROR;
633 : }
634 :
635 5575 : all = total;
636 5575 : all->where = where;
637 : }
638 :
639 6115156 : *result = all;
640 6115156 : return MATCH_YES;
641 : }
642 :
643 :
644 : /* Match a level 4 expression. */
645 :
646 : static match
647 5890312 : match_level_4 (gfc_expr **result)
648 : {
649 5890312 : gfc_expr *left, *right, *r;
650 5890312 : gfc_intrinsic_op i;
651 5890312 : locus old_loc;
652 5890312 : locus where;
653 5890312 : match m;
654 :
655 5890312 : m = match_level_3 (&left);
656 5890311 : if (m != MATCH_YES)
657 : return m;
658 :
659 5147950 : old_loc = gfc_current_locus;
660 :
661 5147950 : if (gfc_match_intrinsic_op (&i) != MATCH_YES)
662 : {
663 4058203 : *result = left;
664 4058203 : return MATCH_YES;
665 : }
666 :
667 1089747 : if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE
668 413987 : && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT
669 368124 : && i != INTRINSIC_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS
670 138295 : && i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS)
671 : {
672 122541 : gfc_current_locus = old_loc;
673 122541 : *result = left;
674 122541 : return MATCH_YES;
675 : }
676 :
677 967206 : where = gfc_current_locus;
678 :
679 967206 : m = match_level_3 (&right);
680 967206 : if (m == MATCH_NO)
681 0 : gfc_error (expression_syntax);
682 967206 : if (m != MATCH_YES)
683 : {
684 0 : gfc_free_expr (left);
685 0 : return MATCH_ERROR;
686 : }
687 :
688 967206 : switch (i)
689 : {
690 33994 : case INTRINSIC_EQ:
691 33994 : case INTRINSIC_EQ_OS:
692 33994 : r = gfc_eq (left, right, i);
693 33994 : break;
694 :
695 866849 : case INTRINSIC_NE:
696 866849 : case INTRINSIC_NE_OS:
697 866849 : r = gfc_ne (left, right, i);
698 866849 : break;
699 :
700 11592 : case INTRINSIC_LT:
701 11592 : case INTRINSIC_LT_OS:
702 11592 : r = gfc_lt (left, right, i);
703 11592 : break;
704 :
705 7463 : case INTRINSIC_LE:
706 7463 : case INTRINSIC_LE_OS:
707 7463 : r = gfc_le (left, right, i);
708 7463 : break;
709 :
710 42562 : case INTRINSIC_GT:
711 42562 : case INTRINSIC_GT_OS:
712 42562 : r = gfc_gt (left, right, i);
713 42562 : break;
714 :
715 4746 : case INTRINSIC_GE:
716 4746 : case INTRINSIC_GE_OS:
717 4746 : r = gfc_ge (left, right, i);
718 4746 : break;
719 :
720 0 : default:
721 0 : gfc_internal_error ("match_level_4(): Bad operator");
722 : }
723 :
724 967206 : if (r == NULL)
725 : {
726 0 : gfc_free_expr (left);
727 0 : gfc_free_expr (right);
728 0 : return MATCH_ERROR;
729 : }
730 :
731 967206 : r->where = where;
732 967206 : *result = r;
733 :
734 967206 : return MATCH_YES;
735 : }
736 :
737 :
738 : static match
739 5890312 : match_and_operand (gfc_expr **result)
740 : {
741 5890312 : gfc_expr *e, *r;
742 5890312 : locus where;
743 5890312 : match m;
744 5890312 : int i;
745 :
746 5890312 : i = next_operator (INTRINSIC_NOT);
747 5890312 : where = gfc_current_locus;
748 :
749 5890312 : m = match_level_4 (&e);
750 5890311 : if (m != MATCH_YES)
751 : return m;
752 :
753 5147950 : r = e;
754 5147950 : if (i)
755 : {
756 78443 : r = gfc_not (e);
757 78443 : if (r == NULL)
758 : {
759 0 : gfc_free_expr (e);
760 0 : return MATCH_ERROR;
761 : }
762 : }
763 :
764 5147950 : r->where = where;
765 5147950 : *result = r;
766 :
767 5147950 : return MATCH_YES;
768 : }
769 :
770 :
771 : static match
772 5872853 : match_or_operand (gfc_expr **result)
773 : {
774 5872853 : gfc_expr *all, *e, *total;
775 5872853 : locus where;
776 5872853 : match m;
777 :
778 5872853 : m = match_and_operand (&all);
779 5872852 : if (m != MATCH_YES)
780 : return m;
781 :
782 5165409 : for (;;)
783 : {
784 5147950 : if (!next_operator (INTRINSIC_AND))
785 : break;
786 17459 : where = gfc_current_locus;
787 :
788 17459 : m = match_and_operand (&e);
789 17459 : if (m == MATCH_NO)
790 0 : gfc_error (expression_syntax);
791 17459 : if (m != MATCH_YES)
792 : {
793 0 : gfc_free_expr (all);
794 0 : return MATCH_ERROR;
795 : }
796 :
797 17459 : total = gfc_and (all, e);
798 17459 : if (total == NULL)
799 : {
800 0 : gfc_free_expr (all);
801 0 : gfc_free_expr (e);
802 0 : return MATCH_ERROR;
803 : }
804 :
805 17459 : all = total;
806 17459 : all->where = where;
807 : }
808 :
809 5130491 : *result = all;
810 5130491 : return MATCH_YES;
811 : }
812 :
813 :
814 : static match
815 5671237 : match_equiv_operand (gfc_expr **result)
816 : {
817 5671237 : gfc_expr *all, *e, *total;
818 5671237 : locus where;
819 5671237 : match m;
820 :
821 5671237 : m = match_or_operand (&all);
822 5671236 : if (m != MATCH_YES)
823 : return m;
824 :
825 5332107 : for (;;)
826 : {
827 5130491 : if (!next_operator (INTRINSIC_OR))
828 : break;
829 201616 : where = gfc_current_locus;
830 :
831 201616 : m = match_or_operand (&e);
832 201616 : if (m == MATCH_NO)
833 0 : gfc_error (expression_syntax);
834 201616 : if (m != MATCH_YES)
835 : {
836 0 : gfc_free_expr (all);
837 0 : return MATCH_ERROR;
838 : }
839 :
840 201616 : total = gfc_or (all, e);
841 201616 : if (total == NULL)
842 : {
843 0 : gfc_free_expr (all);
844 0 : gfc_free_expr (e);
845 0 : return MATCH_ERROR;
846 : }
847 :
848 201616 : all = total;
849 201616 : all->where = where;
850 : }
851 :
852 4928875 : *result = all;
853 4928875 : return MATCH_YES;
854 : }
855 :
856 :
857 : /* Match a level 5 expression. */
858 :
859 : static match
860 5646826 : match_level_5 (gfc_expr **result)
861 : {
862 5646826 : gfc_expr *all, *e, *total;
863 5646826 : locus where;
864 5646826 : match m;
865 5646826 : gfc_intrinsic_op i;
866 :
867 5646826 : m = match_equiv_operand (&all);
868 5646825 : if (m != MATCH_YES)
869 : return m;
870 :
871 4953286 : for (;;)
872 : {
873 4928875 : if (next_operator (INTRINSIC_EQV))
874 : i = INTRINSIC_EQV;
875 : else
876 : {
877 4926895 : if (next_operator (INTRINSIC_NEQV))
878 : i = INTRINSIC_NEQV;
879 : else
880 : break;
881 : }
882 :
883 24411 : where = gfc_current_locus;
884 :
885 24411 : m = match_equiv_operand (&e);
886 24411 : if (m == MATCH_NO)
887 0 : gfc_error (expression_syntax);
888 24411 : if (m != MATCH_YES)
889 : {
890 0 : gfc_free_expr (all);
891 0 : return MATCH_ERROR;
892 : }
893 :
894 24411 : if (i == INTRINSIC_EQV)
895 1980 : total = gfc_eqv (all, e);
896 : else
897 22431 : total = gfc_neqv (all, e);
898 :
899 24411 : if (total == NULL)
900 : {
901 0 : gfc_free_expr (all);
902 0 : gfc_free_expr (e);
903 0 : return MATCH_ERROR;
904 : }
905 :
906 24411 : all = total;
907 24411 : all->where = where;
908 : }
909 :
910 4904464 : *result = all;
911 4904464 : 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 5646465 : gfc_match_expr (gfc_expr **result)
920 : {
921 5646465 : gfc_expr *all, *e;
922 5646465 : gfc_user_op *uop;
923 5646465 : locus where;
924 5646465 : match m;
925 :
926 5646465 : m = match_level_5 (&all);
927 5646464 : if (m != MATCH_YES)
928 : return m;
929 :
930 4904825 : for (;;)
931 : {
932 4904464 : uop = NULL;
933 4904464 : m = match_defined_operator (&uop);
934 4904464 : if (m == MATCH_NO)
935 : break;
936 397 : if (m == MATCH_ERROR)
937 : {
938 36 : gfc_free_expr (all);
939 36 : return MATCH_ERROR;
940 : }
941 :
942 361 : where = gfc_current_locus;
943 :
944 361 : m = match_level_5 (&e);
945 361 : if (m == MATCH_NO)
946 0 : gfc_error (expression_syntax);
947 361 : if (m != MATCH_YES)
948 : {
949 0 : gfc_free_expr (all);
950 0 : return MATCH_ERROR;
951 : }
952 :
953 361 : all = gfc_get_operator_expr (&where, INTRINSIC_USER, all, e);
954 361 : all->value.op.uop = uop;
955 : }
956 :
957 4904067 : *result = all;
958 4904067 : return MATCH_YES;
959 : }
|
