integration/gcc/fortran/matchexp.c

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