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 11922953 : gfc_match_defined_op_name (char *result, int error_flag)
37 : {
38 11922953 : static const char * const badops[] = {
39 : "and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt",
40 : NULL
41 : };
42 :
43 11922953 : char name[GFC_MAX_SYMBOL_LEN + 1];
44 11922953 : locus old_loc;
45 11922953 : match m;
46 11922953 : int i;
47 :
48 11922953 : old_loc = gfc_current_locus;
49 :
50 11922953 : m = gfc_match (" . %n .", name);
51 11922953 : 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 57705 : if (strcmp (name, "true") == 0 || strcmp (name, "false") == 0)
58 : {
59 56652 : if (error_flag)
60 0 : goto error;
61 56652 : gfc_current_locus = old_loc;
62 56652 : 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 11921458 : match_defined_operator (gfc_user_op **result)
93 : {
94 11921458 : char name[GFC_MAX_SYMBOL_LEN + 1];
95 11921458 : match m;
96 :
97 11921458 : m = gfc_match_defined_op_name (name, 0);
98 11921458 : 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 76958232 : next_operator (gfc_intrinsic_op t)
111 : {
112 76958232 : gfc_intrinsic_op u;
113 76958232 : locus old_loc;
114 :
115 76958232 : old_loc = gfc_current_locus;
116 76958232 : if (gfc_match_intrinsic_op (&u) == MATCH_YES && t == u)
117 : return 1;
118 :
119 76143321 : gfc_current_locus = old_loc;
120 76143321 : 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 58298 : gfc_get_parentheses (gfc_expr *e)
130 : {
131 58298 : gfc_expr *e2;
132 :
133 58298 : e2 = gfc_get_operator_expr (&e->where, INTRINSIC_PARENTHESES, e, NULL);
134 58298 : e2->ts = e->ts;
135 58298 : e2->rank = e->rank;
136 58298 : e2->corank = e->corank;
137 :
138 58298 : return e2;
139 : }
140 :
141 : /* Match a conditional expression. */
142 :
143 : static match
144 58444 : match_conditional (gfc_expr **result)
145 : {
146 58444 : gfc_expr *condition, *true_expr, *false_expr;
147 58444 : locus where;
148 58444 : match m;
149 :
150 58444 : where = gfc_current_locus;
151 :
152 58444 : m = gfc_match_expr (&condition);
153 58444 : if (m != MATCH_YES)
154 : {
155 70 : gfc_error (expression_syntax);
156 70 : return MATCH_ERROR;
157 : }
158 :
159 58374 : m = gfc_match_char ('?');
160 58374 : if (m != MATCH_YES)
161 : {
162 58138 : *result = condition;
163 58138 : return MATCH_YES;
164 : }
165 236 : 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 235 : gfc_gobble_whitespace ();
173 235 : m = gfc_match_expr (&true_expr);
174 235 : if (m != MATCH_YES)
175 : {
176 0 : gfc_free_expr (condition);
177 0 : return m;
178 : }
179 :
180 235 : m = gfc_match_char (':');
181 235 : 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 234 : m = match_conditional (&false_expr);
190 234 : 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 234 : *result = gfc_get_conditional_expr (&where, condition, true_expr, false_expr);
198 234 : return MATCH_YES;
199 : }
200 :
201 : /* Match a primary expression. */
202 :
203 : static match
204 7097656 : match_primary (gfc_expr **result)
205 : {
206 7097656 : match m;
207 7097656 : gfc_expr *e;
208 :
209 7097656 : m = gfc_match_literal_constant (result, 0);
210 7097656 : if (m != MATCH_NO)
211 : return m;
212 :
213 4371905 : m = gfc_match_array_constructor (result);
214 4371905 : if (m != MATCH_NO)
215 : return m;
216 :
217 4238624 : m = gfc_match_rvalue (result);
218 4238624 : if (m != MATCH_NO)
219 : return m;
220 :
221 : /* Match an expression in parentheses. */
222 203565 : if (gfc_match_char ('(') != MATCH_YES)
223 : return MATCH_NO;
224 :
225 58210 : m = match_conditional (&e);
226 58210 : if (m != MATCH_YES)
227 : return m;
228 :
229 58138 : m = gfc_match_char (')');
230 58138 : 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 58138 : *result = e->expr_type == EXPR_CONDITIONAL ? e : gfc_get_parentheses (e);
239 :
240 58138 : 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 7097656 : match_level_1 (gfc_expr **result)
254 : {
255 7097656 : gfc_user_op *uop;
256 7097656 : gfc_expr *e, *f;
257 7097656 : locus where;
258 7097656 : match m;
259 :
260 7097656 : gfc_gobble_whitespace ();
261 7097656 : where = gfc_current_locus;
262 7097656 : uop = NULL;
263 7097656 : m = match_defined_operator (&uop);
264 7097656 : if (m == MATCH_ERROR)
265 : return m;
266 :
267 7097656 : m = match_primary (&e);
268 7097656 : if (m != MATCH_YES)
269 : return m;
270 :
271 6315561 : if (uop == NULL)
272 6315329 : *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 13401402 : match_add_op (void)
305 : {
306 13401402 : if (next_operator (INTRINSIC_MINUS))
307 : return -1;
308 13192616 : if (next_operator (INTRINSIC_PLUS))
309 69749 : return 1;
310 : return 0;
311 : }
312 :
313 :
314 : static match
315 7097656 : match_mult_operand (gfc_expr **result)
316 : {
317 : /* Workaround -Wmaybe-uninitialized false positive during
318 : profiledbootstrap by initializing them. */
319 7097656 : gfc_expr *e = NULL, *exp, *r;
320 7097656 : locus where;
321 7097656 : match m;
322 :
323 7097656 : m = match_level_1 (&e);
324 7097656 : if (m != MATCH_YES)
325 : return m;
326 :
327 6315561 : if (!next_operator (INTRINSIC_POWER))
328 : {
329 6246902 : *result = e;
330 6246902 : 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 210348 : match_ext_mult_operand (gfc_expr **result)
361 : {
362 210348 : gfc_expr *all, *e;
363 210348 : locus where;
364 210348 : match m;
365 210348 : int i;
366 :
367 210348 : where = gfc_current_locus;
368 210348 : i = match_add_op ();
369 :
370 210348 : if (i == 0)
371 210335 : 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 6887321 : match_add_operand (gfc_expr **result)
406 : {
407 6887321 : gfc_expr *all, *e, *total;
408 6887321 : locus where, old_loc;
409 6887321 : match m;
410 6887321 : gfc_intrinsic_op i;
411 :
412 6887321 : m = match_mult_operand (&all);
413 6887321 : if (m != MATCH_YES)
414 : return m;
415 :
416 6329937 : for (;;)
417 : {
418 : /* Build up a string of products or quotients. */
419 :
420 6246894 : old_loc = gfc_current_locus;
421 :
422 6246894 : if (next_operator (INTRINSIC_TIMES))
423 : i = INTRINSIC_TIMES;
424 : else
425 : {
426 6177338 : if (next_operator (INTRINSIC_DIVIDE))
427 : i = INTRINSIC_DIVIDE;
428 : else
429 : break;
430 : }
431 :
432 141676 : where = gfc_current_locus;
433 :
434 141676 : m = match_ext_mult_operand (&e);
435 141676 : if (m == MATCH_NO)
436 : {
437 58625 : gfc_current_locus = old_loc;
438 58625 : break;
439 : }
440 :
441 83051 : if (m == MATCH_ERROR)
442 : {
443 0 : gfc_free_expr (all);
444 0 : return MATCH_ERROR;
445 : }
446 :
447 83051 : if (i == INTRINSIC_TIMES)
448 69556 : total = gfc_multiply (all, e);
449 : else
450 13495 : total = gfc_divide (all, e);
451 :
452 83051 : if (total == NULL)
453 : {
454 8 : gfc_free_expr (all);
455 8 : gfc_free_expr (e);
456 8 : return MATCH_ERROR;
457 : }
458 :
459 83043 : all = total;
460 83043 : all->where = where;
461 : }
462 :
463 6163843 : *result = all;
464 6163843 : return MATCH_YES;
465 : }
466 :
467 :
468 : static match
469 278522 : match_ext_add_operand (gfc_expr **result)
470 : {
471 278522 : gfc_expr *all, *e;
472 278522 : locus where;
473 278522 : match m;
474 278522 : int i;
475 :
476 278522 : where = gfc_current_locus;
477 278522 : i = match_add_op ();
478 :
479 278522 : if (i == 0)
480 278522 : 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 6748690 : match_level_2 (gfc_expr **result)
517 : {
518 6748690 : gfc_expr *all, *e, *total;
519 6748690 : locus where;
520 6748690 : match m;
521 6748690 : int i;
522 :
523 6748690 : where = gfc_current_locus;
524 6748690 : i = match_add_op ();
525 :
526 6748690 : if (i != 0)
527 : {
528 139891 : m = match_ext_add_operand (&e);
529 139891 : if (m == MATCH_NO)
530 : {
531 8 : gfc_error (expression_syntax);
532 8 : m = MATCH_ERROR;
533 : }
534 : }
535 : else
536 6608799 : m = match_add_operand (&e);
537 :
538 6748690 : if (m != MATCH_YES)
539 723475 : return m;
540 :
541 6025215 : if (i == 0)
542 5885338 : all = e;
543 : else
544 : {
545 139877 : if (i == -1)
546 139507 : all = gfc_uminus (e);
547 : else
548 370 : all = gfc_uplus (e);
549 :
550 139877 : if (all == NULL)
551 : {
552 1 : gfc_free_expr (e);
553 1 : return MATCH_ERROR;
554 : }
555 : }
556 :
557 6025214 : all->where = where;
558 :
559 : /* Append add-operands to the sum. */
560 :
561 6302470 : for (;;)
562 : {
563 6163842 : where = gfc_current_locus;
564 6163842 : i = match_add_op ();
565 6163842 : if (i == 0)
566 : break;
567 :
568 138631 : m = match_ext_add_operand (&e);
569 138631 : if (m == MATCH_NO)
570 0 : gfc_error (expression_syntax);
571 138631 : if (m != MATCH_YES)
572 : {
573 3 : gfc_free_expr (all);
574 3 : return MATCH_ERROR;
575 : }
576 :
577 138628 : if (i == -1)
578 69258 : total = gfc_subtract (all, e);
579 : else
580 69370 : total = gfc_add (all, e);
581 :
582 138628 : if (total == NULL)
583 : {
584 0 : gfc_free_expr (all);
585 0 : gfc_free_expr (e);
586 0 : return MATCH_ERROR;
587 : }
588 :
589 138628 : all = total;
590 138628 : all->where = where;
591 : }
592 :
593 6025211 : *result = all;
594 6025211 : return MATCH_YES;
595 : }
596 :
597 :
598 : /* Match a level three expression. */
599 :
600 : static match
601 6743162 : match_level_3 (gfc_expr **result)
602 : {
603 6743162 : gfc_expr *all, *e, *total = NULL;
604 6743162 : locus where;
605 6743162 : match m;
606 :
607 6743162 : m = match_level_2 (&all);
608 6743162 : if (m != MATCH_YES)
609 : return m;
610 :
611 6030731 : for (;;)
612 : {
613 6025210 : if (!next_operator (INTRINSIC_CONCAT))
614 : break;
615 :
616 5528 : where = gfc_current_locus;
617 :
618 5528 : m = match_level_2 (&e);
619 5528 : if (m == MATCH_NO)
620 0 : gfc_error (expression_syntax);
621 5528 : if (m != MATCH_YES)
622 : {
623 6 : gfc_free_expr (all);
624 6 : return MATCH_ERROR;
625 : }
626 :
627 5522 : total = gfc_concat (all, e);
628 5522 : if (total == NULL)
629 : {
630 1 : gfc_free_expr (all);
631 1 : gfc_free_expr (e);
632 1 : return MATCH_ERROR;
633 : }
634 :
635 5521 : all = total;
636 5521 : all->where = where;
637 : }
638 :
639 6019682 : *result = all;
640 6019682 : return MATCH_YES;
641 : }
642 :
643 :
644 : /* Match a level 4 expression. */
645 :
646 : static match
647 5789692 : match_level_4 (gfc_expr **result)
648 : {
649 5789692 : gfc_expr *left, *right, *r;
650 5789692 : gfc_intrinsic_op i;
651 5789692 : locus old_loc;
652 5789692 : locus where;
653 5789692 : match m;
654 :
655 5789692 : m = match_level_3 (&left);
656 5789692 : if (m != MATCH_YES)
657 : return m;
658 :
659 5066212 : old_loc = gfc_current_locus;
660 :
661 5066212 : if (gfc_match_intrinsic_op (&i) != MATCH_YES)
662 : {
663 3990657 : *result = left;
664 3990657 : return MATCH_YES;
665 : }
666 :
667 1075555 : if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE
668 410246 : && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT
669 365674 : && i != INTRINSIC_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS
670 137791 : && i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS)
671 : {
672 122085 : gfc_current_locus = old_loc;
673 122085 : *result = left;
674 122085 : return MATCH_YES;
675 : }
676 :
677 953470 : where = gfc_current_locus;
678 :
679 953470 : m = match_level_3 (&right);
680 953470 : if (m == MATCH_NO)
681 0 : gfc_error (expression_syntax);
682 953470 : if (m != MATCH_YES)
683 : {
684 0 : gfc_free_expr (left);
685 0 : return MATCH_ERROR;
686 : }
687 :
688 953470 : switch (i)
689 : {
690 33623 : case INTRINSIC_EQ:
691 33623 : case INTRINSIC_EQ_OS:
692 33623 : r = gfc_eq (left, right, i);
693 33623 : break;
694 :
695 854875 : case INTRINSIC_NE:
696 854875 : case INTRINSIC_NE_OS:
697 854875 : r = gfc_ne (left, right, i);
698 854875 : break;
699 :
700 11207 : case INTRINSIC_LT:
701 11207 : case INTRINSIC_LT_OS:
702 11207 : r = gfc_lt (left, right, i);
703 11207 : break;
704 :
705 7407 : case INTRINSIC_LE:
706 7407 : case INTRINSIC_LE_OS:
707 7407 : r = gfc_le (left, right, i);
708 7407 : break;
709 :
710 41664 : case INTRINSIC_GT:
711 41664 : case INTRINSIC_GT_OS:
712 41664 : r = gfc_gt (left, right, i);
713 41664 : 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 953470 : if (r == NULL)
725 : {
726 0 : gfc_free_expr (left);
727 0 : gfc_free_expr (right);
728 0 : return MATCH_ERROR;
729 : }
730 :
731 953470 : r->where = where;
732 953470 : *result = r;
733 :
734 953470 : return MATCH_YES;
735 : }
736 :
737 :
738 : static match
739 5789692 : match_and_operand (gfc_expr **result)
740 : {
741 5789692 : gfc_expr *e, *r;
742 5789692 : locus where;
743 5789692 : match m;
744 5789692 : int i;
745 :
746 5789692 : i = next_operator (INTRINSIC_NOT);
747 5789692 : where = gfc_current_locus;
748 :
749 5789692 : m = match_level_4 (&e);
750 5789692 : if (m != MATCH_YES)
751 : return m;
752 :
753 5066212 : r = e;
754 5066212 : if (i)
755 : {
756 78103 : r = gfc_not (e);
757 78103 : if (r == NULL)
758 : {
759 0 : gfc_free_expr (e);
760 0 : return MATCH_ERROR;
761 : }
762 : }
763 :
764 5066212 : r->where = where;
765 5066212 : *result = r;
766 :
767 5066212 : return MATCH_YES;
768 : }
769 :
770 :
771 : static match
772 5772629 : match_or_operand (gfc_expr **result)
773 : {
774 5772629 : gfc_expr *all, *e, *total;
775 5772629 : locus where;
776 5772629 : match m;
777 :
778 5772629 : m = match_and_operand (&all);
779 5772629 : if (m != MATCH_YES)
780 : return m;
781 :
782 5083275 : for (;;)
783 : {
784 5066212 : if (!next_operator (INTRINSIC_AND))
785 : break;
786 17063 : where = gfc_current_locus;
787 :
788 17063 : m = match_and_operand (&e);
789 17063 : if (m == MATCH_NO)
790 0 : gfc_error (expression_syntax);
791 17063 : if (m != MATCH_YES)
792 : {
793 0 : gfc_free_expr (all);
794 0 : return MATCH_ERROR;
795 : }
796 :
797 17063 : total = gfc_and (all, e);
798 17063 : if (total == NULL)
799 : {
800 0 : gfc_free_expr (all);
801 0 : gfc_free_expr (e);
802 0 : return MATCH_ERROR;
803 : }
804 :
805 17063 : all = total;
806 17063 : all->where = where;
807 : }
808 :
809 5049149 : *result = all;
810 5049149 : return MATCH_YES;
811 : }
812 :
813 :
814 : static match
815 5571549 : match_equiv_operand (gfc_expr **result)
816 : {
817 5571549 : gfc_expr *all, *e, *total;
818 5571549 : locus where;
819 5571549 : match m;
820 :
821 5571549 : m = match_or_operand (&all);
822 5571549 : if (m != MATCH_YES)
823 : return m;
824 :
825 5250229 : for (;;)
826 : {
827 5049149 : if (!next_operator (INTRINSIC_OR))
828 : break;
829 201080 : where = gfc_current_locus;
830 :
831 201080 : m = match_or_operand (&e);
832 201080 : if (m == MATCH_NO)
833 0 : gfc_error (expression_syntax);
834 201080 : if (m != MATCH_YES)
835 : {
836 0 : gfc_free_expr (all);
837 0 : return MATCH_ERROR;
838 : }
839 :
840 201080 : total = gfc_or (all, e);
841 201080 : if (total == NULL)
842 : {
843 0 : gfc_free_expr (all);
844 0 : gfc_free_expr (e);
845 0 : return MATCH_ERROR;
846 : }
847 :
848 201080 : all = total;
849 201080 : all->where = where;
850 : }
851 :
852 4848069 : *result = all;
853 4848069 : return MATCH_YES;
854 : }
855 :
856 :
857 : /* Match a level 5 expression. */
858 :
859 : static match
860 5547282 : match_level_5 (gfc_expr **result)
861 : {
862 5547282 : gfc_expr *all, *e, *total;
863 5547282 : locus where;
864 5547282 : match m;
865 5547282 : gfc_intrinsic_op i;
866 :
867 5547282 : m = match_equiv_operand (&all);
868 5547282 : if (m != MATCH_YES)
869 : return m;
870 :
871 4872336 : for (;;)
872 : {
873 4848069 : if (next_operator (INTRINSIC_EQV))
874 : i = INTRINSIC_EQV;
875 : else
876 : {
877 4846089 : if (next_operator (INTRINSIC_NEQV))
878 : i = INTRINSIC_NEQV;
879 : else
880 : break;
881 : }
882 :
883 24267 : where = gfc_current_locus;
884 :
885 24267 : m = match_equiv_operand (&e);
886 24267 : if (m == MATCH_NO)
887 0 : gfc_error (expression_syntax);
888 24267 : if (m != MATCH_YES)
889 : {
890 0 : gfc_free_expr (all);
891 0 : return MATCH_ERROR;
892 : }
893 :
894 24267 : if (i == INTRINSIC_EQV)
895 1980 : total = gfc_eqv (all, e);
896 : else
897 22287 : total = gfc_neqv (all, e);
898 :
899 24267 : if (total == NULL)
900 : {
901 0 : gfc_free_expr (all);
902 0 : gfc_free_expr (e);
903 0 : return MATCH_ERROR;
904 : }
905 :
906 24267 : all = total;
907 24267 : all->where = where;
908 : }
909 :
910 4823802 : *result = all;
911 4823802 : 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 5546924 : gfc_match_expr (gfc_expr **result)
920 : {
921 5546924 : gfc_expr *all, *e;
922 5546924 : gfc_user_op *uop;
923 5546924 : locus where;
924 5546924 : match m;
925 :
926 5546924 : m = match_level_5 (&all);
927 5546924 : if (m != MATCH_YES)
928 : return m;
929 :
930 4824160 : for (;;)
931 : {
932 4823802 : uop = NULL;
933 4823802 : m = match_defined_operator (&uop);
934 4823802 : 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 4823408 : *result = all;
958 4823408 : return MATCH_YES;
959 : }
|
