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