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