1/* Expression parser. 2 Copyright (C) 2000-2020 Free Software Foundation, Inc. 3 Contributed by Andy Vaught 4 5This file is part of GCC. 6 7GCC is free software; you can redistribute it and/or modify it under 8the terms of the GNU General Public License as published by the Free 9Software Foundation; either version 3, or (at your option) any later 10version. 11 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13WARRANTY; without even the implied warranty of MERCHANTABILITY or 14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15for more details. 16 17You should have received a copy of the GNU General Public License 18along 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 28static 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 35match 36gfc_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 79error: 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 91static match 92match_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 109static int 110next_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.c to generate 126 temporaries. */ 127 128gfc_expr * 129gfc_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 143static match 144match_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 188syntax: 189 gfc_error (expression_syntax); 190 return MATCH_ERROR; 191} 192 193 194/* Match a level 1 expression. */ 195 196static match 197match_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 244static match match_ext_mult_operand (gfc_expr **result); 245static match match_ext_add_operand (gfc_expr **result); 246 247static int 248match_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 258static match 259match_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 303static match 304match_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 348static match 349match_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 412static match 413match_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 459static match 460match_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 544static match 545match_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 590static match 591match_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 682static match 683match_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 715static match 716match_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 758static match 759match_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 803static match 804match_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 862match 863gfc_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