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