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