gcc/fortran/matchexp.cc

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