gcc/fortran/matchexp.c

   1 /* Expression parser.
   2    Copyright (C) 2000-2017 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.c 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
 137   return e2;
 138 }
 139
 140
 141 /* Match a primary expression.  */
 142
 143 static match
 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
 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
 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
 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
 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
 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
 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
 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
 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
 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
 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
 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
 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
 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
 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 }