gcc/fortran/matchexp.c

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