gcc/fortran/matchexp.c

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