gcc/fortran/matchexp.c

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