gcc/fortran/matchexp.c

   1 /* Expression parser.
   2    Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
   3    Contributed by Andy Vaught
   4
   5 This file is part of GNU G95.
   6
   7 GNU G95 is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU G95 is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU G95; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330,
  20 Boston, MA 02111-1307, USA.  */
  21
  22
  23 #include "config.h"
  24 #include <string.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_set_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_set_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_set_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->operator = operator;
 183   new->where = *where;
 184
 185   new->op1 = op1;
 186   new->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->uop = uop;
 218       *result = f;
 219     }
 220
 221   return MATCH_YES;
 222 }
 223
 224
 225 static match
 226 match_mult_operand (gfc_expr ** result)
 227 {
 228   gfc_expr *e, *exp, *r;
 229   locus where;
 230   match m;
 231
 232   m = match_level_1 (&e);
 233   if (m != MATCH_YES)
 234     return m;
 235
 236   if (!next_operator (INTRINSIC_POWER))
 237     {
 238       *result = e;
 239       return MATCH_YES;
 240     }
 241
 242   where = *gfc_current_locus ();
 243
 244   m = match_mult_operand (&exp);
 245   if (m == MATCH_NO)
 246     gfc_error ("Expected exponent in expression at %C");
 247   if (m != MATCH_YES)
 248     {
 249       gfc_free_expr (e);
 250       return MATCH_ERROR;
 251     }
 252
 253   r = gfc_power (e, exp);
 254   if (r == NULL)
 255     {
 256       gfc_free_expr (e);
 257       gfc_free_expr (exp);
 258       return MATCH_ERROR;
 259     }
 260
 261   r->where = where;
 262   *result = r;
 263
 264   return MATCH_YES;
 265 }
 266
 267
 268 static match
 269 match_add_operand (gfc_expr ** result)
 270 {
 271   gfc_expr *all, *e, *total;
 272   locus where, old_loc;
 273   match m;
 274   gfc_intrinsic_op i;
 275
 276   m = match_mult_operand (&all);
 277   if (m != MATCH_YES)
 278     return m;
 279
 280   for (;;)
 281     {
 282       /* Build up a string of products or quotients.  */
 283
 284       old_loc = *gfc_current_locus ();
 285
 286       if (next_operator (INTRINSIC_TIMES))
 287         i = INTRINSIC_TIMES;
 288       else
 289         {
 290           if (next_operator (INTRINSIC_DIVIDE))
 291             i = INTRINSIC_DIVIDE;
 292           else
 293             break;
 294         }
 295
 296       where = *gfc_current_locus ();
 297
 298       m = match_mult_operand (&e);
 299       if (m == MATCH_NO)
 300         {
 301           gfc_set_locus (&old_loc);
 302           break;
 303         }
 304
 305       if (m == MATCH_ERROR)
 306         {
 307           gfc_free_expr (all);
 308           return MATCH_ERROR;
 309         }
 310
 311       if (i == INTRINSIC_TIMES)
 312         total = gfc_multiply (all, e);
 313       else
 314         total = gfc_divide (all, e);
 315
 316       if (total == NULL)
 317         {
 318           gfc_free_expr (all);
 319           gfc_free_expr (e);
 320           return MATCH_ERROR;
 321         }
 322
 323       all = total;
 324       all->where = where;
 325     }
 326
 327   *result = all;
 328   return MATCH_YES;
 329 }
 330
 331
 332 static int
 333 match_add_op (void)
 334 {
 335
 336   if (next_operator (INTRINSIC_MINUS))
 337     return -1;
 338   if (next_operator (INTRINSIC_PLUS))
 339     return 1;
 340   return 0;
 341 }
 342
 343
 344 /* Match a level 2 expression.  */
 345
 346 static match
 347 match_level_2 (gfc_expr ** result)
 348 {
 349   gfc_expr *all, *e, *total;
 350   locus where;
 351   match m;
 352   int i;
 353
 354   where = *gfc_current_locus ();
 355   i = match_add_op ();
 356
 357   m = match_add_operand (&e);
 358   if (i != 0 && m == MATCH_NO)
 359     {
 360       gfc_error (expression_syntax);
 361       m = MATCH_ERROR;
 362     }
 363
 364   if (m != MATCH_YES)
 365     return m;
 366
 367   if (i == 0)
 368     all = e;
 369   else
 370     {
 371       if (i == -1)
 372         all = gfc_uminus (e);
 373       else
 374         all = gfc_uplus (e);
 375
 376       if (all == NULL)
 377         {
 378           gfc_free_expr (e);
 379           return MATCH_ERROR;
 380         }
 381     }
 382
 383   all->where = where;
 384
 385 /* Append add-operands to the sum */
 386
 387   for (;;)
 388     {
 389       where = *gfc_current_locus ();
 390       i = match_add_op ();
 391       if (i == 0)
 392         break;
 393
 394       m = match_add_operand (&e);
 395       if (m == MATCH_NO)
 396         gfc_error (expression_syntax);
 397       if (m != MATCH_YES)
 398         {
 399           gfc_free_expr (all);
 400           return MATCH_ERROR;
 401         }
 402
 403       if (i == -1)
 404         total = gfc_subtract (all, e);
 405       else
 406         total = gfc_add (all, e);
 407
 408       if (total == NULL)
 409         {
 410           gfc_free_expr (all);
 411           gfc_free_expr (e);
 412           return MATCH_ERROR;
 413         }
 414
 415       all = total;
 416       all->where = where;
 417     }
 418
 419   *result = all;
 420   return MATCH_YES;
 421 }
 422
 423
 424 /* Match a level three expression.  */
 425
 426 static match
 427 match_level_3 (gfc_expr ** result)
 428 {
 429   gfc_expr *all, *e, *total;
 430   locus where;
 431   match m;
 432
 433   m = match_level_2 (&all);
 434   if (m != MATCH_YES)
 435     return m;
 436
 437   for (;;)
 438     {
 439       if (!next_operator (INTRINSIC_CONCAT))
 440         break;
 441
 442       where = *gfc_current_locus ();
 443
 444       m = match_level_2 (&e);
 445       if (m == MATCH_NO)
 446         {
 447           gfc_error (expression_syntax);
 448           gfc_free_expr (all);
 449         }
 450       if (m != MATCH_YES)
 451         return MATCH_ERROR;
 452
 453       total = gfc_concat (all, e);
 454       if (total == NULL)
 455         {
 456           gfc_free_expr (all);
 457           gfc_free_expr (e);
 458           return MATCH_ERROR;
 459         }
 460
 461       all = total;
 462       all->where = where;
 463     }
 464
 465   *result = all;
 466   return MATCH_YES;
 467 }
 468
 469
 470 /* Match a level 4 expression.  */
 471
 472 static match
 473 match_level_4 (gfc_expr ** result)
 474 {
 475   gfc_expr *left, *right, *r;
 476   gfc_intrinsic_op i;
 477   locus old_loc;
 478   locus where;
 479   match m;
 480
 481   m = match_level_3 (&left);
 482   if (m != MATCH_YES)
 483     return m;
 484
 485   old_loc = *gfc_current_locus ();
 486
 487   if (gfc_match_intrinsic_op (&i) != MATCH_YES)
 488     {
 489       *result = left;
 490       return MATCH_YES;
 491     }
 492
 493   if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE
 494       && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT)
 495     {
 496       gfc_set_locus (&old_loc);
 497       *result = left;
 498       return MATCH_YES;
 499     }
 500
 501   where = *gfc_current_locus ();
 502
 503   m = match_level_3 (&right);
 504   if (m == MATCH_NO)
 505     gfc_error (expression_syntax);
 506   if (m != MATCH_YES)
 507     {
 508       gfc_free_expr (left);
 509       return MATCH_ERROR;
 510     }
 511
 512   switch (i)
 513     {
 514     case INTRINSIC_EQ:
 515       r = gfc_eq (left, right);
 516       break;
 517
 518     case INTRINSIC_NE:
 519       r = gfc_ne (left, right);
 520       break;
 521
 522     case INTRINSIC_LT:
 523       r = gfc_lt (left, right);
 524       break;
 525
 526     case INTRINSIC_LE:
 527       r = gfc_le (left, right);
 528       break;
 529
 530     case INTRINSIC_GT:
 531       r = gfc_gt (left, right);
 532       break;
 533
 534     case INTRINSIC_GE:
 535       r = gfc_ge (left, right);
 536       break;
 537
 538     default:
 539       gfc_internal_error ("match_level_4(): Bad operator");
 540     }
 541
 542   if (r == NULL)
 543     {
 544       gfc_free_expr (left);
 545       gfc_free_expr (right);
 546       return MATCH_ERROR;
 547     }
 548
 549   r->where = where;
 550   *result = r;
 551
 552   return MATCH_YES;
 553 }
 554
 555
 556 static match
 557 match_and_operand (gfc_expr ** result)
 558 {
 559   gfc_expr *e, *r;
 560   locus where;
 561   match m;
 562   int i;
 563
 564   i = next_operator (INTRINSIC_NOT);
 565   where = *gfc_current_locus ();
 566
 567   m = match_level_4 (&e);
 568   if (m != MATCH_YES)
 569     return m;
 570
 571   r = e;
 572   if (i)
 573     {
 574       r = gfc_not (e);
 575       if (r == NULL)
 576         {
 577           gfc_free_expr (e);
 578           return MATCH_ERROR;
 579         }
 580     }
 581
 582   r->where = where;
 583   *result = r;
 584
 585   return MATCH_YES;
 586 }
 587
 588
 589 static match
 590 match_or_operand (gfc_expr ** result)
 591 {
 592   gfc_expr *all, *e, *total;
 593   locus where;
 594   match m;
 595
 596   m = match_and_operand (&all);
 597   if (m != MATCH_YES)
 598     return m;
 599
 600   for (;;)
 601     {
 602       if (!next_operator (INTRINSIC_AND))
 603         break;
 604       where = *gfc_current_locus ();
 605
 606       m = match_and_operand (&e);
 607       if (m == MATCH_NO)
 608         gfc_error (expression_syntax);
 609       if (m != MATCH_YES)
 610         {
 611           gfc_free_expr (all);
 612           return MATCH_ERROR;
 613         }
 614
 615       total = gfc_and (all, e);
 616       if (total == NULL)
 617         {
 618           gfc_free_expr (all);
 619           gfc_free_expr (e);
 620           return MATCH_ERROR;
 621         }
 622
 623       all = total;
 624       all->where = where;
 625     }
 626
 627   *result = all;
 628   return MATCH_YES;
 629 }
 630
 631
 632 static match
 633 match_equiv_operand (gfc_expr ** result)
 634 {
 635   gfc_expr *all, *e, *total;
 636   locus where;
 637   match m;
 638
 639   m = match_or_operand (&all);
 640   if (m != MATCH_YES)
 641     return m;
 642
 643   for (;;)
 644     {
 645       if (!next_operator (INTRINSIC_OR))
 646         break;
 647       where = *gfc_current_locus ();
 648
 649       m = match_or_operand (&e);
 650       if (m == MATCH_NO)
 651         gfc_error (expression_syntax);
 652       if (m != MATCH_YES)
 653         {
 654           gfc_free_expr (all);
 655           return MATCH_ERROR;
 656         }
 657
 658       total = gfc_or (all, e);
 659       if (total == NULL)
 660         {
 661           gfc_free_expr (all);
 662           gfc_free_expr (e);
 663           return MATCH_ERROR;
 664         }
 665
 666       all = total;
 667       all->where = where;
 668     }
 669
 670   *result = all;
 671   return MATCH_YES;
 672 }
 673
 674
 675 /* Match a level 5 expression.  */
 676
 677 static match
 678 match_level_5 (gfc_expr ** result)
 679 {
 680   gfc_expr *all, *e, *total;
 681   locus where;
 682   match m;
 683   gfc_intrinsic_op i;
 684
 685   m = match_equiv_operand (&all);
 686   if (m != MATCH_YES)
 687     return m;
 688
 689   for (;;)
 690     {
 691       if (next_operator (INTRINSIC_EQV))
 692         i = INTRINSIC_EQV;
 693       else
 694         {
 695           if (next_operator (INTRINSIC_NEQV))
 696             i = INTRINSIC_NEQV;
 697           else
 698             break;
 699         }
 700
 701       where = *gfc_current_locus ();
 702
 703       m = match_equiv_operand (&e);
 704       if (m == MATCH_NO)
 705         gfc_error (expression_syntax);
 706       if (m != MATCH_YES)
 707         {
 708           gfc_free_expr (all);
 709           return MATCH_ERROR;
 710         }
 711
 712       if (i == INTRINSIC_EQV)
 713         total = gfc_eqv (all, e);
 714       else
 715         total = gfc_neqv (all, e);
 716
 717       if (total == NULL)
 718         {
 719           gfc_free_expr (all);
 720           gfc_free_expr (e);
 721           return MATCH_ERROR;
 722         }
 723
 724       all = total;
 725       all->where = where;
 726     }
 727
 728   *result = all;
 729   return MATCH_YES;
 730 }
 731
 732
 733 /* Match an expression.  At this level, we are stringing together
 734    level 5 expressions separated by binary operators.  */
 735
 736 match
 737 gfc_match_expr (gfc_expr ** result)
 738 {
 739   gfc_expr *all, *e;
 740   gfc_user_op *uop;
 741   locus where;
 742   match m;
 743
 744   m = match_level_5 (&all);
 745   if (m != MATCH_YES)
 746     return m;
 747
 748   for (;;)
 749     {
 750       m = match_defined_operator (&uop);
 751       if (m == MATCH_NO)
 752         break;
 753       if (m == MATCH_ERROR)
 754         {
 755           gfc_free_expr (all);
 756           return MATCH_ERROR;
 757         }
 758
 759       where = *gfc_current_locus ();
 760
 761       m = match_level_5 (&e);
 762       if (m == MATCH_NO)
 763         gfc_error (expression_syntax);
 764       if (m != MATCH_YES)
 765         {
 766           gfc_free_expr (all);
 767           return MATCH_ERROR;
 768         }
 769
 770       all = build_node (INTRINSIC_USER, &where, all, e);
 771       all->uop = uop;
 772     }
 773
 774   *result = all;
 775   return MATCH_YES;
 776 }