Branch data Line data Source code
1 : : /* Expression parser.
2 : : Copyright (C) 2000-2024 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 : 10521176 : gfc_match_defined_op_name (char *result, int error_flag)
37 : : {
38 : 10521176 : static const char * const badops[] = {
39 : : "and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt",
40 : : NULL
41 : : };
42 : :
43 : 10521176 : char name[GFC_MAX_SYMBOL_LEN + 1];
44 : 10521176 : locus old_loc;
45 : 10521176 : match m;
46 : 10521176 : int i;
47 : :
48 : 10521176 : old_loc = gfc_current_locus;
49 : :
50 : 10521176 : m = gfc_match (" . %n .", name);
51 : 10521176 : 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 : 45246 : if (strcmp (name, "true") == 0 || strcmp (name, "false") == 0)
58 : : {
59 : 44410 : if (error_flag)
60 : 0 : goto error;
61 : 44410 : gfc_current_locus = old_loc;
62 : 44410 : return MATCH_NO;
63 : : }
64 : :
65 : 10031 : for (i = 0; badops[i]; i++)
66 : 9196 : if (strcmp (badops[i], name) == 0)
67 : 1 : goto error;
68 : :
69 : 4398 : for (i = 0; name[i]; i++)
70 : 3599 : 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 : 799 : strcpy (result, name);
77 : 799 : 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 : 10519749 : match_defined_operator (gfc_user_op **result)
93 : : {
94 : 10519749 : char name[GFC_MAX_SYMBOL_LEN + 1];
95 : 10519749 : match m;
96 : :
97 : 10519749 : m = gfc_match_defined_op_name (name, 0);
98 : 10519749 : if (m != MATCH_YES)
99 : : return m;
100 : :
101 : 404 : *result = gfc_get_uop (name);
102 : 404 : 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 : 67294633 : next_operator (gfc_intrinsic_op t)
111 : : {
112 : 67294633 : gfc_intrinsic_op u;
113 : 67294633 : locus old_loc;
114 : :
115 : 67294633 : old_loc = gfc_current_locus;
116 : 67294633 : if (gfc_match_intrinsic_op (&u) == MATCH_YES && t == u)
117 : : return 1;
118 : :
119 : 66684680 : gfc_current_locus = old_loc;
120 : 66684680 : 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 : 54889 : gfc_get_parentheses (gfc_expr *e)
130 : : {
131 : 54889 : gfc_expr *e2;
132 : :
133 : 54889 : e2 = gfc_get_operator_expr (&e->where, INTRINSIC_PARENTHESES, e, NULL);
134 : 54889 : e2->ts = e->ts;
135 : 54889 : e2->rank = e->rank;
136 : 54889 : e2->corank = e->corank;
137 : :
138 : 54889 : return e2;
139 : : }
140 : :
141 : :
142 : : /* Match a primary expression. */
143 : :
144 : : static match
145 : 6165459 : match_primary (gfc_expr **result)
146 : : {
147 : 6165459 : match m;
148 : 6165459 : gfc_expr *e;
149 : :
150 : 6165459 : m = gfc_match_literal_constant (result, 0);
151 : 6165459 : if (m != MATCH_NO)
152 : : return m;
153 : :
154 : 3693496 : m = gfc_match_array_constructor (result);
155 : 3693496 : if (m != MATCH_NO)
156 : : return m;
157 : :
158 : 3570856 : m = gfc_match_rvalue (result);
159 : 3570856 : if (m != MATCH_NO)
160 : : return m;
161 : :
162 : : /* Match an expression in parentheses. */
163 : 196293 : if (gfc_match_char ('(') != MATCH_YES)
164 : : return MATCH_NO;
165 : :
166 : 54603 : m = gfc_match_expr (&e);
167 : 54603 : if (m == MATCH_NO)
168 : 65 : goto syntax;
169 : 54538 : if (m == MATCH_ERROR)
170 : : return m;
171 : :
172 : 54533 : m = gfc_match_char (')');
173 : 54533 : if (m == MATCH_NO)
174 : 2318 : gfc_error ("Expected a right parenthesis in expression at %C");
175 : :
176 : : /* Now we have the expression inside the parentheses, build the
177 : : expression pointing to it. By 7.1.7.2, any expression in
178 : : parentheses shall be treated as a data entity. */
179 : 54533 : *result = gfc_get_parentheses (e);
180 : :
181 : 54533 : if (m != MATCH_YES)
182 : : {
183 : 2318 : gfc_free_expr (*result);
184 : 2318 : return MATCH_ERROR;
185 : : }
186 : :
187 : : return MATCH_YES;
188 : :
189 : 65 : syntax:
190 : 65 : gfc_error (expression_syntax);
191 : 65 : return MATCH_ERROR;
192 : : }
193 : :
194 : :
195 : : /* Match a level 1 expression. */
196 : :
197 : : static match
198 : 6165459 : match_level_1 (gfc_expr **result)
199 : : {
200 : 6165459 : gfc_user_op *uop;
201 : 6165459 : gfc_expr *e, *f;
202 : 6165459 : locus where;
203 : 6165459 : match m;
204 : :
205 : 6165459 : gfc_gobble_whitespace ();
206 : 6165459 : where = gfc_current_locus;
207 : 6165459 : uop = NULL;
208 : 6165459 : m = match_defined_operator (&uop);
209 : 6165459 : if (m == MATCH_ERROR)
210 : : return m;
211 : :
212 : 6165459 : m = match_primary (&e);
213 : 6165459 : if (m != MATCH_YES)
214 : : return m;
215 : :
216 : 5422626 : if (uop == NULL)
217 : 5422402 : *result = e;
218 : : else
219 : : {
220 : 224 : f = gfc_get_operator_expr (&where, INTRINSIC_USER, e, NULL);
221 : 224 : f->value.op.uop = uop;
222 : 224 : *result = f;
223 : : }
224 : :
225 : : return MATCH_YES;
226 : : }
227 : :
228 : :
229 : : /* As a GNU extension we support an expanded level-2 expression syntax.
230 : : Via this extension we support (arbitrary) nesting of unary plus and
231 : : minus operations following unary and binary operators, such as **.
232 : : The grammar of section 7.1.1.3 is effectively rewritten as:
233 : :
234 : : R704 mult-operand is level-1-expr [ power-op ext-mult-operand ]
235 : : R704' ext-mult-operand is add-op ext-mult-operand
236 : : or mult-operand
237 : : R705 add-operand is add-operand mult-op ext-mult-operand
238 : : or mult-operand
239 : : R705' ext-add-operand is add-op ext-add-operand
240 : : or add-operand
241 : : R706 level-2-expr is [ level-2-expr ] add-op ext-add-operand
242 : : or add-operand
243 : : */
244 : :
245 : : static match match_ext_mult_operand (gfc_expr **result);
246 : : static match match_ext_add_operand (gfc_expr **result);
247 : :
248 : : static int
249 : 11639296 : match_add_op (void)
250 : : {
251 : 11639296 : if (next_operator (INTRINSIC_MINUS))
252 : : return -1;
253 : 11434943 : if (next_operator (INTRINSIC_PLUS))
254 : 66952 : return 1;
255 : : return 0;
256 : : }
257 : :
258 : :
259 : : static match
260 : 6165459 : match_mult_operand (gfc_expr **result)
261 : : {
262 : : /* Workaround -Wmaybe-uninitialized false positive during
263 : : profiledbootstrap by initializing them. */
264 : 6165459 : gfc_expr *e = NULL, *exp, *r;
265 : 6165459 : locus where;
266 : 6165459 : match m;
267 : :
268 : 6165459 : m = match_level_1 (&e);
269 : 6165459 : if (m != MATCH_YES)
270 : : return m;
271 : :
272 : 5422626 : if (!next_operator (INTRINSIC_POWER))
273 : : {
274 : 5415611 : *result = e;
275 : 5415611 : return MATCH_YES;
276 : : }
277 : :
278 : 7015 : where = gfc_current_locus;
279 : :
280 : 7015 : m = match_ext_mult_operand (&exp);
281 : 7015 : if (m == MATCH_NO)
282 : 0 : gfc_error ("Expected exponent in expression at %C");
283 : 7015 : if (m != MATCH_YES)
284 : : {
285 : 1 : gfc_free_expr (e);
286 : 1 : return MATCH_ERROR;
287 : : }
288 : :
289 : 7014 : r = gfc_power (e, exp);
290 : 7014 : if (r == NULL)
291 : : {
292 : 0 : gfc_free_expr (e);
293 : 0 : gfc_free_expr (exp);
294 : 0 : return MATCH_ERROR;
295 : : }
296 : :
297 : 7014 : r->where = where;
298 : 7014 : *result = r;
299 : :
300 : 7014 : return MATCH_YES;
301 : : }
302 : :
303 : :
304 : : static match
305 : 144421 : match_ext_mult_operand (gfc_expr **result)
306 : : {
307 : 144421 : gfc_expr *all, *e;
308 : 144421 : locus where;
309 : 144421 : match m;
310 : 144421 : int i;
311 : :
312 : 144421 : where = gfc_current_locus;
313 : 144421 : i = match_add_op ();
314 : :
315 : 144421 : if (i == 0)
316 : 144408 : return match_mult_operand (result);
317 : :
318 : 13 : if (gfc_notification_std (GFC_STD_GNU) == ERROR)
319 : : {
320 : 0 : gfc_error ("Extension: Unary operator following "
321 : : "arithmetic operator (use parentheses) at %C");
322 : 0 : return MATCH_ERROR;
323 : : }
324 : : else
325 : 13 : gfc_warning (0, "Extension: Unary operator following "
326 : : "arithmetic operator (use parentheses) at %C");
327 : :
328 : 13 : m = match_ext_mult_operand (&e);
329 : 13 : if (m != MATCH_YES)
330 : : return m;
331 : :
332 : 13 : if (i == -1)
333 : 7 : all = gfc_uminus (e);
334 : : else
335 : 6 : all = gfc_uplus (e);
336 : :
337 : 13 : if (all == NULL)
338 : : {
339 : 0 : gfc_free_expr (e);
340 : 0 : return MATCH_ERROR;
341 : : }
342 : :
343 : 13 : all->where = where;
344 : 13 : *result = all;
345 : 13 : return MATCH_YES;
346 : : }
347 : :
348 : :
349 : : static match
350 : 6021051 : match_add_operand (gfc_expr **result)
351 : : {
352 : 6021051 : gfc_expr *all, *e, *total;
353 : 6021051 : locus where, old_loc;
354 : 6021051 : match m;
355 : 6021051 : gfc_intrinsic_op i;
356 : :
357 : 6021051 : m = match_mult_operand (&all);
358 : 6021051 : if (m != MATCH_YES)
359 : : return m;
360 : :
361 : 5494060 : for (;;)
362 : : {
363 : : /* Build up a string of products or quotients. */
364 : :
365 : 5415603 : old_loc = gfc_current_locus;
366 : :
367 : 5415603 : if (next_operator (INTRINSIC_TIMES))
368 : : i = INTRINSIC_TIMES;
369 : : else
370 : : {
371 : 5349997 : if (next_operator (INTRINSIC_DIVIDE))
372 : : i = INTRINSIC_DIVIDE;
373 : : else
374 : : break;
375 : : }
376 : :
377 : 137393 : where = gfc_current_locus;
378 : :
379 : 137393 : m = match_ext_mult_operand (&e);
380 : 137393 : if (m == MATCH_NO)
381 : : {
382 : 58928 : gfc_current_locus = old_loc;
383 : 58928 : break;
384 : : }
385 : :
386 : 78465 : if (m == MATCH_ERROR)
387 : : {
388 : 0 : gfc_free_expr (all);
389 : 0 : return MATCH_ERROR;
390 : : }
391 : :
392 : 78465 : if (i == INTRINSIC_TIMES)
393 : 65606 : total = gfc_multiply (all, e);
394 : : else
395 : 12859 : total = gfc_divide (all, e);
396 : :
397 : 78465 : if (total == NULL)
398 : : {
399 : 8 : gfc_free_expr (all);
400 : 8 : gfc_free_expr (e);
401 : 8 : return MATCH_ERROR;
402 : : }
403 : :
404 : 78457 : all = total;
405 : 78457 : all->where = where;
406 : : }
407 : :
408 : 5337138 : *result = all;
409 : 5337138 : return MATCH_YES;
410 : : }
411 : :
412 : :
413 : : static match
414 : 271292 : match_ext_add_operand (gfc_expr **result)
415 : : {
416 : 271292 : gfc_expr *all, *e;
417 : 271292 : locus where;
418 : 271292 : match m;
419 : 271292 : int i;
420 : :
421 : 271292 : where = gfc_current_locus;
422 : 271292 : i = match_add_op ();
423 : :
424 : 271292 : if (i == 0)
425 : 271292 : return match_add_operand (result);
426 : :
427 : 0 : if (gfc_notification_std (GFC_STD_GNU) == ERROR)
428 : : {
429 : 0 : gfc_error ("Extension: Unary operator following "
430 : : "arithmetic operator (use parentheses) at %C");
431 : 0 : return MATCH_ERROR;
432 : : }
433 : : else
434 : 0 : gfc_warning (0, "Extension: Unary operator following "
435 : : "arithmetic operator (use parentheses) at %C");
436 : :
437 : 0 : m = match_ext_add_operand (&e);
438 : 0 : if (m != MATCH_YES)
439 : : return m;
440 : :
441 : 0 : if (i == -1)
442 : 0 : all = gfc_uminus (e);
443 : : else
444 : 0 : all = gfc_uplus (e);
445 : :
446 : 0 : if (all == NULL)
447 : : {
448 : 0 : gfc_free_expr (e);
449 : 0 : return MATCH_ERROR;
450 : : }
451 : :
452 : 0 : all->where = where;
453 : 0 : *result = all;
454 : 0 : return MATCH_YES;
455 : : }
456 : :
457 : :
458 : : /* Match a level 2 expression. */
459 : :
460 : : static match
461 : 5886446 : match_level_2 (gfc_expr **result)
462 : : {
463 : 5886446 : gfc_expr *all, *e, *total;
464 : 5886446 : locus where;
465 : 5886446 : match m;
466 : 5886446 : int i;
467 : :
468 : 5886446 : where = gfc_current_locus;
469 : 5886446 : i = match_add_op ();
470 : :
471 : 5886446 : if (i != 0)
472 : : {
473 : 136687 : m = match_ext_add_operand (&e);
474 : 136687 : if (m == MATCH_NO)
475 : : {
476 : 8 : gfc_error (expression_syntax);
477 : 8 : m = MATCH_ERROR;
478 : : }
479 : : }
480 : : else
481 : 5749759 : m = match_add_operand (&e);
482 : :
483 : 5886446 : if (m != MATCH_YES)
484 : 683910 : return m;
485 : :
486 : 5202536 : if (i == 0)
487 : 5065863 : all = e;
488 : : else
489 : : {
490 : 136673 : if (i == -1)
491 : 136303 : all = gfc_uminus (e);
492 : : else
493 : 370 : all = gfc_uplus (e);
494 : :
495 : 136673 : if (all == NULL)
496 : : {
497 : 1 : gfc_free_expr (e);
498 : 1 : return MATCH_ERROR;
499 : : }
500 : : }
501 : :
502 : 5202535 : all->where = where;
503 : :
504 : : /* Append add-operands to the sum. */
505 : :
506 : 5471739 : for (;;)
507 : : {
508 : 5337137 : where = gfc_current_locus;
509 : 5337137 : i = match_add_op ();
510 : 5337137 : if (i == 0)
511 : : break;
512 : :
513 : 134605 : m = match_ext_add_operand (&e);
514 : 134605 : if (m == MATCH_NO)
515 : 0 : gfc_error (expression_syntax);
516 : 134605 : if (m != MATCH_YES)
517 : : {
518 : 3 : gfc_free_expr (all);
519 : 3 : return MATCH_ERROR;
520 : : }
521 : :
522 : 134602 : if (i == -1)
523 : 68029 : total = gfc_subtract (all, e);
524 : : else
525 : 66573 : total = gfc_add (all, e);
526 : :
527 : 134602 : if (total == NULL)
528 : : {
529 : 0 : gfc_free_expr (all);
530 : 0 : gfc_free_expr (e);
531 : 0 : return MATCH_ERROR;
532 : : }
533 : :
534 : 134602 : all = total;
535 : 134602 : all->where = where;
536 : : }
537 : :
538 : 5202532 : *result = all;
539 : 5202532 : return MATCH_YES;
540 : : }
541 : :
542 : :
543 : : /* Match a level three expression. */
544 : :
545 : : static match
546 : 5880891 : match_level_3 (gfc_expr **result)
547 : : {
548 : 5880891 : gfc_expr *all, *e, *total = NULL;
549 : 5880891 : locus where;
550 : 5880891 : match m;
551 : :
552 : 5880891 : m = match_level_2 (&all);
553 : 5880891 : if (m != MATCH_YES)
554 : : return m;
555 : :
556 : 5208079 : for (;;)
557 : : {
558 : 5202531 : if (!next_operator (INTRINSIC_CONCAT))
559 : : break;
560 : :
561 : 5555 : where = gfc_current_locus;
562 : :
563 : 5555 : m = match_level_2 (&e);
564 : 5555 : if (m == MATCH_NO)
565 : 0 : gfc_error (expression_syntax);
566 : 5555 : if (m != MATCH_YES)
567 : : {
568 : 6 : gfc_free_expr (all);
569 : 6 : return MATCH_ERROR;
570 : : }
571 : :
572 : 5549 : total = gfc_concat (all, e);
573 : 5549 : if (total == NULL)
574 : : {
575 : 1 : gfc_free_expr (all);
576 : 1 : gfc_free_expr (e);
577 : 1 : return MATCH_ERROR;
578 : : }
579 : :
580 : 5548 : all = total;
581 : 5548 : all->where = where;
582 : : }
583 : :
584 : 5196976 : *result = all;
585 : 5196976 : return MATCH_YES;
586 : : }
587 : :
588 : :
589 : : /* Match a level 4 expression. */
590 : :
591 : : static match
592 : 5153746 : match_level_4 (gfc_expr **result)
593 : : {
594 : 5153746 : gfc_expr *left, *right, *r;
595 : 5153746 : gfc_intrinsic_op i;
596 : 5153746 : locus old_loc;
597 : 5153746 : locus where;
598 : 5153746 : match m;
599 : :
600 : 5153746 : m = match_level_3 (&left);
601 : 5153746 : if (m != MATCH_YES)
602 : : return m;
603 : :
604 : 4469831 : old_loc = gfc_current_locus;
605 : :
606 : 4469831 : if (gfc_match_intrinsic_op (&i) != MATCH_YES)
607 : : {
608 : 3622830 : *result = left;
609 : 3622830 : return MATCH_YES;
610 : : }
611 : :
612 : 847001 : if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE
613 : 391996 : && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT
614 : 348167 : && i != INTRINSIC_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS
615 : 135599 : && i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS)
616 : : {
617 : 119856 : gfc_current_locus = old_loc;
618 : 119856 : *result = left;
619 : 119856 : return MATCH_YES;
620 : : }
621 : :
622 : 727145 : where = gfc_current_locus;
623 : :
624 : 727145 : m = match_level_3 (&right);
625 : 727145 : if (m == MATCH_NO)
626 : 0 : gfc_error (expression_syntax);
627 : 727145 : if (m != MATCH_YES)
628 : : {
629 : 0 : gfc_free_expr (left);
630 : 0 : return MATCH_ERROR;
631 : : }
632 : :
633 : 727145 : switch (i)
634 : : {
635 : 32630 : case INTRINSIC_EQ:
636 : 32630 : case INTRINSIC_EQ_OS:
637 : 32630 : r = gfc_eq (left, right, i);
638 : 32630 : break;
639 : :
640 : 630051 : case INTRINSIC_NE:
641 : 630051 : case INTRINSIC_NE_OS:
642 : 630051 : r = gfc_ne (left, right, i);
643 : 630051 : break;
644 : :
645 : 11296 : case INTRINSIC_LT:
646 : 11296 : case INTRINSIC_LT_OS:
647 : 11296 : r = gfc_lt (left, right, i);
648 : 11296 : break;
649 : :
650 : 7491 : case INTRINSIC_LE:
651 : 7491 : case INTRINSIC_LE_OS:
652 : 7491 : r = gfc_le (left, right, i);
653 : 7491 : break;
654 : :
655 : 40785 : case INTRINSIC_GT:
656 : 40785 : case INTRINSIC_GT_OS:
657 : 40785 : r = gfc_gt (left, right, i);
658 : 40785 : break;
659 : :
660 : 4892 : case INTRINSIC_GE:
661 : 4892 : case INTRINSIC_GE_OS:
662 : 4892 : r = gfc_ge (left, right, i);
663 : 4892 : break;
664 : :
665 : 0 : default:
666 : 0 : gfc_internal_error ("match_level_4(): Bad operator");
667 : : }
668 : :
669 : 727145 : if (r == NULL)
670 : : {
671 : 0 : gfc_free_expr (left);
672 : 0 : gfc_free_expr (right);
673 : 0 : return MATCH_ERROR;
674 : : }
675 : :
676 : 727145 : r->where = where;
677 : 727145 : *result = r;
678 : :
679 : 727145 : return MATCH_YES;
680 : : }
681 : :
682 : :
683 : : static match
684 : 5153746 : match_and_operand (gfc_expr **result)
685 : : {
686 : 5153746 : gfc_expr *e, *r;
687 : 5153746 : locus where;
688 : 5153746 : match m;
689 : 5153746 : int i;
690 : :
691 : 5153746 : i = next_operator (INTRINSIC_NOT);
692 : 5153746 : where = gfc_current_locus;
693 : :
694 : 5153746 : m = match_level_4 (&e);
695 : 5153746 : if (m != MATCH_YES)
696 : : return m;
697 : :
698 : 4469831 : r = e;
699 : 4469831 : if (i)
700 : : {
701 : 73144 : r = gfc_not (e);
702 : 73144 : if (r == NULL)
703 : : {
704 : 0 : gfc_free_expr (e);
705 : 0 : return MATCH_ERROR;
706 : : }
707 : : }
708 : :
709 : 4469831 : r->where = where;
710 : 4469831 : *result = r;
711 : :
712 : 4469831 : return MATCH_YES;
713 : : }
714 : :
715 : :
716 : : static match
717 : 5136933 : match_or_operand (gfc_expr **result)
718 : : {
719 : 5136933 : gfc_expr *all, *e, *total;
720 : 5136933 : locus where;
721 : 5136933 : match m;
722 : :
723 : 5136933 : m = match_and_operand (&all);
724 : 5136933 : if (m != MATCH_YES)
725 : : return m;
726 : :
727 : 4486644 : for (;;)
728 : : {
729 : 4469831 : if (!next_operator (INTRINSIC_AND))
730 : : break;
731 : 16813 : where = gfc_current_locus;
732 : :
733 : 16813 : m = match_and_operand (&e);
734 : 16813 : if (m == MATCH_NO)
735 : 0 : gfc_error (expression_syntax);
736 : 16813 : if (m != MATCH_YES)
737 : : {
738 : 0 : gfc_free_expr (all);
739 : 0 : return MATCH_ERROR;
740 : : }
741 : :
742 : 16813 : total = gfc_and (all, e);
743 : 16813 : if (total == NULL)
744 : : {
745 : 0 : gfc_free_expr (all);
746 : 0 : gfc_free_expr (e);
747 : 0 : return MATCH_ERROR;
748 : : }
749 : :
750 : 16813 : all = total;
751 : 16813 : all->where = where;
752 : : }
753 : :
754 : 4453018 : *result = all;
755 : 4453018 : return MATCH_YES;
756 : : }
757 : :
758 : :
759 : : static match
760 : 5061422 : match_equiv_operand (gfc_expr **result)
761 : : {
762 : 5061422 : gfc_expr *all, *e, *total;
763 : 5061422 : locus where;
764 : 5061422 : match m;
765 : :
766 : 5061422 : m = match_or_operand (&all);
767 : 5061422 : if (m != MATCH_YES)
768 : : return m;
769 : :
770 : 4528529 : for (;;)
771 : : {
772 : 4453018 : if (!next_operator (INTRINSIC_OR))
773 : : break;
774 : 75511 : where = gfc_current_locus;
775 : :
776 : 75511 : m = match_or_operand (&e);
777 : 75511 : if (m == MATCH_NO)
778 : 0 : gfc_error (expression_syntax);
779 : 75511 : if (m != MATCH_YES)
780 : : {
781 : 0 : gfc_free_expr (all);
782 : 0 : return MATCH_ERROR;
783 : : }
784 : :
785 : 75511 : total = gfc_or (all, e);
786 : 75511 : if (total == NULL)
787 : : {
788 : 0 : gfc_free_expr (all);
789 : 0 : gfc_free_expr (e);
790 : 0 : return MATCH_ERROR;
791 : : }
792 : :
793 : 75511 : all = total;
794 : 75511 : all->where = where;
795 : : }
796 : :
797 : 4377507 : *result = all;
798 : 4377507 : return MATCH_YES;
799 : : }
800 : :
801 : :
802 : : /* Match a level 5 expression. */
803 : :
804 : : static match
805 : 5038205 : match_level_5 (gfc_expr **result)
806 : : {
807 : 5038205 : gfc_expr *all, *e, *total;
808 : 5038205 : locus where;
809 : 5038205 : match m;
810 : 5038205 : gfc_intrinsic_op i;
811 : :
812 : 5038205 : m = match_equiv_operand (&all);
813 : 5038205 : if (m != MATCH_YES)
814 : : return m;
815 : :
816 : 4400724 : for (;;)
817 : : {
818 : 4377507 : if (next_operator (INTRINSIC_EQV))
819 : : i = INTRINSIC_EQV;
820 : : else
821 : : {
822 : 4375535 : if (next_operator (INTRINSIC_NEQV))
823 : : i = INTRINSIC_NEQV;
824 : : else
825 : : break;
826 : : }
827 : :
828 : 23217 : where = gfc_current_locus;
829 : :
830 : 23217 : m = match_equiv_operand (&e);
831 : 23217 : if (m == MATCH_NO)
832 : 0 : gfc_error (expression_syntax);
833 : 23217 : if (m != MATCH_YES)
834 : : {
835 : 0 : gfc_free_expr (all);
836 : 0 : return MATCH_ERROR;
837 : : }
838 : :
839 : 23217 : if (i == INTRINSIC_EQV)
840 : 1972 : total = gfc_eqv (all, e);
841 : : else
842 : 21245 : total = gfc_neqv (all, e);
843 : :
844 : 23217 : if (total == NULL)
845 : : {
846 : 0 : gfc_free_expr (all);
847 : 0 : gfc_free_expr (e);
848 : 0 : return MATCH_ERROR;
849 : : }
850 : :
851 : 23217 : all = total;
852 : 23217 : all->where = where;
853 : : }
854 : :
855 : 4354290 : *result = all;
856 : 4354290 : return MATCH_YES;
857 : : }
858 : :
859 : :
860 : : /* Match an expression. At this level, we are stringing together
861 : : level 5 expressions separated by binary operators. */
862 : :
863 : : match
864 : 5038026 : gfc_match_expr (gfc_expr **result)
865 : : {
866 : 5038026 : gfc_expr *all, *e;
867 : 5038026 : gfc_user_op *uop;
868 : 5038026 : locus where;
869 : 5038026 : match m;
870 : :
871 : 5038026 : m = match_level_5 (&all);
872 : 5038026 : if (m != MATCH_YES)
873 : : return m;
874 : :
875 : 4354469 : for (;;)
876 : : {
877 : 4354290 : uop = NULL;
878 : 4354290 : m = match_defined_operator (&uop);
879 : 4354290 : if (m == MATCH_NO)
880 : : break;
881 : 215 : if (m == MATCH_ERROR)
882 : : {
883 : 36 : gfc_free_expr (all);
884 : 36 : return MATCH_ERROR;
885 : : }
886 : :
887 : 179 : where = gfc_current_locus;
888 : :
889 : 179 : m = match_level_5 (&e);
890 : 179 : if (m == MATCH_NO)
891 : 0 : gfc_error (expression_syntax);
892 : 179 : if (m != MATCH_YES)
893 : : {
894 : 0 : gfc_free_expr (all);
895 : 0 : return MATCH_ERROR;
896 : : }
897 : :
898 : 179 : all = gfc_get_operator_expr (&where, INTRINSIC_USER, all, e);
899 : 179 : all->value.op.uop = uop;
900 : : }
901 : :
902 : 4354075 : *result = all;
903 : 4354075 : return MATCH_YES;
904 : : }
|
