Branch data Line data Source code
1 : : /* Expression parser.
2 : : Copyright (C) 2000-2025 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 : 11598492 : gfc_match_defined_op_name (char *result, int error_flag)
37 : : {
38 : 11598492 : static const char * const badops[] = {
39 : : "and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt",
40 : : NULL
41 : : };
42 : :
43 : 11598492 : char name[GFC_MAX_SYMBOL_LEN + 1];
44 : 11598492 : locus old_loc;
45 : 11598492 : match m;
46 : 11598492 : int i;
47 : :
48 : 11598492 : old_loc = gfc_current_locus;
49 : :
50 : 11598492 : m = gfc_match (" . %n .", name);
51 : 11598492 : 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 : 57296 : if (strcmp (name, "true") == 0 || strcmp (name, "false") == 0)
58 : : {
59 : 56247 : if (error_flag)
60 : 0 : goto error;
61 : 56247 : gfc_current_locus = old_loc;
62 : 56247 : return MATCH_NO;
63 : : }
64 : :
65 : 12587 : for (i = 0; badops[i]; i++)
66 : 11539 : if (strcmp (badops[i], name) == 0)
67 : 1 : goto error;
68 : :
69 : 5697 : for (i = 0; name[i]; i++)
70 : 4685 : 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 : 1012 : strcpy (result, name);
77 : 1012 : 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 : 11596999 : match_defined_operator (gfc_user_op **result)
93 : : {
94 : 11596999 : char name[GFC_MAX_SYMBOL_LEN + 1];
95 : 11596999 : match m;
96 : :
97 : 11596999 : m = gfc_match_defined_op_name (name, 0);
98 : 11596999 : if (m != MATCH_YES)
99 : : return m;
100 : :
101 : 589 : *result = gfc_get_uop (name);
102 : 589 : 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 : 74880556 : next_operator (gfc_intrinsic_op t)
111 : : {
112 : 74880556 : gfc_intrinsic_op u;
113 : 74880556 : locus old_loc;
114 : :
115 : 74880556 : old_loc = gfc_current_locus;
116 : 74880556 : if (gfc_match_intrinsic_op (&u) == MATCH_YES && t == u)
117 : : return 1;
118 : :
119 : 74077592 : gfc_current_locus = old_loc;
120 : 74077592 : 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 : 54665 : gfc_get_parentheses (gfc_expr *e)
130 : : {
131 : 54665 : gfc_expr *e2;
132 : :
133 : 54665 : e2 = gfc_get_operator_expr (&e->where, INTRINSIC_PARENTHESES, e, NULL);
134 : 54665 : e2->ts = e->ts;
135 : 54665 : e2->rank = e->rank;
136 : 54665 : e2->corank = e->corank;
137 : :
138 : 54665 : return e2;
139 : : }
140 : :
141 : : /* Match a conditional expression. */
142 : :
143 : : static match
144 : 54559 : match_conditional (gfc_expr **result)
145 : : {
146 : 54559 : gfc_expr *condition, *true_expr, *false_expr;
147 : 54559 : locus where;
148 : 54559 : match m;
149 : :
150 : 54559 : where = gfc_current_locus;
151 : :
152 : 54559 : m = gfc_match_expr (&condition);
153 : 54559 : if (m != MATCH_YES)
154 : : {
155 : 70 : gfc_error (expression_syntax);
156 : 70 : return MATCH_ERROR;
157 : : }
158 : :
159 : 54489 : m = gfc_match_char ('?');
160 : 54489 : if (m != MATCH_YES)
161 : : {
162 : 54397 : *result = condition;
163 : 54397 : return MATCH_YES;
164 : : }
165 : 92 : 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 : 91 : gfc_gobble_whitespace ();
173 : 91 : m = gfc_match_expr (&true_expr);
174 : 91 : if (m != MATCH_YES)
175 : : {
176 : 0 : gfc_free_expr (condition);
177 : 0 : return m;
178 : : }
179 : :
180 : 91 : m = gfc_match_char (':');
181 : 91 : 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 : 90 : m = match_conditional (&false_expr);
190 : 90 : 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 : 90 : *result = gfc_get_conditional_expr (&where, condition, true_expr, false_expr);
198 : 90 : return MATCH_YES;
199 : : }
200 : :
201 : : /* Match a primary expression. */
202 : :
203 : : static match
204 : 6910069 : match_primary (gfc_expr **result)
205 : : {
206 : 6910069 : match m;
207 : 6910069 : gfc_expr *e;
208 : :
209 : 6910069 : m = gfc_match_literal_constant (result, 0);
210 : 6910069 : if (m != MATCH_NO)
211 : : return m;
212 : :
213 : 4259493 : m = gfc_match_array_constructor (result);
214 : 4259493 : if (m != MATCH_NO)
215 : : return m;
216 : :
217 : 4133571 : m = gfc_match_rvalue (result);
218 : 4133525 : if (m != MATCH_NO)
219 : : return m;
220 : :
221 : : /* Match an expression in parentheses. */
222 : 197880 : if (gfc_match_char ('(') != MATCH_YES)
223 : : return MATCH_NO;
224 : :
225 : 54469 : m = match_conditional (&e);
226 : 54469 : if (m != MATCH_YES)
227 : : return m;
228 : :
229 : 54397 : m = gfc_match_char (')');
230 : 54397 : if (m == MATCH_NO)
231 : 2384 : 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 : 54397 : *result = e->expr_type == EXPR_CONDITIONAL ? e : gfc_get_parentheses (e);
239 : :
240 : 54397 : if (m != MATCH_YES)
241 : : {
242 : 2384 : gfc_free_expr (*result);
243 : 2384 : return MATCH_ERROR;
244 : : }
245 : :
246 : : return MATCH_YES;
247 : : }
248 : :
249 : :
250 : : /* Match a level 1 expression. */
251 : :
252 : : static match
253 : 6910069 : match_level_1 (gfc_expr **result)
254 : : {
255 : 6910069 : gfc_user_op *uop;
256 : 6910069 : gfc_expr *e, *f;
257 : 6910069 : locus where;
258 : 6910069 : match m;
259 : :
260 : 6910069 : gfc_gobble_whitespace ();
261 : 6910069 : where = gfc_current_locus;
262 : 6910069 : uop = NULL;
263 : 6910069 : m = match_defined_operator (&uop);
264 : 6910069 : if (m == MATCH_ERROR)
265 : : return m;
266 : :
267 : 6910069 : m = match_primary (&e);
268 : 6910023 : if (m != MATCH_YES)
269 : : return m;
270 : :
271 : 6148149 : if (uop == NULL)
272 : 6147919 : *result = e;
273 : : else
274 : : {
275 : 230 : f = gfc_get_operator_expr (&where, INTRINSIC_USER, e, NULL);
276 : 230 : f->value.op.uop = uop;
277 : 230 : *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 : 13047274 : match_add_op (void)
305 : : {
306 : 13047274 : if (next_operator (INTRINSIC_MINUS))
307 : : return -1;
308 : 12841662 : if (next_operator (INTRINSIC_PLUS))
309 : 68208 : return 1;
310 : : return 0;
311 : : }
312 : :
313 : :
314 : : static match
315 : 6910069 : match_mult_operand (gfc_expr **result)
316 : : {
317 : : /* Workaround -Wmaybe-uninitialized false positive during
318 : : profiledbootstrap by initializing them. */
319 : 6910069 : gfc_expr *e = NULL, *exp, *r;
320 : 6910069 : locus where;
321 : 6910069 : match m;
322 : :
323 : 6910069 : m = match_level_1 (&e);
324 : 6910023 : if (m != MATCH_YES)
325 : : return m;
326 : :
327 : 6148149 : if (!next_operator (INTRINSIC_POWER))
328 : : {
329 : 6080693 : *result = e;
330 : 6080693 : return MATCH_YES;
331 : : }
332 : :
333 : 67456 : where = gfc_current_locus;
334 : :
335 : 67456 : m = match_ext_mult_operand (&exp);
336 : 67456 : if (m == MATCH_NO)
337 : 0 : gfc_error ("Expected exponent in expression at %C");
338 : 67456 : if (m != MATCH_YES)
339 : : {
340 : 1 : gfc_free_expr (e);
341 : 1 : return MATCH_ERROR;
342 : : }
343 : :
344 : 67455 : r = gfc_power (e, exp);
345 : 67455 : if (r == NULL)
346 : : {
347 : 0 : gfc_free_expr (e);
348 : 0 : gfc_free_expr (exp);
349 : 0 : return MATCH_ERROR;
350 : : }
351 : :
352 : 67455 : r->where = where;
353 : 67455 : *result = r;
354 : :
355 : 67455 : return MATCH_YES;
356 : : }
357 : :
358 : :
359 : : static match
360 : 207385 : match_ext_mult_operand (gfc_expr **result)
361 : : {
362 : 207385 : gfc_expr *all, *e;
363 : 207385 : locus where;
364 : 207385 : match m;
365 : 207385 : int i;
366 : :
367 : 207385 : where = gfc_current_locus;
368 : 207385 : i = match_add_op ();
369 : :
370 : 207385 : if (i == 0)
371 : 207372 : 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 : 6702697 : match_add_operand (gfc_expr **result)
406 : : {
407 : 6702697 : gfc_expr *all, *e, *total;
408 : 6702697 : locus where, old_loc;
409 : 6702697 : match m;
410 : 6702697 : gfc_intrinsic_op i;
411 : :
412 : 6702697 : m = match_mult_operand (&all);
413 : 6702651 : if (m != MATCH_YES)
414 : : return m;
415 : :
416 : 6162012 : for (;;)
417 : : {
418 : : /* Build up a string of products or quotients. */
419 : :
420 : 6080685 : old_loc = gfc_current_locus;
421 : :
422 : 6080685 : if (next_operator (INTRINSIC_TIMES))
423 : : i = INTRINSIC_TIMES;
424 : : else
425 : : {
426 : 6012340 : if (next_operator (INTRINSIC_DIVIDE))
427 : : i = INTRINSIC_DIVIDE;
428 : : else
429 : : break;
430 : : }
431 : :
432 : 139916 : where = gfc_current_locus;
433 : :
434 : 139916 : m = match_ext_mult_operand (&e);
435 : 139916 : if (m == MATCH_NO)
436 : : {
437 : 58581 : gfc_current_locus = old_loc;
438 : 58581 : break;
439 : : }
440 : :
441 : 81335 : if (m == MATCH_ERROR)
442 : : {
443 : 0 : gfc_free_expr (all);
444 : 0 : return MATCH_ERROR;
445 : : }
446 : :
447 : 81335 : if (i == INTRINSIC_TIMES)
448 : 68345 : total = gfc_multiply (all, e);
449 : : else
450 : 12990 : total = gfc_divide (all, e);
451 : :
452 : 81335 : if (total == NULL)
453 : : {
454 : 8 : gfc_free_expr (all);
455 : 8 : gfc_free_expr (e);
456 : 8 : return MATCH_ERROR;
457 : : }
458 : :
459 : 81327 : all = total;
460 : 81327 : all->where = where;
461 : : }
462 : :
463 : 5999350 : *result = all;
464 : 5999350 : return MATCH_YES;
465 : : }
466 : :
467 : :
468 : : static match
469 : 273807 : match_ext_add_operand (gfc_expr **result)
470 : : {
471 : 273807 : gfc_expr *all, *e;
472 : 273807 : locus where;
473 : 273807 : match m;
474 : 273807 : int i;
475 : :
476 : 273807 : where = gfc_current_locus;
477 : 273807 : i = match_add_op ();
478 : :
479 : 273807 : if (i == 0)
480 : 273807 : 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 : 6566733 : match_level_2 (gfc_expr **result)
517 : : {
518 : 6566733 : gfc_expr *all, *e, *total;
519 : 6566733 : locus where;
520 : 6566733 : match m;
521 : 6566733 : int i;
522 : :
523 : 6566733 : where = gfc_current_locus;
524 : 6566733 : i = match_add_op ();
525 : :
526 : 6566733 : if (i != 0)
527 : : {
528 : 137843 : m = match_ext_add_operand (&e);
529 : 137843 : if (m == MATCH_NO)
530 : : {
531 : 8 : gfc_error (expression_syntax);
532 : 8 : m = MATCH_ERROR;
533 : : }
534 : : }
535 : : else
536 : 6428890 : m = match_add_operand (&e);
537 : :
538 : 6566687 : if (m != MATCH_YES)
539 : 703298 : return m;
540 : :
541 : 5863389 : if (i == 0)
542 : 5725560 : all = e;
543 : : else
544 : : {
545 : 137829 : if (i == -1)
546 : 137459 : all = gfc_uminus (e);
547 : : else
548 : 370 : all = gfc_uplus (e);
549 : :
550 : 137829 : if (all == NULL)
551 : : {
552 : 1 : gfc_free_expr (e);
553 : 1 : return MATCH_ERROR;
554 : : }
555 : : }
556 : :
557 : 5863388 : all->where = where;
558 : :
559 : : /* Append add-operands to the sum. */
560 : :
561 : 6135310 : for (;;)
562 : : {
563 : 5999349 : where = gfc_current_locus;
564 : 5999349 : i = match_add_op ();
565 : 5999349 : if (i == 0)
566 : : break;
567 : :
568 : 135964 : m = match_ext_add_operand (&e);
569 : 135964 : if (m == MATCH_NO)
570 : 0 : gfc_error (expression_syntax);
571 : 135964 : if (m != MATCH_YES)
572 : : {
573 : 3 : gfc_free_expr (all);
574 : 3 : return MATCH_ERROR;
575 : : }
576 : :
577 : 135961 : if (i == -1)
578 : 68132 : total = gfc_subtract (all, e);
579 : : else
580 : 67829 : total = gfc_add (all, e);
581 : :
582 : 135961 : if (total == NULL)
583 : : {
584 : 0 : gfc_free_expr (all);
585 : 0 : gfc_free_expr (e);
586 : 0 : return MATCH_ERROR;
587 : : }
588 : :
589 : 135961 : all = total;
590 : 135961 : all->where = where;
591 : : }
592 : :
593 : 5863385 : *result = all;
594 : 5863385 : return MATCH_YES;
595 : : }
596 : :
597 : :
598 : : /* Match a level three expression. */
599 : :
600 : : static match
601 : 6561561 : match_level_3 (gfc_expr **result)
602 : : {
603 : 6561561 : gfc_expr *all, *e, *total = NULL;
604 : 6561561 : locus where;
605 : 6561561 : match m;
606 : :
607 : 6561561 : m = match_level_2 (&all);
608 : 6561515 : if (m != MATCH_YES)
609 : : return m;
610 : :
611 : 5868549 : for (;;)
612 : : {
613 : 5863384 : if (!next_operator (INTRINSIC_CONCAT))
614 : : break;
615 : :
616 : 5172 : where = gfc_current_locus;
617 : :
618 : 5172 : m = match_level_2 (&e);
619 : 5172 : if (m == MATCH_NO)
620 : 0 : gfc_error (expression_syntax);
621 : 5172 : if (m != MATCH_YES)
622 : : {
623 : 6 : gfc_free_expr (all);
624 : 6 : return MATCH_ERROR;
625 : : }
626 : :
627 : 5166 : total = gfc_concat (all, e);
628 : 5166 : if (total == NULL)
629 : : {
630 : 1 : gfc_free_expr (all);
631 : 1 : gfc_free_expr (e);
632 : 1 : return MATCH_ERROR;
633 : : }
634 : :
635 : 5165 : all = total;
636 : 5165 : all->where = where;
637 : : }
638 : :
639 : 5858212 : *result = all;
640 : 5858212 : return MATCH_YES;
641 : : }
642 : :
643 : :
644 : : /* Match a level 4 expression. */
645 : :
646 : : static match
647 : 5630141 : match_level_4 (gfc_expr **result)
648 : : {
649 : 5630141 : gfc_expr *left, *right, *r;
650 : 5630141 : gfc_intrinsic_op i;
651 : 5630141 : locus old_loc;
652 : 5630141 : locus where;
653 : 5630141 : match m;
654 : :
655 : 5630141 : m = match_level_3 (&left);
656 : 5630095 : if (m != MATCH_YES)
657 : : return m;
658 : :
659 : 4926792 : old_loc = gfc_current_locus;
660 : :
661 : 4926792 : if (gfc_match_intrinsic_op (&i) != MATCH_YES)
662 : : {
663 : 3873880 : *result = left;
664 : 3873880 : return MATCH_YES;
665 : : }
666 : :
667 : 1052912 : if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE
668 : 407929 : && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT
669 : 364021 : && i != INTRINSIC_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS
670 : 137156 : && i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS)
671 : : {
672 : 121492 : gfc_current_locus = old_loc;
673 : 121492 : *result = left;
674 : 121492 : return MATCH_YES;
675 : : }
676 : :
677 : 931420 : where = gfc_current_locus;
678 : :
679 : 931420 : m = match_level_3 (&right);
680 : 931420 : if (m == MATCH_NO)
681 : 0 : gfc_error (expression_syntax);
682 : 931420 : if (m != MATCH_YES)
683 : : {
684 : 0 : gfc_free_expr (left);
685 : 0 : return MATCH_ERROR;
686 : : }
687 : :
688 : 931420 : switch (i)
689 : : {
690 : 32489 : case INTRINSIC_EQ:
691 : 32489 : case INTRINSIC_EQ_OS:
692 : 32489 : r = gfc_eq (left, right, i);
693 : 32489 : break;
694 : :
695 : 834701 : case INTRINSIC_NE:
696 : 834701 : case INTRINSIC_NE_OS:
697 : 834701 : r = gfc_ne (left, right, i);
698 : 834701 : break;
699 : :
700 : 11078 : case INTRINSIC_LT:
701 : 11078 : case INTRINSIC_LT_OS:
702 : 11078 : r = gfc_lt (left, right, i);
703 : 11078 : break;
704 : :
705 : 7383 : case INTRINSIC_LE:
706 : 7383 : case INTRINSIC_LE_OS:
707 : 7383 : r = gfc_le (left, right, i);
708 : 7383 : break;
709 : :
710 : 41111 : case INTRINSIC_GT:
711 : 41111 : case INTRINSIC_GT_OS:
712 : 41111 : r = gfc_gt (left, right, i);
713 : 41111 : break;
714 : :
715 : 4658 : case INTRINSIC_GE:
716 : 4658 : case INTRINSIC_GE_OS:
717 : 4658 : r = gfc_ge (left, right, i);
718 : 4658 : break;
719 : :
720 : 0 : default:
721 : 0 : gfc_internal_error ("match_level_4(): Bad operator");
722 : : }
723 : :
724 : 931420 : if (r == NULL)
725 : : {
726 : 0 : gfc_free_expr (left);
727 : 0 : gfc_free_expr (right);
728 : 0 : return MATCH_ERROR;
729 : : }
730 : :
731 : 931420 : r->where = where;
732 : 931420 : *result = r;
733 : :
734 : 931420 : return MATCH_YES;
735 : : }
736 : :
737 : :
738 : : static match
739 : 5630141 : match_and_operand (gfc_expr **result)
740 : : {
741 : 5630141 : gfc_expr *e, *r;
742 : 5630141 : locus where;
743 : 5630141 : match m;
744 : 5630141 : int i;
745 : :
746 : 5630141 : i = next_operator (INTRINSIC_NOT);
747 : 5630141 : where = gfc_current_locus;
748 : :
749 : 5630141 : m = match_level_4 (&e);
750 : 5630095 : if (m != MATCH_YES)
751 : : return m;
752 : :
753 : 4926792 : r = e;
754 : 4926792 : if (i)
755 : : {
756 : 76738 : r = gfc_not (e);
757 : 76738 : if (r == NULL)
758 : : {
759 : 0 : gfc_free_expr (e);
760 : 0 : return MATCH_ERROR;
761 : : }
762 : : }
763 : :
764 : 4926792 : r->where = where;
765 : 4926792 : *result = r;
766 : :
767 : 4926792 : return MATCH_YES;
768 : : }
769 : :
770 : :
771 : : static match
772 : 5613368 : match_or_operand (gfc_expr **result)
773 : : {
774 : 5613368 : gfc_expr *all, *e, *total;
775 : 5613368 : locus where;
776 : 5613368 : match m;
777 : :
778 : 5613368 : m = match_and_operand (&all);
779 : 5613322 : if (m != MATCH_YES)
780 : : return m;
781 : :
782 : 4943565 : for (;;)
783 : : {
784 : 4926792 : if (!next_operator (INTRINSIC_AND))
785 : : break;
786 : 16773 : where = gfc_current_locus;
787 : :
788 : 16773 : m = match_and_operand (&e);
789 : 16773 : if (m == MATCH_NO)
790 : 0 : gfc_error (expression_syntax);
791 : 16773 : if (m != MATCH_YES)
792 : : {
793 : 0 : gfc_free_expr (all);
794 : 0 : return MATCH_ERROR;
795 : : }
796 : :
797 : 16773 : total = gfc_and (all, e);
798 : 16773 : if (total == NULL)
799 : : {
800 : 0 : gfc_free_expr (all);
801 : 0 : gfc_free_expr (e);
802 : 0 : return MATCH_ERROR;
803 : : }
804 : :
805 : 16773 : all = total;
806 : 16773 : all->where = where;
807 : : }
808 : :
809 : 4910019 : *result = all;
810 : 4910019 : return MATCH_YES;
811 : : }
812 : :
813 : :
814 : : static match
815 : 5414394 : match_equiv_operand (gfc_expr **result)
816 : : {
817 : 5414394 : gfc_expr *all, *e, *total;
818 : 5414394 : locus where;
819 : 5414394 : match m;
820 : :
821 : 5414394 : m = match_or_operand (&all);
822 : 5414348 : if (m != MATCH_YES)
823 : : return m;
824 : :
825 : 5108993 : for (;;)
826 : : {
827 : 4910019 : if (!next_operator (INTRINSIC_OR))
828 : : break;
829 : 198974 : where = gfc_current_locus;
830 : :
831 : 198974 : m = match_or_operand (&e);
832 : 198974 : if (m == MATCH_NO)
833 : 0 : gfc_error (expression_syntax);
834 : 198974 : if (m != MATCH_YES)
835 : : {
836 : 0 : gfc_free_expr (all);
837 : 0 : return MATCH_ERROR;
838 : : }
839 : :
840 : 198974 : total = gfc_or (all, e);
841 : 198974 : if (total == NULL)
842 : : {
843 : 0 : gfc_free_expr (all);
844 : 0 : gfc_free_expr (e);
845 : 0 : return MATCH_ERROR;
846 : : }
847 : :
848 : 198974 : all = total;
849 : 198974 : all->where = where;
850 : : }
851 : :
852 : 4711045 : *result = all;
853 : 4711045 : return MATCH_YES;
854 : : }
855 : :
856 : :
857 : : /* Match a level 5 expression. */
858 : :
859 : : static match
860 : 5390279 : match_level_5 (gfc_expr **result)
861 : : {
862 : 5390279 : gfc_expr *all, *e, *total;
863 : 5390279 : locus where;
864 : 5390279 : match m;
865 : 5390279 : gfc_intrinsic_op i;
866 : :
867 : 5390279 : m = match_equiv_operand (&all);
868 : 5390233 : if (m != MATCH_YES)
869 : : return m;
870 : :
871 : 4735160 : for (;;)
872 : : {
873 : 4711045 : if (next_operator (INTRINSIC_EQV))
874 : : i = INTRINSIC_EQV;
875 : : else
876 : : {
877 : 4709065 : if (next_operator (INTRINSIC_NEQV))
878 : : i = INTRINSIC_NEQV;
879 : : else
880 : : break;
881 : : }
882 : :
883 : 24115 : where = gfc_current_locus;
884 : :
885 : 24115 : m = match_equiv_operand (&e);
886 : 24115 : if (m == MATCH_NO)
887 : 0 : gfc_error (expression_syntax);
888 : 24115 : if (m != MATCH_YES)
889 : : {
890 : 0 : gfc_free_expr (all);
891 : 0 : return MATCH_ERROR;
892 : : }
893 : :
894 : 24115 : if (i == INTRINSIC_EQV)
895 : 1980 : total = gfc_eqv (all, e);
896 : : else
897 : 22135 : total = gfc_neqv (all, e);
898 : :
899 : 24115 : if (total == NULL)
900 : : {
901 : 0 : gfc_free_expr (all);
902 : 0 : gfc_free_expr (e);
903 : 0 : return MATCH_ERROR;
904 : : }
905 : :
906 : 24115 : all = total;
907 : 24115 : all->where = where;
908 : : }
909 : :
910 : 4686930 : *result = all;
911 : 4686930 : 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 : 5389921 : gfc_match_expr (gfc_expr **result)
920 : : {
921 : 5389921 : gfc_expr *all, *e;
922 : 5389921 : gfc_user_op *uop;
923 : 5389921 : locus where;
924 : 5389921 : match m;
925 : :
926 : 5389921 : m = match_level_5 (&all);
927 : 5389875 : if (m != MATCH_YES)
928 : : return m;
929 : :
930 : 4687288 : for (;;)
931 : : {
932 : 4686930 : uop = NULL;
933 : 4686930 : m = match_defined_operator (&uop);
934 : 4686930 : 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 : 4686536 : *result = all;
958 : 4686536 : return MATCH_YES;
959 : : }
|
