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 11996718 : gfc_match_defined_op_name (char *result, int error_flag)
37 : {
38 11996718 : static const char * const badops[] = {
39 : "and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt",
40 : NULL
41 : };
42 :
43 11996718 : char name[GFC_MAX_SYMBOL_LEN + 1];
44 11996718 : locus old_loc;
45 11996718 : match m;
46 11996718 : int i;
47 :
48 11996718 : old_loc = gfc_current_locus;
49 :
50 11996718 : m = gfc_match (" . %n .", name);
51 11996718 : 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 57893 : if (strcmp (name, "true") == 0 || strcmp (name, "false") == 0)
58 : {
59 56790 : if (error_flag)
60 0 : goto error;
61 56790 : gfc_current_locus = old_loc;
62 56790 : 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 11995173 : match_defined_operator (gfc_user_op **result)
93 : {
94 11995173 : char name[GFC_MAX_SYMBOL_LEN + 1];
95 11995173 : match m;
96 :
97 11995173 : m = gfc_match_defined_op_name (name, 0);
98 11995173 : 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 77413567 : next_operator (gfc_intrinsic_op t)
111 : {
112 77413567 : gfc_intrinsic_op u;
113 77413567 : locus old_loc;
114 :
115 77413567 : old_loc = gfc_current_locus;
116 77413567 : if (gfc_match_intrinsic_op (&u) == MATCH_YES && t == u)
117 : return 1;
118 :
119 76596533 : gfc_current_locus = old_loc;
120 76596533 : 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 58578 : gfc_get_parentheses (gfc_expr *e)
130 : {
131 58578 : gfc_expr *e2;
132 :
133 58578 : e2 = gfc_get_operator_expr (&e->where, INTRINSIC_PARENTHESES, e, NULL);
134 58578 : e2->ts = e->ts;
135 58578 : e2->rank = e->rank;
136 58578 : e2->corank = e->corank;
137 :
138 58578 : return e2;
139 : }
140 :
141 : /* Match a conditional expression. */
142 :
143 : static match
144 58744 : match_conditional (gfc_expr **result)
145 : {
146 58744 : gfc_expr *condition, *true_expr, *false_expr;
147 58744 : locus where;
148 58744 : match m;
149 :
150 58744 : where = gfc_current_locus;
151 :
152 58744 : m = gfc_match_expr (&condition);
153 58744 : if (m != MATCH_YES)
154 : {
155 74 : gfc_error (expression_syntax);
156 74 : return MATCH_ERROR;
157 : }
158 :
159 58670 : m = gfc_match_char ('?');
160 58670 : if (m != MATCH_YES)
161 : {
162 58426 : *result = condition;
163 58426 : 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 7141251 : match_primary (gfc_expr **result)
205 : {
206 7141251 : match m;
207 7141251 : gfc_expr *e;
208 :
209 7141251 : m = gfc_match_literal_constant (result, 0);
210 7141251 : if (m != MATCH_NO)
211 : return m;
212 :
213 4399188 : m = gfc_match_array_constructor (result);
214 4399188 : if (m != MATCH_NO)
215 : return m;
216 :
217 4264887 : m = gfc_match_rvalue (result);
218 4264886 : if (m != MATCH_NO)
219 : return m;
220 :
221 : /* Match an expression in parentheses. */
222 204371 : if (gfc_match_char ('(') != MATCH_YES)
223 : return MATCH_NO;
224 :
225 58502 : m = match_conditional (&e);
226 58502 : if (m != MATCH_YES)
227 : return m;
228 :
229 58426 : m = gfc_match_char (')');
230 58426 : if (m == MATCH_NO)
231 2619 : 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 58426 : *result = e->expr_type == EXPR_CONDITIONAL ? e : gfc_get_parentheses (e);
239 :
240 58426 : if (m != MATCH_YES)
241 : {
242 2619 : gfc_free_expr (*result);
243 2619 : return MATCH_ERROR;
244 : }
245 :
246 : return MATCH_YES;
247 : }
248 :
249 :
250 : /* Match a level 1 expression. */
251 :
252 : static match
253 7141251 : match_level_1 (gfc_expr **result)
254 : {
255 7141251 : gfc_user_op *uop;
256 7141251 : gfc_expr *e, *f;
257 7141251 : locus where;
258 7141251 : match m;
259 :
260 7141251 : gfc_gobble_whitespace ();
261 7141251 : where = gfc_current_locus;
262 7141251 : uop = NULL;
263 7141251 : m = match_defined_operator (&uop);
264 7141251 : if (m == MATCH_ERROR)
265 : return m;
266 :
267 7141251 : m = match_primary (&e);
268 7141250 : if (m != MATCH_YES)
269 : return m;
270 :
271 6350883 : if (uop == NULL)
272 6350627 : *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 13480026 : match_add_op (void)
305 : {
306 13480026 : if (next_operator (INTRINSIC_MINUS))
307 : return -1;
308 13270447 : if (next_operator (INTRINSIC_PLUS))
309 70119 : return 1;
310 : return 0;
311 : }
312 :
313 :
314 : static match
315 7141251 : match_mult_operand (gfc_expr **result)
316 : {
317 : /* Workaround -Wmaybe-uninitialized false positive during
318 : profiledbootstrap by initializing them. */
319 7141251 : gfc_expr *e = NULL, *exp, *r;
320 7141251 : locus where;
321 7141251 : match m;
322 :
323 7141251 : m = match_level_1 (&e);
324 7141250 : if (m != MATCH_YES)
325 : return m;
326 :
327 6350883 : if (!next_operator (INTRINSIC_POWER))
328 : {
329 6282176 : *result = e;
330 6282176 : return MATCH_YES;
331 : }
332 :
333 68707 : where = gfc_current_locus;
334 :
335 68707 : m = match_ext_mult_operand (&exp);
336 68707 : if (m == MATCH_NO)
337 0 : gfc_error ("Expected exponent in expression at %C");
338 68707 : if (m != MATCH_YES)
339 : {
340 1 : gfc_free_expr (e);
341 1 : return MATCH_ERROR;
342 : }
343 :
344 68706 : r = gfc_power (e, exp);
345 68706 : if (r == NULL)
346 : {
347 0 : gfc_free_expr (e);
348 0 : gfc_free_expr (exp);
349 0 : return MATCH_ERROR;
350 : }
351 :
352 68706 : r->where = where;
353 68706 : *result = r;
354 :
355 68706 : return MATCH_YES;
356 : }
357 :
358 :
359 : static match
360 210954 : match_ext_mult_operand (gfc_expr **result)
361 : {
362 210954 : gfc_expr *all, *e;
363 210954 : locus where;
364 210954 : match m;
365 210954 : int i;
366 :
367 210954 : where = gfc_current_locus;
368 210954 : i = match_add_op ();
369 :
370 210954 : if (i == 0)
371 210941 : 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 6930310 : match_add_operand (gfc_expr **result)
406 : {
407 6930310 : gfc_expr *all, *e, *total;
408 6930310 : locus where, old_loc;
409 6930310 : match m;
410 6930310 : gfc_intrinsic_op i;
411 :
412 6930310 : m = match_mult_operand (&all);
413 6930309 : if (m != MATCH_YES)
414 : return m;
415 :
416 6365769 : for (;;)
417 : {
418 : /* Build up a string of products or quotients. */
419 :
420 6282168 : old_loc = gfc_current_locus;
421 :
422 6282168 : if (next_operator (INTRINSIC_TIMES))
423 : i = INTRINSIC_TIMES;
424 : else
425 : {
426 6212091 : if (next_operator (INTRINSIC_DIVIDE))
427 : i = INTRINSIC_DIVIDE;
428 : else
429 : break;
430 : }
431 :
432 142234 : where = gfc_current_locus;
433 :
434 142234 : m = match_ext_mult_operand (&e);
435 142234 : if (m == MATCH_NO)
436 : {
437 58625 : gfc_current_locus = old_loc;
438 58625 : break;
439 : }
440 :
441 83609 : if (m == MATCH_ERROR)
442 : {
443 0 : gfc_free_expr (all);
444 0 : return MATCH_ERROR;
445 : }
446 :
447 83609 : if (i == INTRINSIC_TIMES)
448 70077 : total = gfc_multiply (all, e);
449 : else
450 13532 : total = gfc_divide (all, e);
451 :
452 83609 : if (total == NULL)
453 : {
454 8 : gfc_free_expr (all);
455 8 : gfc_free_expr (e);
456 8 : return MATCH_ERROR;
457 : }
458 :
459 83601 : all = total;
460 83601 : all->where = where;
461 : }
462 :
463 6198559 : *result = all;
464 6198559 : return MATCH_YES;
465 : }
466 :
467 :
468 : static match
469 279685 : match_ext_add_operand (gfc_expr **result)
470 : {
471 279685 : gfc_expr *all, *e;
472 279685 : locus where;
473 279685 : match m;
474 279685 : int i;
475 :
476 279685 : where = gfc_current_locus;
477 279685 : i = match_add_op ();
478 :
479 279685 : if (i == 0)
480 279685 : 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 6790829 : match_level_2 (gfc_expr **result)
517 : {
518 6790829 : gfc_expr *all, *e, *total;
519 6790829 : locus where;
520 6790829 : match m;
521 6790829 : int i;
522 :
523 6790829 : where = gfc_current_locus;
524 6790829 : i = match_add_op ();
525 :
526 6790829 : if (i != 0)
527 : {
528 140204 : m = match_ext_add_operand (&e);
529 140204 : if (m == MATCH_NO)
530 : {
531 8 : gfc_error (expression_syntax);
532 8 : m = MATCH_ERROR;
533 : }
534 : }
535 : else
536 6650625 : m = match_add_operand (&e);
537 :
538 6790828 : if (m != MATCH_YES)
539 731747 : return m;
540 :
541 6059081 : if (i == 0)
542 5918891 : all = e;
543 : else
544 : {
545 140190 : if (i == -1)
546 139820 : all = gfc_uminus (e);
547 : else
548 370 : all = gfc_uplus (e);
549 :
550 140190 : if (all == NULL)
551 : {
552 1 : gfc_free_expr (e);
553 1 : return MATCH_ERROR;
554 : }
555 : }
556 :
557 6059080 : all->where = where;
558 :
559 : /* Append add-operands to the sum. */
560 :
561 6338036 : for (;;)
562 : {
563 6198558 : where = gfc_current_locus;
564 6198558 : i = match_add_op ();
565 6198558 : if (i == 0)
566 : break;
567 :
568 139481 : m = match_ext_add_operand (&e);
569 139481 : if (m == MATCH_NO)
570 0 : gfc_error (expression_syntax);
571 139481 : if (m != MATCH_YES)
572 : {
573 3 : gfc_free_expr (all);
574 3 : return MATCH_ERROR;
575 : }
576 :
577 139478 : if (i == -1)
578 69738 : total = gfc_subtract (all, e);
579 : else
580 69740 : total = gfc_add (all, e);
581 :
582 139478 : if (total == NULL)
583 : {
584 0 : gfc_free_expr (all);
585 0 : gfc_free_expr (e);
586 0 : return MATCH_ERROR;
587 : }
588 :
589 139478 : all = total;
590 139478 : all->where = where;
591 : }
592 :
593 6059077 : *result = all;
594 6059077 : return MATCH_YES;
595 : }
596 :
597 :
598 : /* Match a level three expression. */
599 :
600 : static match
601 6785271 : match_level_3 (gfc_expr **result)
602 : {
603 6785271 : gfc_expr *all, *e, *total = NULL;
604 6785271 : locus where;
605 6785271 : match m;
606 :
607 6785271 : m = match_level_2 (&all);
608 6785270 : if (m != MATCH_YES)
609 : return m;
610 :
611 6064627 : for (;;)
612 : {
613 6059076 : if (!next_operator (INTRINSIC_CONCAT))
614 : break;
615 :
616 5558 : where = gfc_current_locus;
617 :
618 5558 : m = match_level_2 (&e);
619 5558 : if (m == MATCH_NO)
620 0 : gfc_error (expression_syntax);
621 5558 : if (m != MATCH_YES)
622 : {
623 6 : gfc_free_expr (all);
624 6 : return MATCH_ERROR;
625 : }
626 :
627 5552 : total = gfc_concat (all, e);
628 5552 : if (total == NULL)
629 : {
630 1 : gfc_free_expr (all);
631 1 : gfc_free_expr (e);
632 1 : return MATCH_ERROR;
633 : }
634 :
635 5551 : all = total;
636 5551 : all->where = where;
637 : }
638 :
639 6053518 : *result = all;
640 6053518 : return MATCH_YES;
641 : }
642 :
643 :
644 : /* Match a level 4 expression. */
645 :
646 : static match
647 5828357 : match_level_4 (gfc_expr **result)
648 : {
649 5828357 : gfc_expr *left, *right, *r;
650 5828357 : gfc_intrinsic_op i;
651 5828357 : locus old_loc;
652 5828357 : locus where;
653 5828357 : match m;
654 :
655 5828357 : m = match_level_3 (&left);
656 5828356 : if (m != MATCH_YES)
657 : return m;
658 :
659 5096604 : old_loc = gfc_current_locus;
660 :
661 5096604 : if (gfc_match_intrinsic_op (&i) != MATCH_YES)
662 : {
663 4017581 : *result = left;
664 4017581 : return MATCH_YES;
665 : }
666 :
667 1079023 : if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE
668 410950 : && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT
669 365818 : && i != INTRINSIC_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS
670 137815 : && i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS)
671 : {
672 122109 : gfc_current_locus = old_loc;
673 122109 : *result = left;
674 122109 : return MATCH_YES;
675 : }
676 :
677 956914 : where = gfc_current_locus;
678 :
679 956914 : m = match_level_3 (&right);
680 956914 : if (m == MATCH_NO)
681 0 : gfc_error (expression_syntax);
682 956914 : if (m != MATCH_YES)
683 : {
684 0 : gfc_free_expr (left);
685 0 : return MATCH_ERROR;
686 : }
687 :
688 956914 : switch (i)
689 : {
690 33663 : case INTRINSIC_EQ:
691 33663 : case INTRINSIC_EQ_OS:
692 33663 : r = gfc_eq (left, right, i);
693 33663 : break;
694 :
695 857679 : case INTRINSIC_NE:
696 857679 : case INTRINSIC_NE_OS:
697 857679 : r = gfc_ne (left, right, i);
698 857679 : break;
699 :
700 11311 : case INTRINSIC_LT:
701 11311 : case INTRINSIC_LT_OS:
702 11311 : r = gfc_lt (left, right, i);
703 11311 : break;
704 :
705 7439 : case INTRINSIC_LE:
706 7439 : case INTRINSIC_LE_OS:
707 7439 : r = gfc_le (left, right, i);
708 7439 : break;
709 :
710 42088 : case INTRINSIC_GT:
711 42088 : case INTRINSIC_GT_OS:
712 42088 : r = gfc_gt (left, right, i);
713 42088 : break;
714 :
715 4734 : case INTRINSIC_GE:
716 4734 : case INTRINSIC_GE_OS:
717 4734 : r = gfc_ge (left, right, i);
718 4734 : break;
719 :
720 0 : default:
721 0 : gfc_internal_error ("match_level_4(): Bad operator");
722 : }
723 :
724 956914 : if (r == NULL)
725 : {
726 0 : gfc_free_expr (left);
727 0 : gfc_free_expr (right);
728 0 : return MATCH_ERROR;
729 : }
730 :
731 956914 : r->where = where;
732 956914 : *result = r;
733 :
734 956914 : return MATCH_YES;
735 : }
736 :
737 :
738 : static match
739 5828357 : match_and_operand (gfc_expr **result)
740 : {
741 5828357 : gfc_expr *e, *r;
742 5828357 : locus where;
743 5828357 : match m;
744 5828357 : int i;
745 :
746 5828357 : i = next_operator (INTRINSIC_NOT);
747 5828357 : where = gfc_current_locus;
748 :
749 5828357 : m = match_level_4 (&e);
750 5828356 : if (m != MATCH_YES)
751 : return m;
752 :
753 5096604 : r = e;
754 5096604 : if (i)
755 : {
756 78155 : r = gfc_not (e);
757 78155 : if (r == NULL)
758 : {
759 0 : gfc_free_expr (e);
760 0 : return MATCH_ERROR;
761 : }
762 : }
763 :
764 5096604 : r->where = where;
765 5096604 : *result = r;
766 :
767 5096604 : return MATCH_YES;
768 : }
769 :
770 :
771 : static match
772 5811270 : match_or_operand (gfc_expr **result)
773 : {
774 5811270 : gfc_expr *all, *e, *total;
775 5811270 : locus where;
776 5811270 : match m;
777 :
778 5811270 : m = match_and_operand (&all);
779 5811269 : if (m != MATCH_YES)
780 : return m;
781 :
782 5113691 : for (;;)
783 : {
784 5096604 : if (!next_operator (INTRINSIC_AND))
785 : break;
786 17087 : where = gfc_current_locus;
787 :
788 17087 : m = match_and_operand (&e);
789 17087 : if (m == MATCH_NO)
790 0 : gfc_error (expression_syntax);
791 17087 : if (m != MATCH_YES)
792 : {
793 0 : gfc_free_expr (all);
794 0 : return MATCH_ERROR;
795 : }
796 :
797 17087 : total = gfc_and (all, e);
798 17087 : if (total == NULL)
799 : {
800 0 : gfc_free_expr (all);
801 0 : gfc_free_expr (e);
802 0 : return MATCH_ERROR;
803 : }
804 :
805 17087 : all = total;
806 17087 : all->where = where;
807 : }
808 :
809 5079517 : *result = all;
810 5079517 : return MATCH_YES;
811 : }
812 :
813 :
814 : static match
815 5609942 : match_equiv_operand (gfc_expr **result)
816 : {
817 5609942 : gfc_expr *all, *e, *total;
818 5609942 : locus where;
819 5609942 : match m;
820 :
821 5609942 : m = match_or_operand (&all);
822 5609941 : if (m != MATCH_YES)
823 : return m;
824 :
825 5280845 : for (;;)
826 : {
827 5079517 : if (!next_operator (INTRINSIC_OR))
828 : break;
829 201328 : where = gfc_current_locus;
830 :
831 201328 : m = match_or_operand (&e);
832 201328 : if (m == MATCH_NO)
833 0 : gfc_error (expression_syntax);
834 201328 : if (m != MATCH_YES)
835 : {
836 0 : gfc_free_expr (all);
837 0 : return MATCH_ERROR;
838 : }
839 :
840 201328 : total = gfc_or (all, e);
841 201328 : if (total == NULL)
842 : {
843 0 : gfc_free_expr (all);
844 0 : gfc_free_expr (e);
845 0 : return MATCH_ERROR;
846 : }
847 :
848 201328 : all = total;
849 201328 : all->where = where;
850 : }
851 :
852 4878189 : *result = all;
853 4878189 : return MATCH_YES;
854 : }
855 :
856 :
857 : /* Match a level 5 expression. */
858 :
859 : static match
860 5585675 : match_level_5 (gfc_expr **result)
861 : {
862 5585675 : gfc_expr *all, *e, *total;
863 5585675 : locus where;
864 5585675 : match m;
865 5585675 : gfc_intrinsic_op i;
866 :
867 5585675 : m = match_equiv_operand (&all);
868 5585674 : if (m != MATCH_YES)
869 : return m;
870 :
871 4902456 : for (;;)
872 : {
873 4878189 : if (next_operator (INTRINSIC_EQV))
874 : i = INTRINSIC_EQV;
875 : else
876 : {
877 4876209 : 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 4853922 : *result = all;
911 4853922 : 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 5585314 : gfc_match_expr (gfc_expr **result)
920 : {
921 5585314 : gfc_expr *all, *e;
922 5585314 : gfc_user_op *uop;
923 5585314 : locus where;
924 5585314 : match m;
925 :
926 5585314 : m = match_level_5 (&all);
927 5585313 : if (m != MATCH_YES)
928 : return m;
929 :
930 4854283 : for (;;)
931 : {
932 4853922 : uop = NULL;
933 4853922 : m = match_defined_operator (&uop);
934 4853922 : 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 4853525 : *result = all;
958 4853525 : return MATCH_YES;
959 : }
|
