gcc/fortran/matchexp.c

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