gcc/fortran/match.c

   1 /* Matching subroutines in all sizes, shapes and colors.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
   3    2009, 2010, 2011
   4    Free Software Foundation, Inc.
   5    Contributed by Andy Vaught
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  22
  23 #include "config.h"
  24 #include "system.h"
  25 #include "flags.h"
  26 #include "gfortran.h"
  27 #include "match.h"
  28 #include "parse.h"
  29
  30 int gfc_matching_ptr_assignment = 0;
  31 int gfc_matching_procptr_assignment = 0;
  32 bool gfc_matching_prefix = false;
  33
  34 /* Stack of SELECT TYPE statements.  */
  35 gfc_select_type_stack *select_type_stack = NULL;
  36
  37 /* For debugging and diagnostic purposes.  Return the textual representation
  38    of the intrinsic operator OP.  */
  39 const char *
  40 gfc_op2string (gfc_intrinsic_op op)
  41 {
  42   switch (op)
  43     {
  44     case INTRINSIC_UPLUS:
  45     case INTRINSIC_PLUS:
  46       return "+";
  47
  48     case INTRINSIC_UMINUS:
  49     case INTRINSIC_MINUS:
  50       return "-";
  51
  52     case INTRINSIC_POWER:
  53       return "**";
  54     case INTRINSIC_CONCAT:
  55       return "//";
  56     case INTRINSIC_TIMES:
  57       return "*";
  58     case INTRINSIC_DIVIDE:
  59       return "/";
  60
  61     case INTRINSIC_AND:
  62       return ".and.";
  63     case INTRINSIC_OR:
  64       return ".or.";
  65     case INTRINSIC_EQV:
  66       return ".eqv.";
  67     case INTRINSIC_NEQV:
  68       return ".neqv.";
  69
  70     case INTRINSIC_EQ_OS:
  71       return ".eq.";
  72     case INTRINSIC_EQ:
  73       return "==";
  74     case INTRINSIC_NE_OS:
  75       return ".ne.";
  76     case INTRINSIC_NE:
  77       return "/=";
  78     case INTRINSIC_GE_OS:
  79       return ".ge.";
  80     case INTRINSIC_GE:
  81       return ">=";
  82     case INTRINSIC_LE_OS:
  83       return ".le.";
  84     case INTRINSIC_LE:
  85       return "<=";
  86     case INTRINSIC_LT_OS:
  87       return ".lt.";
  88     case INTRINSIC_LT:
  89       return "<";
  90     case INTRINSIC_GT_OS:
  91       return ".gt.";
  92     case INTRINSIC_GT:
  93       return ">";
  94     case INTRINSIC_NOT:
  95       return ".not.";
  96
  97     case INTRINSIC_ASSIGN:
  98       return "=";
  99
 100     case INTRINSIC_PARENTHESES:
 101       return "parens";
 102
 103     default:
 104       break;
 105     }
 106
 107   gfc_internal_error ("gfc_op2string(): Bad code");
 108   /* Not reached.  */
 109 }
 110
 111
 112 /******************** Generic matching subroutines ************************/
 113
 114 /* This function scans the current statement counting the opened and closed
 115    parenthesis to make sure they are balanced.  */
 116
 117 match
 118 gfc_match_parens (void)
 119 {
 120   locus old_loc, where;
 121   int count;
 122   gfc_instring instring;
 123   gfc_char_t c, quote;
 124
 125   old_loc = gfc_current_locus;
 126   count = 0;
 127   instring = NONSTRING;
 128   quote = ' ';
 129
 130   for (;;)
 131     {
 132       c = gfc_next_char_literal (instring);
 133       if (c == '\n')
 134         break;
 135       if (quote == ' ' && ((c == '\'') || (c == '"')))
 136         {
 137           quote = c;
 138           instring = INSTRING_WARN;
 139           continue;
 140         }
 141       if (quote != ' ' && c == quote)
 142         {
 143           quote = ' ';
 144           instring = NONSTRING;
 145           continue;
 146         }
 147
 148       if (c == '(' && quote == ' ')
 149         {
 150           count++;
 151           where = gfc_current_locus;
 152         }
 153       if (c == ')' && quote == ' ')
 154         {
 155           count--;
 156           where = gfc_current_locus;
 157         }
 158     }
 159
 160   gfc_current_locus = old_loc;
 161
 162   if (count > 0)
 163     {
 164       gfc_error ("Missing ')' in statement at or before %L", &where);
 165       return MATCH_ERROR;
 166     }
 167   if (count < 0)
 168     {
 169       gfc_error ("Missing '(' in statement at or before %L", &where);
 170       return MATCH_ERROR;
 171     }
 172
 173   return MATCH_YES;
 174 }
 175
 176
 177 /* See if the next character is a special character that has
 178    escaped by a \ via the -fbackslash option.  */
 179
 180 match
 181 gfc_match_special_char (gfc_char_t *res)
 182 {
 183   int len, i;
 184   gfc_char_t c, n;
 185   match m;
 186
 187   m = MATCH_YES;
 188
 189   switch ((c = gfc_next_char_literal (INSTRING_WARN)))
 190     {
 191     case 'a':
 192       *res = '\a';
 193       break;
 194     case 'b':
 195       *res = '\b';
 196       break;
 197     case 't':
 198       *res = '\t';
 199       break;
 200     case 'f':
 201       *res = '\f';
 202       break;
 203     case 'n':
 204       *res = '\n';
 205       break;
 206     case 'r':
 207       *res = '\r';
 208       break;
 209     case 'v':
 210       *res = '\v';
 211       break;
 212     case '\\':
 213       *res = '\\';
 214       break;
 215     case '0':
 216       *res = '\0';
 217       break;
 218
 219     case 'x':
 220     case 'u':
 221     case 'U':
 222       /* Hexadecimal form of wide characters.  */
 223       len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
 224       n = 0;
 225       for (i = 0; i < len; i++)
 226         {
 227           char buf[2] = { '\0', '\0' };
 228
 229           c = gfc_next_char_literal (INSTRING_WARN);
 230           if (!gfc_wide_fits_in_byte (c)
 231               || !gfc_check_digit ((unsigned char) c, 16))
 232             return MATCH_NO;
 233
 234           buf[0] = (unsigned char) c;
 235           n = n << 4;
 236           n += strtol (buf, NULL, 16);
 237         }
 238       *res = n;
 239       break;
 240
 241     default:
 242       /* Unknown backslash codes are simply not expanded.  */
 243       m = MATCH_NO;
 244       break;
 245     }
 246
 247   return m;
 248 }
 249
 250
 251 /* In free form, match at least one space.  Always matches in fixed
 252    form.  */
 253
 254 match
 255 gfc_match_space (void)
 256 {
 257   locus old_loc;
 258   char c;
 259
 260   if (gfc_current_form == FORM_FIXED)
 261     return MATCH_YES;
 262
 263   old_loc = gfc_current_locus;
 264
 265   c = gfc_next_ascii_char ();
 266   if (!gfc_is_whitespace (c))
 267     {
 268       gfc_current_locus = old_loc;
 269       return MATCH_NO;
 270     }
 271
 272   gfc_gobble_whitespace ();
 273
 274   return MATCH_YES;
 275 }
 276
 277
 278 /* Match an end of statement.  End of statement is optional
 279    whitespace, followed by a ';' or '\n' or comment '!'.  If a
 280    semicolon is found, we continue to eat whitespace and semicolons.  */
 281
 282 match
 283 gfc_match_eos (void)
 284 {
 285   locus old_loc;
 286   int flag;
 287   char c;
 288
 289   flag = 0;
 290
 291   for (;;)
 292     {
 293       old_loc = gfc_current_locus;
 294       gfc_gobble_whitespace ();
 295
 296       c = gfc_next_ascii_char ();
 297       switch (c)
 298         {
 299         case '!':
 300           do
 301             {
 302               c = gfc_next_ascii_char ();
 303             }
 304           while (c != '\n');
 305
 306           /* Fall through.  */
 307
 308         case '\n':
 309           return MATCH_YES;
 310
 311         case ';':
 312           flag = 1;
 313           continue;
 314         }
 315
 316       break;
 317     }
 318
 319   gfc_current_locus = old_loc;
 320   return (flag) ? MATCH_YES : MATCH_NO;
 321 }
 322
 323
 324 /* Match a literal integer on the input, setting the value on
 325    MATCH_YES.  Literal ints occur in kind-parameters as well as
 326    old-style character length specifications.  If cnt is non-NULL it
 327    will be set to the number of digits.  */
 328
 329 match
 330 gfc_match_small_literal_int (int *value, int *cnt)
 331 {
 332   locus old_loc;
 333   char c;
 334   int i, j;
 335
 336   old_loc = gfc_current_locus;
 337
 338   *value = -1;
 339   gfc_gobble_whitespace ();
 340   c = gfc_next_ascii_char ();
 341   if (cnt)
 342     *cnt = 0;
 343
 344   if (!ISDIGIT (c))
 345     {
 346       gfc_current_locus = old_loc;
 347       return MATCH_NO;
 348     }
 349
 350   i = c - '0';
 351   j = 1;
 352
 353   for (;;)
 354     {
 355       old_loc = gfc_current_locus;
 356       c = gfc_next_ascii_char ();
 357
 358       if (!ISDIGIT (c))
 359         break;
 360
 361       i = 10 * i + c - '0';
 362       j++;
 363
 364       if (i > 99999999)
 365         {
 366           gfc_error ("Integer too large at %C");
 367           return MATCH_ERROR;
 368         }
 369     }
 370
 371   gfc_current_locus = old_loc;
 372
 373   *value = i;
 374   if (cnt)
 375     *cnt = j;
 376   return MATCH_YES;
 377 }
 378
 379
 380 /* Match a small, constant integer expression, like in a kind
 381    statement.  On MATCH_YES, 'value' is set.  */
 382
 383 match
 384 gfc_match_small_int (int *value)
 385 {
 386   gfc_expr *expr;
 387   const char *p;
 388   match m;
 389   int i;
 390
 391   m = gfc_match_expr (&expr);
 392   if (m != MATCH_YES)
 393     return m;
 394
 395   p = gfc_extract_int (expr, &i);
 396   gfc_free_expr (expr);
 397
 398   if (p != NULL)
 399     {
 400       gfc_error (p);
 401       m = MATCH_ERROR;
 402     }
 403
 404   *value = i;
 405   return m;
 406 }
 407
 408
 409 /* This function is the same as the gfc_match_small_int, except that
 410    we're keeping the pointer to the expr.  This function could just be
 411    removed and the previously mentioned one modified, though all calls
 412    to it would have to be modified then (and there were a number of
 413    them).  Return MATCH_ERROR if fail to extract the int; otherwise,
 414    return the result of gfc_match_expr().  The expr (if any) that was
 415    matched is returned in the parameter expr.  */
 416
 417 match
 418 gfc_match_small_int_expr (int *value, gfc_expr **expr)
 419 {
 420   const char *p;
 421   match m;
 422   int i;
 423
 424   m = gfc_match_expr (expr);
 425   if (m != MATCH_YES)
 426     return m;
 427
 428   p = gfc_extract_int (*expr, &i);
 429
 430   if (p != NULL)
 431     {
 432       gfc_error (p);
 433       m = MATCH_ERROR;
 434     }
 435
 436   *value = i;
 437   return m;
 438 }
 439
 440
 441 /* Matches a statement label.  Uses gfc_match_small_literal_int() to
 442    do most of the work.  */
 443
 444 match
 445 gfc_match_st_label (gfc_st_label **label)
 446 {
 447   locus old_loc;
 448   match m;
 449   int i, cnt;
 450
 451   old_loc = gfc_current_locus;
 452
 453   m = gfc_match_small_literal_int (&i, &cnt);
 454   if (m != MATCH_YES)
 455     return m;
 456
 457   if (cnt > 5)
 458     {
 459       gfc_error ("Too many digits in statement label at %C");
 460       goto cleanup;
 461     }
 462
 463   if (i == 0)
 464     {
 465       gfc_error ("Statement label at %C is zero");
 466       goto cleanup;
 467     }
 468
 469   *label = gfc_get_st_label (i);
 470   return MATCH_YES;
 471
 472 cleanup:
 473
 474   gfc_current_locus = old_loc;
 475   return MATCH_ERROR;
 476 }
 477
 478
 479 /* Match and validate a label associated with a named IF, DO or SELECT
 480    statement.  If the symbol does not have the label attribute, we add
 481    it.  We also make sure the symbol does not refer to another
 482    (active) block.  A matched label is pointed to by gfc_new_block.  */
 483
 484 match
 485 gfc_match_label (void)
 486 {
 487   char name[GFC_MAX_SYMBOL_LEN + 1];
 488   match m;
 489
 490   gfc_new_block = NULL;
 491
 492   m = gfc_match (" %n :", name);
 493   if (m != MATCH_YES)
 494     return m;
 495
 496   if (gfc_get_symbol (name, NULL, &gfc_new_block))
 497     {
 498       gfc_error ("Label name '%s' at %C is ambiguous", name);
 499       return MATCH_ERROR;
 500     }
 501
 502   if (gfc_new_block->attr.flavor == FL_LABEL)
 503     {
 504       gfc_error ("Duplicate construct label '%s' at %C", name);
 505       return MATCH_ERROR;
 506     }
 507
 508   if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
 509                       gfc_new_block->name, NULL) == FAILURE)
 510     return MATCH_ERROR;
 511
 512   return MATCH_YES;
 513 }
 514
 515
 516 /* See if the current input looks like a name of some sort.  Modifies
 517    the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
 518    Note that options.c restricts max_identifier_length to not more
 519    than GFC_MAX_SYMBOL_LEN.  */
 520
 521 match
 522 gfc_match_name (char *buffer)
 523 {
 524   locus old_loc;
 525   int i;
 526   char c;
 527
 528   old_loc = gfc_current_locus;
 529   gfc_gobble_whitespace ();
 530
 531   c = gfc_next_ascii_char ();
 532   if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
 533     {
 534       if (gfc_error_flag_test() == 0 && c != '(')
 535         gfc_error ("Invalid character in name at %C");
 536       gfc_current_locus = old_loc;
 537       return MATCH_NO;
 538     }
 539
 540   i = 0;
 541
 542   do
 543     {
 544       buffer[i++] = c;
 545
 546       if (i > gfc_option.max_identifier_length)
 547         {
 548           gfc_error ("Name at %C is too long");
 549           return MATCH_ERROR;
 550         }
 551
 552       old_loc = gfc_current_locus;
 553       c = gfc_next_ascii_char ();
 554     }
 555   while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
 556
 557   if (c == '$' && !gfc_option.flag_dollar_ok)
 558     {
 559       gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it "
 560                  "as an extension");
 561       return MATCH_ERROR;
 562     }
 563
 564   buffer[i] = '\0';
 565   gfc_current_locus = old_loc;
 566
 567   return MATCH_YES;
 568 }
 569
 570
 571 /* Match a valid name for C, which is almost the same as for Fortran,
 572    except that you can start with an underscore, etc..  It could have
 573    been done by modifying the gfc_match_name, but this way other
 574    things C allows can be added, such as no limits on the length.
 575    Right now, the length is limited to the same thing as Fortran..
 576    Also, by rewriting it, we use the gfc_next_char_C() to prevent the
 577    input characters from being automatically lower cased, since C is
 578    case sensitive.  The parameter, buffer, is used to return the name
 579    that is matched.  Return MATCH_ERROR if the name is too long
 580    (though this is a self-imposed limit), MATCH_NO if what we're
 581    seeing isn't a name, and MATCH_YES if we successfully match a C
 582    name.  */
 583
 584 match
 585 gfc_match_name_C (char *buffer)
 586 {
 587   locus old_loc;
 588   int i = 0;
 589   gfc_char_t c;
 590
 591   old_loc = gfc_current_locus;
 592   gfc_gobble_whitespace ();
 593
 594   /* Get the next char (first possible char of name) and see if
 595      it's valid for C (either a letter or an underscore).  */
 596   c = gfc_next_char_literal (INSTRING_WARN);
 597
 598   /* If the user put nothing expect spaces between the quotes, it is valid
 599      and simply means there is no name= specifier and the name is the fortran
 600      symbol name, all lowercase.  */
 601   if (c == '"' || c == '\'')
 602     {
 603       buffer[0] = '\0';
 604       gfc_current_locus = old_loc;
 605       return MATCH_YES;
 606     }
 607
 608   if (!ISALPHA (c) && c != '_')
 609     {
 610       gfc_error ("Invalid C name in NAME= specifier at %C");
 611       return MATCH_ERROR;
 612     }
 613
 614   /* Continue to read valid variable name characters.  */
 615   do
 616     {
 617       gcc_assert (gfc_wide_fits_in_byte (c));
 618
 619       buffer[i++] = (unsigned char) c;
 620
 621     /* C does not define a maximum length of variable names, to my
 622        knowledge, but the compiler typically places a limit on them.
 623        For now, i'll use the same as the fortran limit for simplicity,
 624        but this may need to be changed to a dynamic buffer that can
 625        be realloc'ed here if necessary, or more likely, a larger
 626        upper-bound set.  */
 627       if (i > gfc_option.max_identifier_length)
 628         {
 629           gfc_error ("Name at %C is too long");
 630           return MATCH_ERROR;
 631         }
 632
 633       old_loc = gfc_current_locus;
 634
 635       /* Get next char; param means we're in a string.  */
 636       c = gfc_next_char_literal (INSTRING_WARN);
 637     } while (ISALNUM (c) || c == '_');
 638
 639   buffer[i] = '\0';
 640   gfc_current_locus = old_loc;
 641
 642   /* See if we stopped because of whitespace.  */
 643   if (c == ' ')
 644     {
 645       gfc_gobble_whitespace ();
 646       c = gfc_peek_ascii_char ();
 647       if (c != '"' && c != '\'')
 648         {
 649           gfc_error ("Embedded space in NAME= specifier at %C");
 650           return MATCH_ERROR;
 651         }
 652     }
 653
 654   /* If we stopped because we had an invalid character for a C name, report
 655      that to the user by returning MATCH_NO.  */
 656   if (c != '"' && c != '\'')
 657     {
 658       gfc_error ("Invalid C name in NAME= specifier at %C");
 659       return MATCH_ERROR;
 660     }
 661
 662   return MATCH_YES;
 663 }
 664
 665
 666 /* Match a symbol on the input.  Modifies the pointer to the symbol
 667    pointer if successful.  */
 668
 669 match
 670 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
 671 {
 672   char buffer[GFC_MAX_SYMBOL_LEN + 1];
 673   match m;
 674
 675   m = gfc_match_name (buffer);
 676   if (m != MATCH_YES)
 677     return m;
 678
 679   if (host_assoc)
 680     return (gfc_get_ha_sym_tree (buffer, matched_symbol))
 681             ? MATCH_ERROR : MATCH_YES;
 682
 683   if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false))
 684     return MATCH_ERROR;
 685
 686   return MATCH_YES;
 687 }
 688
 689
 690 match
 691 gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
 692 {
 693   gfc_symtree *st;
 694   match m;
 695
 696   m = gfc_match_sym_tree (&st, host_assoc);
 697
 698   if (m == MATCH_YES)
 699     {
 700       if (st)
 701         *matched_symbol = st->n.sym;
 702       else
 703         *matched_symbol = NULL;
 704     }
 705   else
 706     *matched_symbol = NULL;
 707   return m;
 708 }
 709
 710
 711 /* Match an intrinsic operator.  Returns an INTRINSIC enum. While matching,
 712    we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
 713    in matchexp.c.  */
 714
 715 match
 716 gfc_match_intrinsic_op (gfc_intrinsic_op *result)
 717 {
 718   locus orig_loc = gfc_current_locus;
 719   char ch;
 720
 721   gfc_gobble_whitespace ();
 722   ch = gfc_next_ascii_char ();
 723   switch (ch)
 724     {
 725     case '+':
 726       /* Matched "+".  */
 727       *result = INTRINSIC_PLUS;
 728       return MATCH_YES;
 729
 730     case '-':
 731       /* Matched "-".  */
 732       *result = INTRINSIC_MINUS;
 733       return MATCH_YES;
 734
 735     case '=':
 736       if (gfc_next_ascii_char () == '=')
 737         {
 738           /* Matched "==".  */
 739           *result = INTRINSIC_EQ;
 740           return MATCH_YES;
 741         }
 742       break;
 743
 744     case '<':
 745       if (gfc_peek_ascii_char () == '=')
 746         {
 747           /* Matched "<=".  */
 748           gfc_next_ascii_char ();
 749           *result = INTRINSIC_LE;
 750           return MATCH_YES;
 751         }
 752       /* Matched "<".  */
 753       *result = INTRINSIC_LT;
 754       return MATCH_YES;
 755
 756     case '>':
 757       if (gfc_peek_ascii_char () == '=')
 758         {
 759           /* Matched ">=".  */
 760           gfc_next_ascii_char ();
 761           *result = INTRINSIC_GE;
 762           return MATCH_YES;
 763         }
 764       /* Matched ">".  */
 765       *result = INTRINSIC_GT;
 766       return MATCH_YES;
 767
 768     case '*':
 769       if (gfc_peek_ascii_char () == '*')
 770         {
 771           /* Matched "**".  */
 772           gfc_next_ascii_char ();
 773           *result = INTRINSIC_POWER;
 774           return MATCH_YES;
 775         }
 776       /* Matched "*".  */
 777       *result = INTRINSIC_TIMES;
 778       return MATCH_YES;
 779
 780     case '/':
 781       ch = gfc_peek_ascii_char ();
 782       if (ch == '=')
 783         {
 784           /* Matched "/=".  */
 785           gfc_next_ascii_char ();
 786           *result = INTRINSIC_NE;
 787           return MATCH_YES;
 788         }
 789       else if (ch == '/')
 790         {
 791           /* Matched "//".  */
 792           gfc_next_ascii_char ();
 793           *result = INTRINSIC_CONCAT;
 794           return MATCH_YES;
 795         }
 796       /* Matched "/".  */
 797       *result = INTRINSIC_DIVIDE;
 798       return MATCH_YES;
 799
 800     case '.':
 801       ch = gfc_next_ascii_char ();
 802       switch (ch)
 803         {
 804         case 'a':
 805           if (gfc_next_ascii_char () == 'n'
 806               && gfc_next_ascii_char () == 'd'
 807               && gfc_next_ascii_char () == '.')
 808             {
 809               /* Matched ".and.".  */
 810               *result = INTRINSIC_AND;
 811               return MATCH_YES;
 812             }
 813           break;
 814
 815         case 'e':
 816           if (gfc_next_ascii_char () == 'q')
 817             {
 818               ch = gfc_next_ascii_char ();
 819               if (ch == '.')
 820                 {
 821                   /* Matched ".eq.".  */
 822                   *result = INTRINSIC_EQ_OS;
 823                   return MATCH_YES;
 824                 }
 825               else if (ch == 'v')
 826                 {
 827                   if (gfc_next_ascii_char () == '.')
 828                     {
 829                       /* Matched ".eqv.".  */
 830                       *result = INTRINSIC_EQV;
 831                       return MATCH_YES;
 832                     }
 833                 }
 834             }
 835           break;
 836
 837         case 'g':
 838           ch = gfc_next_ascii_char ();
 839           if (ch == 'e')
 840             {
 841               if (gfc_next_ascii_char () == '.')
 842                 {
 843                   /* Matched ".ge.".  */
 844                   *result = INTRINSIC_GE_OS;
 845                   return MATCH_YES;
 846                 }
 847             }
 848           else if (ch == 't')
 849             {
 850               if (gfc_next_ascii_char () == '.')
 851                 {
 852                   /* Matched ".gt.".  */
 853                   *result = INTRINSIC_GT_OS;
 854                   return MATCH_YES;
 855                 }
 856             }
 857           break;
 858
 859         case 'l':
 860           ch = gfc_next_ascii_char ();
 861           if (ch == 'e')
 862             {
 863               if (gfc_next_ascii_char () == '.')
 864                 {
 865                   /* Matched ".le.".  */
 866                   *result = INTRINSIC_LE_OS;
 867                   return MATCH_YES;
 868                 }
 869             }
 870           else if (ch == 't')
 871             {
 872               if (gfc_next_ascii_char () == '.')
 873                 {
 874                   /* Matched ".lt.".  */
 875                   *result = INTRINSIC_LT_OS;
 876                   return MATCH_YES;
 877                 }
 878             }
 879           break;
 880
 881         case 'n':
 882           ch = gfc_next_ascii_char ();
 883           if (ch == 'e')
 884             {
 885               ch = gfc_next_ascii_char ();
 886               if (ch == '.')
 887                 {
 888                   /* Matched ".ne.".  */
 889                   *result = INTRINSIC_NE_OS;
 890                   return MATCH_YES;
 891                 }
 892               else if (ch == 'q')
 893                 {
 894                   if (gfc_next_ascii_char () == 'v'
 895                       && gfc_next_ascii_char () == '.')
 896                     {
 897                       /* Matched ".neqv.".  */
 898                       *result = INTRINSIC_NEQV;
 899                       return MATCH_YES;
 900                     }
 901                 }
 902             }
 903           else if (ch == 'o')
 904             {
 905               if (gfc_next_ascii_char () == 't'
 906                   && gfc_next_ascii_char () == '.')
 907                 {
 908                   /* Matched ".not.".  */
 909                   *result = INTRINSIC_NOT;
 910                   return MATCH_YES;
 911                 }
 912             }
 913           break;
 914
 915         case 'o':
 916           if (gfc_next_ascii_char () == 'r'
 917               && gfc_next_ascii_char () == '.')
 918             {
 919               /* Matched ".or.".  */
 920               *result = INTRINSIC_OR;
 921               return MATCH_YES;
 922             }
 923           break;
 924
 925         default:
 926           break;
 927         }
 928       break;
 929
 930     default:
 931       break;
 932     }
 933
 934   gfc_current_locus = orig_loc;
 935   return MATCH_NO;
 936 }
 937
 938
 939 /* Match a loop control phrase:
 940
 941     <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
 942
 943    If the final integer expression is not present, a constant unity
 944    expression is returned.  We don't return MATCH_ERROR until after
 945    the equals sign is seen.  */
 946
 947 match
 948 gfc_match_iterator (gfc_iterator *iter, int init_flag)
 949 {
 950   char name[GFC_MAX_SYMBOL_LEN + 1];
 951   gfc_expr *var, *e1, *e2, *e3;
 952   locus start;
 953   match m;
 954
 955   e1 = e2 = e3 = NULL;
 956
 957   /* Match the start of an iterator without affecting the symbol table.  */
 958
 959   start = gfc_current_locus;
 960   m = gfc_match (" %n =", name);
 961   gfc_current_locus = start;
 962
 963   if (m != MATCH_YES)
 964     return MATCH_NO;
 965
 966   m = gfc_match_variable (&var, 0);
 967   if (m != MATCH_YES)
 968     return MATCH_NO;
 969
 970   /* F2008, C617 & C565.  */
 971   if (var->symtree->n.sym->attr.codimension)
 972     {
 973       gfc_error ("Loop variable at %C cannot be a coarray");
 974       goto cleanup;
 975     }
 976
 977   if (var->ref != NULL)
 978     {
 979       gfc_error ("Loop variable at %C cannot be a sub-component");
 980       goto cleanup;
 981     }
 982
 983   gfc_match_char ('=');
 984
 985   var->symtree->n.sym->attr.implied_index = 1;
 986
 987   m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
 988   if (m == MATCH_NO)
 989     goto syntax;
 990   if (m == MATCH_ERROR)
 991     goto cleanup;
 992
 993   if (gfc_match_char (',') != MATCH_YES)
 994     goto syntax;
 995
 996   m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
 997   if (m == MATCH_NO)
 998     goto syntax;
 999   if (m == MATCH_ERROR)
1000     goto cleanup;
1001
1002   if (gfc_match_char (',') != MATCH_YES)
1003     {
1004       e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
1005       goto done;
1006     }
1007
1008   m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
1009   if (m == MATCH_ERROR)
1010     goto cleanup;
1011   if (m == MATCH_NO)
1012     {
1013       gfc_error ("Expected a step value in iterator at %C");
1014       goto cleanup;
1015     }
1016
1017 done:
1018   iter->var = var;
1019   iter->start = e1;
1020   iter->end = e2;
1021   iter->step = e3;
1022   return MATCH_YES;
1023
1024 syntax:
1025   gfc_error ("Syntax error in iterator at %C");
1026
1027 cleanup:
1028   gfc_free_expr (e1);
1029   gfc_free_expr (e2);
1030   gfc_free_expr (e3);
1031
1032   return MATCH_ERROR;
1033 }
1034
1035
1036 /* Tries to match the next non-whitespace character on the input.
1037    This subroutine does not return MATCH_ERROR.  */
1038
1039 match
1040 gfc_match_char (char c)
1041 {
1042   locus where;
1043
1044   where = gfc_current_locus;
1045   gfc_gobble_whitespace ();
1046
1047   if (gfc_next_ascii_char () == c)
1048     return MATCH_YES;
1049
1050   gfc_current_locus = where;
1051   return MATCH_NO;
1052 }
1053
1054
1055 /* General purpose matching subroutine.  The target string is a
1056    scanf-like format string in which spaces correspond to arbitrary
1057    whitespace (including no whitespace), characters correspond to
1058    themselves.  The %-codes are:
1059
1060    %%  Literal percent sign
1061    %e  Expression, pointer to a pointer is set
1062    %s  Symbol, pointer to the symbol is set
1063    %n  Name, character buffer is set to name
1064    %t  Matches end of statement.
1065    %o  Matches an intrinsic operator, returned as an INTRINSIC enum.
1066    %l  Matches a statement label
1067    %v  Matches a variable expression (an lvalue)
1068    %   Matches a required space (in free form) and optional spaces.  */
1069
1070 match
1071 gfc_match (const char *target, ...)
1072 {
1073   gfc_st_label **label;
1074   int matches, *ip;
1075   locus old_loc;
1076   va_list argp;
1077   char c, *np;
1078   match m, n;
1079   void **vp;
1080   const char *p;
1081
1082   old_loc = gfc_current_locus;
1083   va_start (argp, target);
1084   m = MATCH_NO;
1085   matches = 0;
1086   p = target;
1087
1088 loop:
1089   c = *p++;
1090   switch (c)
1091     {
1092     case ' ':
1093       gfc_gobble_whitespace ();
1094       goto loop;
1095     case '\0':
1096       m = MATCH_YES;
1097       break;
1098
1099     case '%':
1100       c = *p++;
1101       switch (c)
1102         {
1103         case 'e':
1104           vp = va_arg (argp, void **);
1105           n = gfc_match_expr ((gfc_expr **) vp);
1106           if (n != MATCH_YES)
1107             {
1108               m = n;
1109               goto not_yes;
1110             }
1111
1112           matches++;
1113           goto loop;
1114
1115         case 'v':
1116           vp = va_arg (argp, void **);
1117           n = gfc_match_variable ((gfc_expr **) vp, 0);
1118           if (n != MATCH_YES)
1119             {
1120               m = n;
1121               goto not_yes;
1122             }
1123
1124           matches++;
1125           goto loop;
1126
1127         case 's':
1128           vp = va_arg (argp, void **);
1129           n = gfc_match_symbol ((gfc_symbol **) vp, 0);
1130           if (n != MATCH_YES)
1131             {
1132               m = n;
1133               goto not_yes;
1134             }
1135
1136           matches++;
1137           goto loop;
1138
1139         case 'n':
1140           np = va_arg (argp, char *);
1141           n = gfc_match_name (np);
1142           if (n != MATCH_YES)
1143             {
1144               m = n;
1145               goto not_yes;
1146             }
1147
1148           matches++;
1149           goto loop;
1150
1151         case 'l':
1152           label = va_arg (argp, gfc_st_label **);
1153           n = gfc_match_st_label (label);
1154           if (n != MATCH_YES)
1155             {
1156               m = n;
1157               goto not_yes;
1158             }
1159
1160           matches++;
1161           goto loop;
1162
1163         case 'o':
1164           ip = va_arg (argp, int *);
1165           n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
1166           if (n != MATCH_YES)
1167             {
1168               m = n;
1169               goto not_yes;
1170             }
1171
1172           matches++;
1173           goto loop;
1174
1175         case 't':
1176           if (gfc_match_eos () != MATCH_YES)
1177             {
1178               m = MATCH_NO;
1179               goto not_yes;
1180             }
1181           goto loop;
1182
1183         case ' ':
1184           if (gfc_match_space () == MATCH_YES)
1185             goto loop;
1186           m = MATCH_NO;
1187           goto not_yes;
1188
1189         case '%':
1190           break;        /* Fall through to character matcher.  */
1191
1192         default:
1193           gfc_internal_error ("gfc_match(): Bad match code %c", c);
1194         }
1195
1196     default:
1197
1198       /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1199          expect an upper case character here!  */
1200       gcc_assert (TOLOWER (c) == c);
1201
1202       if (c == gfc_next_ascii_char ())
1203         goto loop;
1204       break;
1205     }
1206
1207 not_yes:
1208   va_end (argp);
1209
1210   if (m != MATCH_YES)
1211     {
1212       /* Clean up after a failed match.  */
1213       gfc_current_locus = old_loc;
1214       va_start (argp, target);
1215
1216       p = target;
1217       for (; matches > 0; matches--)
1218         {
1219           while (*p++ != '%');
1220
1221           switch (*p++)
1222             {
1223             case '%':
1224               matches++;
1225               break;            /* Skip.  */
1226
1227             /* Matches that don't have to be undone */
1228             case 'o':
1229             case 'l':
1230             case 'n':
1231             case 's':
1232               (void) va_arg (argp, void **);
1233               break;
1234
1235             case 'e':
1236             case 'v':
1237               vp = va_arg (argp, void **);
1238               gfc_free_expr ((struct gfc_expr *)*vp);
1239               *vp = NULL;
1240               break;
1241             }
1242         }
1243
1244       va_end (argp);
1245     }
1246
1247   return m;
1248 }
1249
1250
1251 /*********************** Statement level matching **********************/
1252
1253 /* Matches the start of a program unit, which is the program keyword
1254    followed by an obligatory symbol.  */
1255
1256 match
1257 gfc_match_program (void)
1258 {
1259   gfc_symbol *sym;
1260   match m;
1261
1262   m = gfc_match ("% %s%t", &sym);
1263
1264   if (m == MATCH_NO)
1265     {
1266       gfc_error ("Invalid form of PROGRAM statement at %C");
1267       m = MATCH_ERROR;
1268     }
1269
1270   if (m == MATCH_ERROR)
1271     return m;
1272
1273   if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
1274     return MATCH_ERROR;
1275
1276   gfc_new_block = sym;
1277
1278   return MATCH_YES;
1279 }
1280
1281
1282 /* Match a simple assignment statement.  */
1283
1284 match
1285 gfc_match_assignment (void)
1286 {
1287   gfc_expr *lvalue, *rvalue;
1288   locus old_loc;
1289   match m;
1290
1291   old_loc = gfc_current_locus;
1292
1293   lvalue = NULL;
1294   m = gfc_match (" %v =", &lvalue);
1295   if (m != MATCH_YES)
1296     {
1297       gfc_current_locus = old_loc;
1298       gfc_free_expr (lvalue);
1299       return MATCH_NO;
1300     }
1301
1302   rvalue = NULL;
1303   m = gfc_match (" %e%t", &rvalue);
1304   if (m != MATCH_YES)
1305     {
1306       gfc_current_locus = old_loc;
1307       gfc_free_expr (lvalue);
1308       gfc_free_expr (rvalue);
1309       return m;
1310     }
1311
1312   gfc_set_sym_referenced (lvalue->symtree->n.sym);
1313
1314   new_st.op = EXEC_ASSIGN;
1315   new_st.expr1 = lvalue;
1316   new_st.expr2 = rvalue;
1317
1318   gfc_check_do_variable (lvalue->symtree);
1319
1320   return MATCH_YES;
1321 }
1322
1323
1324 /* Match a pointer assignment statement.  */
1325
1326 match
1327 gfc_match_pointer_assignment (void)
1328 {
1329   gfc_expr *lvalue, *rvalue;
1330   locus old_loc;
1331   match m;
1332
1333   old_loc = gfc_current_locus;
1334
1335   lvalue = rvalue = NULL;
1336   gfc_matching_ptr_assignment = 0;
1337   gfc_matching_procptr_assignment = 0;
1338
1339   m = gfc_match (" %v =>", &lvalue);
1340   if (m != MATCH_YES)
1341     {
1342       m = MATCH_NO;
1343       goto cleanup;
1344     }
1345
1346   if (lvalue->symtree->n.sym->attr.proc_pointer
1347       || gfc_is_proc_ptr_comp (lvalue, NULL))
1348     gfc_matching_procptr_assignment = 1;
1349   else
1350     gfc_matching_ptr_assignment = 1;
1351
1352   m = gfc_match (" %e%t", &rvalue);
1353   gfc_matching_ptr_assignment = 0;
1354   gfc_matching_procptr_assignment = 0;
1355   if (m != MATCH_YES)
1356     goto cleanup;
1357
1358   new_st.op = EXEC_POINTER_ASSIGN;
1359   new_st.expr1 = lvalue;
1360   new_st.expr2 = rvalue;
1361
1362   return MATCH_YES;
1363
1364 cleanup:
1365   gfc_current_locus = old_loc;
1366   gfc_free_expr (lvalue);
1367   gfc_free_expr (rvalue);
1368   return m;
1369 }
1370
1371
1372 /* We try to match an easy arithmetic IF statement. This only happens
1373    when just after having encountered a simple IF statement. This code
1374    is really duplicate with parts of the gfc_match_if code, but this is
1375    *much* easier.  */
1376
1377 static match
1378 match_arithmetic_if (void)
1379 {
1380   gfc_st_label *l1, *l2, *l3;
1381   gfc_expr *expr;
1382   match m;
1383
1384   m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
1385   if (m != MATCH_YES)
1386     return m;
1387
1388   if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1389       || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1390       || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1391     {
1392       gfc_free_expr (expr);
1393       return MATCH_ERROR;
1394     }
1395
1396   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
1397                       "statement at %C") == FAILURE)
1398     return MATCH_ERROR;
1399
1400   new_st.op = EXEC_ARITHMETIC_IF;
1401   new_st.expr1 = expr;
1402   new_st.label1 = l1;
1403   new_st.label2 = l2;
1404   new_st.label3 = l3;
1405
1406   return MATCH_YES;
1407 }
1408
1409
1410 /* The IF statement is a bit of a pain.  First of all, there are three
1411    forms of it, the simple IF, the IF that starts a block and the
1412    arithmetic IF.
1413
1414    There is a problem with the simple IF and that is the fact that we
1415    only have a single level of undo information on symbols.  What this
1416    means is for a simple IF, we must re-match the whole IF statement
1417    multiple times in order to guarantee that the symbol table ends up
1418    in the proper state.  */
1419
1420 static match match_simple_forall (void);
1421 static match match_simple_where (void);
1422
1423 match
1424 gfc_match_if (gfc_statement *if_type)
1425 {
1426   gfc_expr *expr;
1427   gfc_st_label *l1, *l2, *l3;
1428   locus old_loc, old_loc2;
1429   gfc_code *p;
1430   match m, n;
1431
1432   n = gfc_match_label ();
1433   if (n == MATCH_ERROR)
1434     return n;
1435
1436   old_loc = gfc_current_locus;
1437
1438   m = gfc_match (" if ( %e", &expr);
1439   if (m != MATCH_YES)
1440     return m;
1441
1442   old_loc2 = gfc_current_locus;
1443   gfc_current_locus = old_loc;
1444
1445   if (gfc_match_parens () == MATCH_ERROR)
1446     return MATCH_ERROR;
1447
1448   gfc_current_locus = old_loc2;
1449
1450   if (gfc_match_char (')') != MATCH_YES)
1451     {
1452       gfc_error ("Syntax error in IF-expression at %C");
1453       gfc_free_expr (expr);
1454       return MATCH_ERROR;
1455     }
1456
1457   m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1458
1459   if (m == MATCH_YES)
1460     {
1461       if (n == MATCH_YES)
1462         {
1463           gfc_error ("Block label not appropriate for arithmetic IF "
1464                      "statement at %C");
1465           gfc_free_expr (expr);
1466           return MATCH_ERROR;
1467         }
1468
1469       if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1470           || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1471           || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1472         {
1473           gfc_free_expr (expr);
1474           return MATCH_ERROR;
1475         }
1476
1477       if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
1478                           "statement at %C") == FAILURE)
1479         return MATCH_ERROR;
1480
1481       new_st.op = EXEC_ARITHMETIC_IF;
1482       new_st.expr1 = expr;
1483       new_st.label1 = l1;
1484       new_st.label2 = l2;
1485       new_st.label3 = l3;
1486
1487       *if_type = ST_ARITHMETIC_IF;
1488       return MATCH_YES;
1489     }
1490
1491   if (gfc_match (" then%t") == MATCH_YES)
1492     {
1493       new_st.op = EXEC_IF;
1494       new_st.expr1 = expr;
1495       *if_type = ST_IF_BLOCK;
1496       return MATCH_YES;
1497     }
1498
1499   if (n == MATCH_YES)
1500     {
1501       gfc_error ("Block label is not appropriate for IF statement at %C");
1502       gfc_free_expr (expr);
1503       return MATCH_ERROR;
1504     }
1505
1506   /* At this point the only thing left is a simple IF statement.  At
1507      this point, n has to be MATCH_NO, so we don't have to worry about
1508      re-matching a block label.  From what we've got so far, try
1509      matching an assignment.  */
1510
1511   *if_type = ST_SIMPLE_IF;
1512
1513   m = gfc_match_assignment ();
1514   if (m == MATCH_YES)
1515     goto got_match;
1516
1517   gfc_free_expr (expr);
1518   gfc_undo_symbols ();
1519   gfc_current_locus = old_loc;
1520
1521   /* m can be MATCH_NO or MATCH_ERROR, here.  For MATCH_ERROR, a mangled
1522      assignment was found.  For MATCH_NO, continue to call the various
1523      matchers.  */
1524   if (m == MATCH_ERROR)
1525     return MATCH_ERROR;
1526
1527   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */
1528
1529   m = gfc_match_pointer_assignment ();
1530   if (m == MATCH_YES)
1531     goto got_match;
1532
1533   gfc_free_expr (expr);
1534   gfc_undo_symbols ();
1535   gfc_current_locus = old_loc;
1536
1537   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */
1538
1539   /* Look at the next keyword to see which matcher to call.  Matching
1540      the keyword doesn't affect the symbol table, so we don't have to
1541      restore between tries.  */
1542
1543 #define match(string, subr, statement) \
1544   if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1545
1546   gfc_clear_error ();
1547
1548   match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1549   match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1550   match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1551   match ("call", gfc_match_call, ST_CALL)
1552   match ("close", gfc_match_close, ST_CLOSE)
1553   match ("continue", gfc_match_continue, ST_CONTINUE)
1554   match ("cycle", gfc_match_cycle, ST_CYCLE)
1555   match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1556   match ("end file", gfc_match_endfile, ST_END_FILE)
1557   match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
1558   match ("exit", gfc_match_exit, ST_EXIT)
1559   match ("flush", gfc_match_flush, ST_FLUSH)
1560   match ("forall", match_simple_forall, ST_FORALL)
1561   match ("go to", gfc_match_goto, ST_GOTO)
1562   match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1563   match ("inquire", gfc_match_inquire, ST_INQUIRE)
1564   match ("lock", gfc_match_lock, ST_LOCK)
1565   match ("nullify", gfc_match_nullify, ST_NULLIFY)
1566   match ("open", gfc_match_open, ST_OPEN)
1567   match ("pause", gfc_match_pause, ST_NONE)
1568   match ("print", gfc_match_print, ST_WRITE)
1569   match ("read", gfc_match_read, ST_READ)
1570   match ("return", gfc_match_return, ST_RETURN)
1571   match ("rewind", gfc_match_rewind, ST_REWIND)
1572   match ("stop", gfc_match_stop, ST_STOP)
1573   match ("wait", gfc_match_wait, ST_WAIT)
1574   match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
1575   match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
1576   match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
1577   match ("unlock", gfc_match_unlock, ST_UNLOCK)
1578   match ("where", match_simple_where, ST_WHERE)
1579   match ("write", gfc_match_write, ST_WRITE)
1580
1581   /* The gfc_match_assignment() above may have returned a MATCH_NO
1582      where the assignment was to a named constant.  Check that
1583      special case here.  */
1584   m = gfc_match_assignment ();
1585   if (m == MATCH_NO)
1586    {
1587       gfc_error ("Cannot assign to a named constant at %C");
1588       gfc_free_expr (expr);
1589       gfc_undo_symbols ();
1590       gfc_current_locus = old_loc;
1591       return MATCH_ERROR;
1592    }
1593
1594   /* All else has failed, so give up.  See if any of the matchers has
1595      stored an error message of some sort.  */
1596   if (gfc_error_check () == 0)
1597     gfc_error ("Unclassifiable statement in IF-clause at %C");
1598
1599   gfc_free_expr (expr);
1600   return MATCH_ERROR;
1601
1602 got_match:
1603   if (m == MATCH_NO)
1604     gfc_error ("Syntax error in IF-clause at %C");
1605   if (m != MATCH_YES)
1606     {
1607       gfc_free_expr (expr);
1608       return MATCH_ERROR;
1609     }
1610
1611   /* At this point, we've matched the single IF and the action clause
1612      is in new_st.  Rearrange things so that the IF statement appears
1613      in new_st.  */
1614
1615   p = gfc_get_code ();
1616   p->next = gfc_get_code ();
1617   *p->next = new_st;
1618   p->next->loc = gfc_current_locus;
1619
1620   p->expr1 = expr;
1621   p->op = EXEC_IF;
1622
1623   gfc_clear_new_st ();
1624
1625   new_st.op = EXEC_IF;
1626   new_st.block = p;
1627
1628   return MATCH_YES;
1629 }
1630
1631 #undef match
1632
1633
1634 /* Match an ELSE statement.  */
1635
1636 match
1637 gfc_match_else (void)
1638 {
1639   char name[GFC_MAX_SYMBOL_LEN + 1];
1640
1641   if (gfc_match_eos () == MATCH_YES)
1642     return MATCH_YES;
1643
1644   if (gfc_match_name (name) != MATCH_YES
1645       || gfc_current_block () == NULL
1646       || gfc_match_eos () != MATCH_YES)
1647     {
1648       gfc_error ("Unexpected junk after ELSE statement at %C");
1649       return MATCH_ERROR;
1650     }
1651
1652   if (strcmp (name, gfc_current_block ()->name) != 0)
1653     {
1654       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1655                  name, gfc_current_block ()->name);
1656       return MATCH_ERROR;
1657     }
1658
1659   return MATCH_YES;
1660 }
1661
1662
1663 /* Match an ELSE IF statement.  */
1664
1665 match
1666 gfc_match_elseif (void)
1667 {
1668   char name[GFC_MAX_SYMBOL_LEN + 1];
1669   gfc_expr *expr;
1670   match m;
1671
1672   m = gfc_match (" ( %e ) then", &expr);
1673   if (m != MATCH_YES)
1674     return m;
1675
1676   if (gfc_match_eos () == MATCH_YES)
1677     goto done;
1678
1679   if (gfc_match_name (name) != MATCH_YES
1680       || gfc_current_block () == NULL
1681       || gfc_match_eos () != MATCH_YES)
1682     {
1683       gfc_error ("Unexpected junk after ELSE IF statement at %C");
1684       goto cleanup;
1685     }
1686
1687   if (strcmp (name, gfc_current_block ()->name) != 0)
1688     {
1689       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1690                  name, gfc_current_block ()->name);
1691       goto cleanup;
1692     }
1693
1694 done:
1695   new_st.op = EXEC_IF;
1696   new_st.expr1 = expr;
1697   return MATCH_YES;
1698
1699 cleanup:
1700   gfc_free_expr (expr);
1701   return MATCH_ERROR;
1702 }
1703
1704
1705 /* Free a gfc_iterator structure.  */
1706
1707 void
1708 gfc_free_iterator (gfc_iterator *iter, int flag)
1709 {
1710
1711   if (iter == NULL)
1712     return;
1713
1714   gfc_free_expr (iter->var);
1715   gfc_free_expr (iter->start);
1716   gfc_free_expr (iter->end);
1717   gfc_free_expr (iter->step);
1718
1719   if (flag)
1720     free (iter);
1721 }
1722
1723
1724 /* Match a CRITICAL statement.  */
1725 match
1726 gfc_match_critical (void)
1727 {
1728   gfc_st_label *label = NULL;
1729
1730   if (gfc_match_label () == MATCH_ERROR)
1731     return MATCH_ERROR;
1732
1733   if (gfc_match (" critical") != MATCH_YES)
1734     return MATCH_NO;
1735
1736   if (gfc_match_st_label (&label) == MATCH_ERROR)
1737     return MATCH_ERROR;
1738
1739   if (gfc_match_eos () != MATCH_YES)
1740     {
1741       gfc_syntax_error (ST_CRITICAL);
1742       return MATCH_ERROR;
1743     }
1744
1745   if (gfc_pure (NULL))
1746     {
1747       gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1748       return MATCH_ERROR;
1749     }
1750
1751   if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
1752     {
1753       gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1754                  "block");
1755       return MATCH_ERROR;
1756     }
1757
1758   if (gfc_implicit_pure (NULL))
1759     gfc_current_ns->proc_name->attr.implicit_pure = 0;
1760
1761   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C")
1762       == FAILURE)
1763     return MATCH_ERROR;
1764
1765   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
1766     {
1767        gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
1768        return MATCH_ERROR;
1769     }
1770
1771   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
1772     {
1773       gfc_error ("Nested CRITICAL block at %C");
1774       return MATCH_ERROR;
1775     }
1776
1777   new_st.op = EXEC_CRITICAL;
1778
1779   if (label != NULL
1780       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1781     return MATCH_ERROR;
1782
1783   return MATCH_YES;
1784 }
1785
1786
1787 /* Match a BLOCK statement.  */
1788
1789 match
1790 gfc_match_block (void)
1791 {
1792   match m;
1793
1794   if (gfc_match_label () == MATCH_ERROR)
1795     return MATCH_ERROR;
1796
1797   if (gfc_match (" block") != MATCH_YES)
1798     return MATCH_NO;
1799
1800   /* For this to be a correct BLOCK statement, the line must end now.  */
1801   m = gfc_match_eos ();
1802   if (m == MATCH_ERROR)
1803     return MATCH_ERROR;
1804   if (m == MATCH_NO)
1805     return MATCH_NO;
1806
1807   return MATCH_YES;
1808 }
1809
1810
1811 /* Match an ASSOCIATE statement.  */
1812
1813 match
1814 gfc_match_associate (void)
1815 {
1816   if (gfc_match_label () == MATCH_ERROR)
1817     return MATCH_ERROR;
1818
1819   if (gfc_match (" associate") != MATCH_YES)
1820     return MATCH_NO;
1821
1822   /* Match the association list.  */
1823   if (gfc_match_char ('(') != MATCH_YES)
1824     {
1825       gfc_error ("Expected association list at %C");
1826       return MATCH_ERROR;
1827     }
1828   new_st.ext.block.assoc = NULL;
1829   while (true)
1830     {
1831       gfc_association_list* newAssoc = gfc_get_association_list ();
1832       gfc_association_list* a;
1833
1834       /* Match the next association.  */
1835       if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
1836             != MATCH_YES)
1837         {
1838           gfc_error ("Expected association at %C");
1839           goto assocListError;
1840         }
1841       newAssoc->where = gfc_current_locus;
1842
1843       /* Check that the current name is not yet in the list.  */
1844       for (a = new_st.ext.block.assoc; a; a = a->next)
1845         if (!strcmp (a->name, newAssoc->name))
1846           {
1847             gfc_error ("Duplicate name '%s' in association at %C",
1848                        newAssoc->name);
1849             goto assocListError;
1850           }
1851
1852       /* The target expression must not be coindexed.  */
1853       if (gfc_is_coindexed (newAssoc->target))
1854         {
1855           gfc_error ("Association target at %C must not be coindexed");
1856           goto assocListError;
1857         }
1858
1859       /* The `variable' field is left blank for now; because the target is not
1860          yet resolved, we can't use gfc_has_vector_subscript to determine it
1861          for now.  This is set during resolution.  */
1862
1863       /* Put it into the list.  */
1864       newAssoc->next = new_st.ext.block.assoc;
1865       new_st.ext.block.assoc = newAssoc;
1866
1867       /* Try next one or end if closing parenthesis is found.  */
1868       gfc_gobble_whitespace ();
1869       if (gfc_peek_char () == ')')
1870         break;
1871       if (gfc_match_char (',') != MATCH_YES)
1872         {
1873           gfc_error ("Expected ')' or ',' at %C");
1874           return MATCH_ERROR;
1875         }
1876
1877       continue;
1878
1879 assocListError:
1880       free (newAssoc);
1881       goto error;
1882     }
1883   if (gfc_match_char (')') != MATCH_YES)
1884     {
1885       /* This should never happen as we peek above.  */
1886       gcc_unreachable ();
1887     }
1888
1889   if (gfc_match_eos () != MATCH_YES)
1890     {
1891       gfc_error ("Junk after ASSOCIATE statement at %C");
1892       goto error;
1893     }
1894
1895   return MATCH_YES;
1896
1897 error:
1898   gfc_free_association_list (new_st.ext.block.assoc);
1899   return MATCH_ERROR;
1900 }
1901
1902
1903 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1904    an accessible derived type.  */
1905
1906 static match
1907 match_derived_type_spec (gfc_typespec *ts)
1908 {
1909   char name[GFC_MAX_SYMBOL_LEN + 1];
1910   locus old_locus;
1911   gfc_symbol *derived;
1912
1913   old_locus = gfc_current_locus;
1914
1915   if (gfc_match ("%n", name) != MATCH_YES)
1916     {
1917        gfc_current_locus = old_locus;
1918        return MATCH_NO;
1919     }
1920
1921   gfc_find_symbol (name, NULL, 1, &derived);
1922
1923   if (derived && derived->attr.flavor == FL_DERIVED)
1924     {
1925       ts->type = BT_DERIVED;
1926       ts->u.derived = derived;
1927       return MATCH_YES;
1928     }
1929
1930   gfc_current_locus = old_locus;
1931   return MATCH_NO;
1932 }
1933
1934
1935 /* Match a Fortran 2003 type-spec (F03:R401).  This is similar to
1936    gfc_match_decl_type_spec() from decl.c, with the following exceptions:
1937    It only includes the intrinsic types from the Fortran 2003 standard
1938    (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
1939    the implicit_flag is not needed, so it was removed. Derived types are
1940    identified by their name alone.  */
1941
1942 static match
1943 match_type_spec (gfc_typespec *ts)
1944 {
1945   match m;
1946   locus old_locus;
1947
1948   gfc_clear_ts (ts);
1949   gfc_gobble_whitespace ();
1950   old_locus = gfc_current_locus;
1951
1952   if (match_derived_type_spec (ts) == MATCH_YES)
1953     {
1954       /* Enforce F03:C401.  */
1955       if (ts->u.derived->attr.abstract)
1956         {
1957           gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
1958                      ts->u.derived->name, &old_locus);
1959           return MATCH_ERROR;
1960         }
1961       return MATCH_YES;
1962     }
1963
1964   if (gfc_match ("integer") == MATCH_YES)
1965     {
1966       ts->type = BT_INTEGER;
1967       ts->kind = gfc_default_integer_kind;
1968       goto kind_selector;
1969     }
1970
1971   if (gfc_match ("real") == MATCH_YES)
1972     {
1973       ts->type = BT_REAL;
1974       ts->kind = gfc_default_real_kind;
1975       goto kind_selector;
1976     }
1977
1978   if (gfc_match ("double precision") == MATCH_YES)
1979     {
1980       ts->type = BT_REAL;
1981       ts->kind = gfc_default_double_kind;
1982       return MATCH_YES;
1983     }
1984
1985   if (gfc_match ("complex") == MATCH_YES)
1986     {
1987       ts->type = BT_COMPLEX;
1988       ts->kind = gfc_default_complex_kind;
1989       goto kind_selector;
1990     }
1991
1992   if (gfc_match ("character") == MATCH_YES)
1993     {
1994       ts->type = BT_CHARACTER;
1995
1996       m = gfc_match_char_spec (ts);
1997
1998       if (m == MATCH_NO)
1999         m = MATCH_YES;
2000
2001       return m;
2002     }
2003
2004   if (gfc_match ("logical") == MATCH_YES)
2005     {
2006       ts->type = BT_LOGICAL;
2007       ts->kind = gfc_default_logical_kind;
2008       goto kind_selector;
2009     }
2010
2011   /* If a type is not matched, simply return MATCH_NO.  */
2012   gfc_current_locus = old_locus;
2013   return MATCH_NO;
2014
2015 kind_selector:
2016
2017   gfc_gobble_whitespace ();
2018   if (gfc_peek_ascii_char () == '*')
2019     {
2020       gfc_error ("Invalid type-spec at %C");
2021       return MATCH_ERROR;
2022     }
2023
2024   m = gfc_match_kind_spec (ts, false);
2025
2026   if (m == MATCH_NO)
2027     m = MATCH_YES;              /* No kind specifier found.  */
2028
2029   return m;
2030 }
2031
2032
2033 /******************** FORALL subroutines ********************/
2034
2035 /* Free a list of FORALL iterators.  */
2036
2037 void
2038 gfc_free_forall_iterator (gfc_forall_iterator *iter)
2039 {
2040   gfc_forall_iterator *next;
2041
2042   while (iter)
2043     {
2044       next = iter->next;
2045       gfc_free_expr (iter->var);
2046       gfc_free_expr (iter->start);
2047       gfc_free_expr (iter->end);
2048       gfc_free_expr (iter->stride);
2049       free (iter);
2050       iter = next;
2051     }
2052 }
2053
2054
2055 /* Match an iterator as part of a FORALL statement.  The format is:
2056
2057      <var> = <start>:<end>[:<stride>]
2058
2059    On MATCH_NO, the caller tests for the possibility that there is a
2060    scalar mask expression.  */
2061
2062 static match
2063 match_forall_iterator (gfc_forall_iterator **result)
2064 {
2065   gfc_forall_iterator *iter;
2066   locus where;
2067   match m;
2068
2069   where = gfc_current_locus;
2070   iter = XCNEW (gfc_forall_iterator);
2071
2072   m = gfc_match_expr (&iter->var);
2073   if (m != MATCH_YES)
2074     goto cleanup;
2075
2076   if (gfc_match_char ('=') != MATCH_YES
2077       || iter->var->expr_type != EXPR_VARIABLE)
2078     {
2079       m = MATCH_NO;
2080       goto cleanup;
2081     }
2082
2083   m = gfc_match_expr (&iter->start);
2084   if (m != MATCH_YES)
2085     goto cleanup;
2086
2087   if (gfc_match_char (':') != MATCH_YES)
2088     goto syntax;
2089
2090   m = gfc_match_expr (&iter->end);
2091   if (m == MATCH_NO)
2092     goto syntax;
2093   if (m == MATCH_ERROR)
2094     goto cleanup;
2095
2096   if (gfc_match_char (':') == MATCH_NO)
2097     iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
2098   else
2099     {
2100       m = gfc_match_expr (&iter->stride);
2101       if (m == MATCH_NO)
2102         goto syntax;
2103       if (m == MATCH_ERROR)
2104         goto cleanup;
2105     }
2106
2107   /* Mark the iteration variable's symbol as used as a FORALL index.  */
2108   iter->var->symtree->n.sym->forall_index = true;
2109
2110   *result = iter;
2111   return MATCH_YES;
2112
2113 syntax:
2114   gfc_error ("Syntax error in FORALL iterator at %C");
2115   m = MATCH_ERROR;
2116
2117 cleanup:
2118
2119   gfc_current_locus = where;
2120   gfc_free_forall_iterator (iter);
2121   return m;
2122 }
2123
2124
2125 /* Match the header of a FORALL statement.  */
2126
2127 static match
2128 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
2129 {
2130   gfc_forall_iterator *head, *tail, *new_iter;
2131   gfc_expr *msk;
2132   match m;
2133
2134   gfc_gobble_whitespace ();
2135
2136   head = tail = NULL;
2137   msk = NULL;
2138
2139   if (gfc_match_char ('(') != MATCH_YES)
2140     return MATCH_NO;
2141
2142   m = match_forall_iterator (&new_iter);
2143   if (m == MATCH_ERROR)
2144     goto cleanup;
2145   if (m == MATCH_NO)
2146     goto syntax;
2147
2148   head = tail = new_iter;
2149
2150   for (;;)
2151     {
2152       if (gfc_match_char (',') != MATCH_YES)
2153         break;
2154
2155       m = match_forall_iterator (&new_iter);
2156       if (m == MATCH_ERROR)
2157         goto cleanup;
2158
2159       if (m == MATCH_YES)
2160         {
2161           tail->next = new_iter;
2162           tail = new_iter;
2163           continue;
2164         }
2165
2166       /* Have to have a mask expression.  */
2167
2168       m = gfc_match_expr (&msk);
2169       if (m == MATCH_NO)
2170         goto syntax;
2171       if (m == MATCH_ERROR)
2172         goto cleanup;
2173
2174       break;
2175     }
2176
2177   if (gfc_match_char (')') == MATCH_NO)
2178     goto syntax;
2179
2180   *phead = head;
2181   *mask = msk;
2182   return MATCH_YES;
2183
2184 syntax:
2185   gfc_syntax_error (ST_FORALL);
2186
2187 cleanup:
2188   gfc_free_expr (msk);
2189   gfc_free_forall_iterator (head);
2190
2191   return MATCH_ERROR;
2192 }
2193
2194 /* Match the rest of a simple FORALL statement that follows an
2195    IF statement.  */
2196
2197 static match
2198 match_simple_forall (void)
2199 {
2200   gfc_forall_iterator *head;
2201   gfc_expr *mask;
2202   gfc_code *c;
2203   match m;
2204
2205   mask = NULL;
2206   head = NULL;
2207   c = NULL;
2208
2209   m = match_forall_header (&head, &mask);
2210
2211   if (m == MATCH_NO)
2212     goto syntax;
2213   if (m != MATCH_YES)
2214     goto cleanup;
2215
2216   m = gfc_match_assignment ();
2217
2218   if (m == MATCH_ERROR)
2219     goto cleanup;
2220   if (m == MATCH_NO)
2221     {
2222       m = gfc_match_pointer_assignment ();
2223       if (m == MATCH_ERROR)
2224         goto cleanup;
2225       if (m == MATCH_NO)
2226         goto syntax;
2227     }
2228
2229   c = gfc_get_code ();
2230   *c = new_st;
2231   c->loc = gfc_current_locus;
2232
2233   if (gfc_match_eos () != MATCH_YES)
2234     goto syntax;
2235
2236   gfc_clear_new_st ();
2237   new_st.op = EXEC_FORALL;
2238   new_st.expr1 = mask;
2239   new_st.ext.forall_iterator = head;
2240   new_st.block = gfc_get_code ();
2241
2242   new_st.block->op = EXEC_FORALL;
2243   new_st.block->next = c;
2244
2245   return MATCH_YES;
2246
2247 syntax:
2248   gfc_syntax_error (ST_FORALL);
2249
2250 cleanup:
2251   gfc_free_forall_iterator (head);
2252   gfc_free_expr (mask);
2253
2254   return MATCH_ERROR;
2255 }
2256
2257
2258 /* Match a FORALL statement.  */
2259
2260 match
2261 gfc_match_forall (gfc_statement *st)
2262 {
2263   gfc_forall_iterator *head;
2264   gfc_expr *mask;
2265   gfc_code *c;
2266   match m0, m;
2267
2268   head = NULL;
2269   mask = NULL;
2270   c = NULL;
2271
2272   m0 = gfc_match_label ();
2273   if (m0 == MATCH_ERROR)
2274     return MATCH_ERROR;
2275
2276   m = gfc_match (" forall");
2277   if (m != MATCH_YES)
2278     return m;
2279
2280   m = match_forall_header (&head, &mask);
2281   if (m == MATCH_ERROR)
2282     goto cleanup;
2283   if (m == MATCH_NO)
2284     goto syntax;
2285
2286   if (gfc_match_eos () == MATCH_YES)
2287     {
2288       *st = ST_FORALL_BLOCK;
2289       new_st.op = EXEC_FORALL;
2290       new_st.expr1 = mask;
2291       new_st.ext.forall_iterator = head;
2292       return MATCH_YES;
2293     }
2294
2295   m = gfc_match_assignment ();
2296   if (m == MATCH_ERROR)
2297     goto cleanup;
2298   if (m == MATCH_NO)
2299     {
2300       m = gfc_match_pointer_assignment ();
2301       if (m == MATCH_ERROR)
2302         goto cleanup;
2303       if (m == MATCH_NO)
2304         goto syntax;
2305     }
2306
2307   c = gfc_get_code ();
2308   *c = new_st;
2309   c->loc = gfc_current_locus;
2310
2311   gfc_clear_new_st ();
2312   new_st.op = EXEC_FORALL;
2313   new_st.expr1 = mask;
2314   new_st.ext.forall_iterator = head;
2315   new_st.block = gfc_get_code ();
2316   new_st.block->op = EXEC_FORALL;
2317   new_st.block->next = c;
2318
2319   *st = ST_FORALL;
2320   return MATCH_YES;
2321
2322 syntax:
2323   gfc_syntax_error (ST_FORALL);
2324
2325 cleanup:
2326   gfc_free_forall_iterator (head);
2327   gfc_free_expr (mask);
2328   gfc_free_statements (c);
2329   return MATCH_NO;
2330 }
2331
2332
2333 /* Match a DO statement.  */
2334
2335 match
2336 gfc_match_do (void)
2337 {
2338   gfc_iterator iter, *ip;
2339   locus old_loc;
2340   gfc_st_label *label;
2341   match m;
2342
2343   old_loc = gfc_current_locus;
2344
2345   label = NULL;
2346   iter.var = iter.start = iter.end = iter.step = NULL;
2347
2348   m = gfc_match_label ();
2349   if (m == MATCH_ERROR)
2350     return m;
2351
2352   if (gfc_match (" do") != MATCH_YES)
2353     return MATCH_NO;
2354
2355   m = gfc_match_st_label (&label);
2356   if (m == MATCH_ERROR)
2357     goto cleanup;
2358
2359   /* Match an infinite DO, make it like a DO WHILE(.TRUE.).  */
2360
2361   if (gfc_match_eos () == MATCH_YES)
2362     {
2363       iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
2364       new_st.op = EXEC_DO_WHILE;
2365       goto done;
2366     }
2367
2368   /* Match an optional comma, if no comma is found, a space is obligatory.  */
2369   if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
2370     return MATCH_NO;
2371
2372   /* Check for balanced parens.  */
2373
2374   if (gfc_match_parens () == MATCH_ERROR)
2375     return MATCH_ERROR;
2376
2377   if (gfc_match (" concurrent") == MATCH_YES)
2378     {
2379       gfc_forall_iterator *head;
2380       gfc_expr *mask;
2381
2382       if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: DO CONCURRENT "
2383                            "construct at %C") == FAILURE)
2384         return MATCH_ERROR;
2385
2386
2387       mask = NULL;
2388       head = NULL;
2389       m = match_forall_header (&head, &mask);
2390
2391       if (m == MATCH_NO)
2392         return m;
2393       if (m == MATCH_ERROR)
2394         goto concurr_cleanup;
2395
2396       if (gfc_match_eos () != MATCH_YES)
2397         goto concurr_cleanup;
2398
2399       if (label != NULL
2400            && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2401         goto concurr_cleanup;
2402
2403       new_st.label1 = label;
2404       new_st.op = EXEC_DO_CONCURRENT;
2405       new_st.expr1 = mask;
2406       new_st.ext.forall_iterator = head;
2407
2408       return MATCH_YES;
2409
2410 concurr_cleanup:
2411       gfc_syntax_error (ST_DO);
2412       gfc_free_expr (mask);
2413       gfc_free_forall_iterator (head);
2414       return MATCH_ERROR;
2415     }
2416
2417   /* See if we have a DO WHILE.  */
2418   if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
2419     {
2420       new_st.op = EXEC_DO_WHILE;
2421       goto done;
2422     }
2423
2424   /* The abortive DO WHILE may have done something to the symbol
2425      table, so we start over.  */
2426   gfc_undo_symbols ();
2427   gfc_current_locus = old_loc;
2428
2429   gfc_match_label ();           /* This won't error.  */
2430   gfc_match (" do ");           /* This will work.  */
2431
2432   gfc_match_st_label (&label);  /* Can't error out.  */
2433   gfc_match_char (',');         /* Optional comma.  */
2434
2435   m = gfc_match_iterator (&iter, 0);
2436   if (m == MATCH_NO)
2437     return MATCH_NO;
2438   if (m == MATCH_ERROR)
2439     goto cleanup;
2440
2441   iter.var->symtree->n.sym->attr.implied_index = 0;
2442   gfc_check_do_variable (iter.var->symtree);
2443
2444   if (gfc_match_eos () != MATCH_YES)
2445     {
2446       gfc_syntax_error (ST_DO);
2447       goto cleanup;
2448     }
2449
2450   new_st.op = EXEC_DO;
2451
2452 done:
2453   if (label != NULL
2454       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2455     goto cleanup;
2456
2457   new_st.label1 = label;
2458
2459   if (new_st.op == EXEC_DO_WHILE)
2460     new_st.expr1 = iter.end;
2461   else
2462     {
2463       new_st.ext.iterator = ip = gfc_get_iterator ();
2464       *ip = iter;
2465     }
2466
2467   return MATCH_YES;
2468
2469 cleanup:
2470   gfc_free_iterator (&iter, 0);
2471
2472   return MATCH_ERROR;
2473 }
2474
2475
2476 /* Match an EXIT or CYCLE statement.  */
2477
2478 static match
2479 match_exit_cycle (gfc_statement st, gfc_exec_op op)
2480 {
2481   gfc_state_data *p, *o;
2482   gfc_symbol *sym;
2483   match m;
2484   int cnt;
2485
2486   if (gfc_match_eos () == MATCH_YES)
2487     sym = NULL;
2488   else
2489     {
2490       char name[GFC_MAX_SYMBOL_LEN + 1];
2491       gfc_symtree* stree;
2492
2493       m = gfc_match ("% %n%t", name);
2494       if (m == MATCH_ERROR)
2495         return MATCH_ERROR;
2496       if (m == MATCH_NO)
2497         {
2498           gfc_syntax_error (st);
2499           return MATCH_ERROR;
2500         }
2501
2502       /* Find the corresponding symbol.  If there's a BLOCK statement
2503          between here and the label, it is not in gfc_current_ns but a parent
2504          namespace!  */
2505       stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
2506       if (!stree)
2507         {
2508           gfc_error ("Name '%s' in %s statement at %C is unknown",
2509                      name, gfc_ascii_statement (st));
2510           return MATCH_ERROR;
2511         }
2512
2513       sym = stree->n.sym;
2514       if (sym->attr.flavor != FL_LABEL)
2515         {
2516           gfc_error ("Name '%s' in %s statement at %C is not a construct name",
2517                      name, gfc_ascii_statement (st));
2518           return MATCH_ERROR;
2519         }
2520     }
2521
2522   /* Find the loop specified by the label (or lack of a label).  */
2523   for (o = NULL, p = gfc_state_stack; p; p = p->previous)
2524     if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
2525       o = p;
2526     else if (p->state == COMP_CRITICAL)
2527       {
2528         gfc_error("%s statement at %C leaves CRITICAL construct",
2529                   gfc_ascii_statement (st));
2530         return MATCH_ERROR;
2531       }
2532     else if (p->state == COMP_DO_CONCURRENT
2533              && (op == EXEC_EXIT || (sym && sym != p->sym)))
2534       {
2535         /* F2008, C821 & C845.  */
2536         gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2537                   gfc_ascii_statement (st));
2538         return MATCH_ERROR;
2539       }
2540     else if ((sym && sym == p->sym)
2541              || (!sym && (p->state == COMP_DO
2542                           || p->state == COMP_DO_CONCURRENT)))
2543       break;
2544
2545   if (p == NULL)
2546     {
2547       if (sym == NULL)
2548         gfc_error ("%s statement at %C is not within a construct",
2549                    gfc_ascii_statement (st));
2550       else
2551         gfc_error ("%s statement at %C is not within construct '%s'",
2552                    gfc_ascii_statement (st), sym->name);
2553
2554       return MATCH_ERROR;
2555     }
2556
2557   /* Special checks for EXIT from non-loop constructs.  */
2558   switch (p->state)
2559     {
2560     case COMP_DO:
2561     case COMP_DO_CONCURRENT:
2562       break;
2563
2564     case COMP_CRITICAL:
2565       /* This is already handled above.  */
2566       gcc_unreachable ();
2567
2568     case COMP_ASSOCIATE:
2569     case COMP_BLOCK:
2570     case COMP_IF:
2571     case COMP_SELECT:
2572     case COMP_SELECT_TYPE:
2573       gcc_assert (sym);
2574       if (op == EXEC_CYCLE)
2575         {
2576           gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2577                      " construct '%s'", sym->name);
2578           return MATCH_ERROR;
2579         }
2580       gcc_assert (op == EXEC_EXIT);
2581       if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: EXIT statement with no"
2582                           " do-construct-name at %C") == FAILURE)
2583         return MATCH_ERROR;
2584       break;
2585
2586     default:
2587       gfc_error ("%s statement at %C is not applicable to construct '%s'",
2588                  gfc_ascii_statement (st), sym->name);
2589       return MATCH_ERROR;
2590     }
2591
2592   if (o != NULL)
2593     {
2594       gfc_error ("%s statement at %C leaving OpenMP structured block",
2595                  gfc_ascii_statement (st));
2596       return MATCH_ERROR;
2597     }
2598
2599   for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
2600     o = o->previous;
2601   if (cnt > 0
2602       && o != NULL
2603       && o->state == COMP_OMP_STRUCTURED_BLOCK
2604       && (o->head->op == EXEC_OMP_DO
2605           || o->head->op == EXEC_OMP_PARALLEL_DO))
2606     {
2607       int collapse = 1;
2608       gcc_assert (o->head->next != NULL
2609                   && (o->head->next->op == EXEC_DO
2610                       || o->head->next->op == EXEC_DO_WHILE)
2611                   && o->previous != NULL
2612                   && o->previous->tail->op == o->head->op);
2613       if (o->previous->tail->ext.omp_clauses != NULL
2614           && o->previous->tail->ext.omp_clauses->collapse > 1)
2615         collapse = o->previous->tail->ext.omp_clauses->collapse;
2616       if (st == ST_EXIT && cnt <= collapse)
2617         {
2618           gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2619           return MATCH_ERROR;
2620         }
2621       if (st == ST_CYCLE && cnt < collapse)
2622         {
2623           gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2624                      " !$OMP DO loop");
2625           return MATCH_ERROR;
2626         }
2627     }
2628
2629   /* Save the first statement in the construct - needed by the backend.  */
2630   new_st.ext.which_construct = p->construct;
2631
2632   new_st.op = op;
2633
2634   return MATCH_YES;
2635 }
2636
2637
2638 /* Match the EXIT statement.  */
2639
2640 match
2641 gfc_match_exit (void)
2642 {
2643   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
2644 }
2645
2646
2647 /* Match the CYCLE statement.  */
2648
2649 match
2650 gfc_match_cycle (void)
2651 {
2652   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
2653 }
2654
2655
2656 /* Match a number or character constant after an (ALL) STOP or PAUSE statement.  */
2657
2658 static match
2659 gfc_match_stopcode (gfc_statement st)
2660 {
2661   gfc_expr *e;
2662   match m;
2663
2664   e = NULL;
2665
2666   if (gfc_match_eos () != MATCH_YES)
2667     {
2668       m = gfc_match_init_expr (&e);
2669       if (m == MATCH_ERROR)
2670         goto cleanup;
2671       if (m == MATCH_NO)
2672         goto syntax;
2673
2674       if (gfc_match_eos () != MATCH_YES)
2675         goto syntax;
2676     }
2677
2678   if (gfc_pure (NULL))
2679     {
2680       gfc_error ("%s statement not allowed in PURE procedure at %C",
2681                  gfc_ascii_statement (st));
2682       goto cleanup;
2683     }
2684
2685   if (gfc_implicit_pure (NULL))
2686     gfc_current_ns->proc_name->attr.implicit_pure = 0;
2687
2688   if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
2689     {
2690       gfc_error ("Image control statement STOP at %C in CRITICAL block");
2691       goto cleanup;
2692     }
2693   if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
2694     {
2695       gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2696       goto cleanup;
2697     }
2698
2699   if (e != NULL)
2700     {
2701       if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
2702         {
2703           gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2704                      &e->where);
2705           goto cleanup;
2706         }
2707
2708       if (e->rank != 0)
2709         {
2710           gfc_error ("STOP code at %L must be scalar",
2711                      &e->where);
2712           goto cleanup;
2713         }
2714
2715       if (e->ts.type == BT_CHARACTER
2716           && e->ts.kind != gfc_default_character_kind)
2717         {
2718           gfc_error ("STOP code at %L must be default character KIND=%d",
2719                      &e->where, (int) gfc_default_character_kind);
2720           goto cleanup;
2721         }
2722
2723       if (e->ts.type == BT_INTEGER
2724           && e->ts.kind != gfc_default_integer_kind)
2725         {
2726           gfc_error ("STOP code at %L must be default integer KIND=%d",
2727                      &e->where, (int) gfc_default_integer_kind);
2728           goto cleanup;
2729         }
2730     }
2731
2732   switch (st)
2733     {
2734     case ST_STOP:
2735       new_st.op = EXEC_STOP;
2736       break;
2737     case ST_ERROR_STOP:
2738       new_st.op = EXEC_ERROR_STOP;
2739       break;
2740     case ST_PAUSE:
2741       new_st.op = EXEC_PAUSE;
2742       break;
2743     default:
2744       gcc_unreachable ();
2745     }
2746
2747   new_st.expr1 = e;
2748   new_st.ext.stop_code = -1;
2749
2750   return MATCH_YES;
2751
2752 syntax:
2753   gfc_syntax_error (st);
2754
2755 cleanup:
2756
2757   gfc_free_expr (e);
2758   return MATCH_ERROR;
2759 }
2760
2761
2762 /* Match the (deprecated) PAUSE statement.  */
2763
2764 match
2765 gfc_match_pause (void)
2766 {
2767   match m;
2768
2769   m = gfc_match_stopcode (ST_PAUSE);
2770   if (m == MATCH_YES)
2771     {
2772       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
2773           " at %C")
2774           == FAILURE)
2775         m = MATCH_ERROR;
2776     }
2777   return m;
2778 }
2779
2780
2781 /* Match the STOP statement.  */
2782
2783 match
2784 gfc_match_stop (void)
2785 {
2786   return gfc_match_stopcode (ST_STOP);
2787 }
2788
2789
2790 /* Match the ERROR STOP statement.  */
2791
2792 match
2793 gfc_match_error_stop (void)
2794 {
2795   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C")
2796       == FAILURE)
2797     return MATCH_ERROR;
2798
2799   return gfc_match_stopcode (ST_ERROR_STOP);
2800 }
2801
2802
2803 /* Match LOCK/UNLOCK statement. Syntax:
2804      LOCK ( lock-variable [ , lock-stat-list ] )
2805      UNLOCK ( lock-variable [ , sync-stat-list ] )
2806    where lock-stat is ACQUIRED_LOCK or sync-stat
2807    and sync-stat is STAT= or ERRMSG=.  */
2808
2809 static match
2810 lock_unlock_statement (gfc_statement st)
2811 {
2812   match m;
2813   gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg;
2814   bool saw_acq_lock, saw_stat, saw_errmsg;
2815
2816   tmp = lockvar = acq_lock = stat = errmsg = NULL;
2817   saw_acq_lock = saw_stat = saw_errmsg = false;
2818
2819   if (gfc_pure (NULL))
2820     {
2821       gfc_error ("Image control statement %s at %C in PURE procedure",
2822                  st == ST_LOCK ? "LOCK" : "UNLOCK");
2823       return MATCH_ERROR;
2824     }
2825
2826   if (gfc_implicit_pure (NULL))
2827     gfc_current_ns->proc_name->attr.implicit_pure = 0;
2828
2829   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
2830     {
2831        gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2832        return MATCH_ERROR;
2833     }
2834
2835   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
2836     {
2837       gfc_error ("Image control statement %s at %C in CRITICAL block",
2838                  st == ST_LOCK ? "LOCK" : "UNLOCK");
2839       return MATCH_ERROR;
2840     }
2841
2842   if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
2843     {
2844       gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
2845                  st == ST_LOCK ? "LOCK" : "UNLOCK");
2846       return MATCH_ERROR;
2847     }
2848
2849   if (gfc_match_char ('(') != MATCH_YES)
2850     goto syntax;
2851
2852   if (gfc_match ("%e", &lockvar) != MATCH_YES)
2853     goto syntax;
2854   m = gfc_match_char (',');
2855   if (m == MATCH_ERROR)
2856     goto syntax;
2857   if (m == MATCH_NO)
2858     {
2859       m = gfc_match_char (')');
2860       if (m == MATCH_YES)
2861         goto done;
2862       goto syntax;
2863     }
2864
2865   for (;;)
2866     {
2867       m = gfc_match (" stat = %v", &tmp);
2868       if (m == MATCH_ERROR)
2869         goto syntax;
2870       if (m == MATCH_YES)
2871         {
2872           if (saw_stat)
2873             {
2874               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2875               goto cleanup;
2876             }
2877           stat = tmp;
2878           saw_stat = true;
2879
2880           m = gfc_match_char (',');
2881           if (m == MATCH_YES)
2882             continue;
2883
2884           tmp = NULL;
2885           break;
2886         }
2887
2888       m = gfc_match (" errmsg = %v", &tmp);
2889       if (m == MATCH_ERROR)
2890         goto syntax;
2891       if (m == MATCH_YES)
2892         {
2893           if (saw_errmsg)
2894             {
2895               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2896               goto cleanup;
2897             }
2898           errmsg = tmp;
2899           saw_errmsg = true;
2900
2901           m = gfc_match_char (',');
2902           if (m == MATCH_YES)
2903             continue;
2904
2905           tmp = NULL;
2906           break;
2907         }
2908
2909       m = gfc_match (" acquired_lock = %v", &tmp);
2910       if (m == MATCH_ERROR || st == ST_UNLOCK)
2911         goto syntax;
2912       if (m == MATCH_YES)
2913         {
2914           if (saw_acq_lock)
2915             {
2916               gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
2917                          &tmp->where);
2918               goto cleanup;
2919             }
2920           acq_lock = tmp;
2921           saw_acq_lock = true;
2922
2923           m = gfc_match_char (',');
2924           if (m == MATCH_YES)
2925             continue;
2926
2927           tmp = NULL;
2928           break;
2929         }
2930
2931       break;
2932     }
2933
2934   if (m == MATCH_ERROR)
2935     goto syntax;
2936
2937   if (gfc_match (" )%t") != MATCH_YES)
2938     goto syntax;
2939
2940 done:
2941   switch (st)
2942     {
2943     case ST_LOCK:
2944       new_st.op = EXEC_LOCK;
2945       break;
2946     case ST_UNLOCK:
2947       new_st.op = EXEC_UNLOCK;
2948       break;
2949     default:
2950       gcc_unreachable ();
2951     }
2952
2953   new_st.expr1 = lockvar;
2954   new_st.expr2 = stat;
2955   new_st.expr3 = errmsg;
2956   new_st.expr4 = acq_lock;
2957
2958   return MATCH_YES;
2959
2960 syntax:
2961   gfc_syntax_error (st);
2962
2963 cleanup:
2964   gfc_free_expr (tmp);
2965   gfc_free_expr (lockvar);
2966   gfc_free_expr (acq_lock);
2967   gfc_free_expr (stat);
2968   gfc_free_expr (errmsg);
2969
2970   return MATCH_ERROR;
2971 }
2972
2973
2974 match
2975 gfc_match_lock (void)
2976 {
2977   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: LOCK statement at %C")
2978       == FAILURE)
2979     return MATCH_ERROR;
2980
2981   return lock_unlock_statement (ST_LOCK);
2982 }
2983
2984
2985 match
2986 gfc_match_unlock (void)
2987 {
2988   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: UNLOCK statement at %C")
2989       == FAILURE)
2990     return MATCH_ERROR;
2991
2992   return lock_unlock_statement (ST_UNLOCK);
2993 }
2994
2995
2996 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2997      SYNC ALL [(sync-stat-list)]
2998      SYNC MEMORY [(sync-stat-list)]
2999      SYNC IMAGES (image-set [, sync-stat-list] )
3000    with sync-stat is int-expr or *.  */
3001
3002 static match
3003 sync_statement (gfc_statement st)
3004 {
3005   match m;
3006   gfc_expr *tmp, *imageset, *stat, *errmsg;
3007   bool saw_stat, saw_errmsg;
3008
3009   tmp = imageset = stat = errmsg = NULL;
3010   saw_stat = saw_errmsg = false;
3011
3012   if (gfc_pure (NULL))
3013     {
3014       gfc_error ("Image control statement SYNC at %C in PURE procedure");
3015       return MATCH_ERROR;
3016     }
3017
3018   if (gfc_implicit_pure (NULL))
3019     gfc_current_ns->proc_name->attr.implicit_pure = 0;
3020
3021   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C")
3022       == FAILURE)
3023     return MATCH_ERROR;
3024
3025   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3026     {
3027        gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3028        return MATCH_ERROR;
3029     }
3030
3031   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
3032     {
3033       gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3034       return MATCH_ERROR;
3035     }
3036
3037   if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
3038     {
3039       gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3040       return MATCH_ERROR;
3041     }
3042
3043   if (gfc_match_eos () == MATCH_YES)
3044     {
3045       if (st == ST_SYNC_IMAGES)
3046         goto syntax;
3047       goto done;
3048     }
3049
3050   if (gfc_match_char ('(') != MATCH_YES)
3051     goto syntax;
3052
3053   if (st == ST_SYNC_IMAGES)
3054     {
3055       /* Denote '*' as imageset == NULL.  */
3056       m = gfc_match_char ('*');
3057       if (m == MATCH_ERROR)
3058         goto syntax;
3059       if (m == MATCH_NO)
3060         {
3061           if (gfc_match ("%e", &imageset) != MATCH_YES)
3062             goto syntax;
3063         }
3064       m = gfc_match_char (',');
3065       if (m == MATCH_ERROR)
3066         goto syntax;
3067       if (m == MATCH_NO)
3068         {
3069           m = gfc_match_char (')');
3070           if (m == MATCH_YES)
3071             goto done;
3072           goto syntax;
3073         }
3074     }
3075
3076   for (;;)
3077     {
3078       m = gfc_match (" stat = %v", &tmp);
3079       if (m == MATCH_ERROR)
3080         goto syntax;
3081       if (m == MATCH_YES)
3082         {
3083           if (saw_stat)
3084             {
3085               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3086               goto cleanup;
3087             }
3088           stat = tmp;
3089           saw_stat = true;
3090
3091           if (gfc_match_char (',') == MATCH_YES)
3092             continue;
3093
3094           tmp = NULL;
3095           break;
3096         }
3097
3098       m = gfc_match (" errmsg = %v", &tmp);
3099       if (m == MATCH_ERROR)
3100         goto syntax;
3101       if (m == MATCH_YES)
3102         {
3103           if (saw_errmsg)
3104             {
3105               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3106               goto cleanup;
3107             }
3108           errmsg = tmp;
3109           saw_errmsg = true;
3110
3111           if (gfc_match_char (',') == MATCH_YES)
3112             continue;
3113
3114           tmp = NULL;
3115           break;
3116         }
3117
3118         break;
3119     }
3120
3121   if (m == MATCH_ERROR)
3122     goto syntax;
3123
3124   if (gfc_match (" )%t") != MATCH_YES)
3125     goto syntax;
3126
3127 done:
3128   switch (st)
3129     {
3130     case ST_SYNC_ALL:
3131       new_st.op = EXEC_SYNC_ALL;
3132       break;
3133     case ST_SYNC_IMAGES:
3134       new_st.op = EXEC_SYNC_IMAGES;
3135       break;
3136     case ST_SYNC_MEMORY:
3137       new_st.op = EXEC_SYNC_MEMORY;
3138       break;
3139     default:
3140       gcc_unreachable ();
3141     }
3142
3143   new_st.expr1 = imageset;
3144   new_st.expr2 = stat;
3145   new_st.expr3 = errmsg;
3146
3147   return MATCH_YES;
3148
3149 syntax:
3150   gfc_syntax_error (st);
3151
3152 cleanup:
3153   gfc_free_expr (tmp);
3154   gfc_free_expr (imageset);
3155   gfc_free_expr (stat);
3156   gfc_free_expr (errmsg);
3157
3158   return MATCH_ERROR;
3159 }
3160
3161
3162 /* Match SYNC ALL statement.  */
3163
3164 match
3165 gfc_match_sync_all (void)
3166 {
3167   return sync_statement (ST_SYNC_ALL);
3168 }
3169
3170
3171 /* Match SYNC IMAGES statement.  */
3172
3173 match
3174 gfc_match_sync_images (void)
3175 {
3176   return sync_statement (ST_SYNC_IMAGES);
3177 }
3178
3179
3180 /* Match SYNC MEMORY statement.  */
3181
3182 match
3183 gfc_match_sync_memory (void)
3184 {
3185   return sync_statement (ST_SYNC_MEMORY);
3186 }
3187
3188
3189 /* Match a CONTINUE statement.  */
3190
3191 match
3192 gfc_match_continue (void)
3193 {
3194   if (gfc_match_eos () != MATCH_YES)
3195     {
3196       gfc_syntax_error (ST_CONTINUE);
3197       return MATCH_ERROR;
3198     }
3199
3200   new_st.op = EXEC_CONTINUE;
3201   return MATCH_YES;
3202 }
3203
3204
3205 /* Match the (deprecated) ASSIGN statement.  */
3206
3207 match
3208 gfc_match_assign (void)
3209 {
3210   gfc_expr *expr;
3211   gfc_st_label *label;
3212
3213   if (gfc_match (" %l", &label) == MATCH_YES)
3214     {
3215       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
3216         return MATCH_ERROR;
3217       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
3218         {
3219           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
3220                               "statement at %C")
3221               == FAILURE)
3222             return MATCH_ERROR;
3223
3224           expr->symtree->n.sym->attr.assign = 1;
3225
3226           new_st.op = EXEC_LABEL_ASSIGN;
3227           new_st.label1 = label;
3228           new_st.expr1 = expr;
3229           return MATCH_YES;
3230         }
3231     }
3232   return MATCH_NO;
3233 }
3234
3235
3236 /* Match the GO TO statement.  As a computed GOTO statement is
3237    matched, it is transformed into an equivalent SELECT block.  No
3238    tree is necessary, and the resulting jumps-to-jumps are
3239    specifically optimized away by the back end.  */
3240
3241 match
3242 gfc_match_goto (void)
3243 {
3244   gfc_code *head, *tail;
3245   gfc_expr *expr;
3246   gfc_case *cp;
3247   gfc_st_label *label;
3248   int i;
3249   match m;
3250
3251   if (gfc_match (" %l%t", &label) == MATCH_YES)
3252     {
3253       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
3254         return MATCH_ERROR;
3255
3256       new_st.op = EXEC_GOTO;
3257       new_st.label1 = label;
3258       return MATCH_YES;
3259     }
3260
3261   /* The assigned GO TO statement.  */
3262
3263   if (gfc_match_variable (&expr, 0) == MATCH_YES)
3264     {
3265       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
3266                           "statement at %C")
3267           == FAILURE)
3268         return MATCH_ERROR;
3269
3270       new_st.op = EXEC_GOTO;
3271       new_st.expr1 = expr;
3272
3273       if (gfc_match_eos () == MATCH_YES)
3274         return MATCH_YES;
3275
3276       /* Match label list.  */
3277       gfc_match_char (',');
3278       if (gfc_match_char ('(') != MATCH_YES)
3279         {
3280           gfc_syntax_error (ST_GOTO);
3281           return MATCH_ERROR;
3282         }
3283       head = tail = NULL;
3284
3285       do
3286         {
3287           m = gfc_match_st_label (&label);
3288           if (m != MATCH_YES)
3289             goto syntax;
3290
3291           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
3292             goto cleanup;
3293
3294           if (head == NULL)
3295             head = tail = gfc_get_code ();
3296           else
3297             {
3298               tail->block = gfc_get_code ();
3299               tail = tail->block;
3300             }
3301
3302           tail->label1 = label;
3303           tail->op = EXEC_GOTO;
3304         }
3305       while (gfc_match_char (',') == MATCH_YES);
3306
3307       if (gfc_match (")%t") != MATCH_YES)
3308         goto syntax;
3309
3310       if (head == NULL)
3311         {
3312            gfc_error ("Statement label list in GOTO at %C cannot be empty");
3313            goto syntax;
3314         }
3315       new_st.block = head;
3316
3317       return MATCH_YES;
3318     }
3319
3320   /* Last chance is a computed GO TO statement.  */
3321   if (gfc_match_char ('(') != MATCH_YES)
3322     {
3323       gfc_syntax_error (ST_GOTO);
3324       return MATCH_ERROR;
3325     }
3326
3327   head = tail = NULL;
3328   i = 1;
3329
3330   do
3331     {
3332       m = gfc_match_st_label (&label);
3333       if (m != MATCH_YES)
3334         goto syntax;
3335
3336       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
3337         goto cleanup;
3338
3339       if (head == NULL)
3340         head = tail = gfc_get_code ();
3341       else
3342         {
3343           tail->block = gfc_get_code ();
3344           tail = tail->block;
3345         }
3346
3347       cp = gfc_get_case ();
3348       cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
3349                                              NULL, i++);
3350
3351       tail->op = EXEC_SELECT;
3352       tail->ext.block.case_list = cp;
3353
3354       tail->next = gfc_get_code ();
3355       tail->next->op = EXEC_GOTO;
3356       tail->next->label1 = label;
3357     }
3358   while (gfc_match_char (',') == MATCH_YES);
3359
3360   if (gfc_match_char (')') != MATCH_YES)
3361     goto syntax;
3362
3363   if (head == NULL)
3364     {
3365       gfc_error ("Statement label list in GOTO at %C cannot be empty");
3366       goto syntax;
3367     }
3368
3369   /* Get the rest of the statement.  */
3370   gfc_match_char (',');
3371
3372   if (gfc_match (" %e%t", &expr) != MATCH_YES)
3373     goto syntax;
3374
3375   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO "
3376                       "at %C") == FAILURE)
3377     return MATCH_ERROR;
3378
3379   /* At this point, a computed GOTO has been fully matched and an
3380      equivalent SELECT statement constructed.  */
3381
3382   new_st.op = EXEC_SELECT;
3383   new_st.expr1 = NULL;
3384
3385   /* Hack: For a "real" SELECT, the expression is in expr. We put
3386      it in expr2 so we can distinguish then and produce the correct
3387      diagnostics.  */
3388   new_st.expr2 = expr;
3389   new_st.block = head;
3390   return MATCH_YES;
3391
3392 syntax:
3393   gfc_syntax_error (ST_GOTO);
3394 cleanup:
3395   gfc_free_statements (head);
3396   return MATCH_ERROR;
3397 }
3398
3399
3400 /* Frees a list of gfc_alloc structures.  */
3401
3402 void
3403 gfc_free_alloc_list (gfc_alloc *p)
3404 {
3405   gfc_alloc *q;
3406
3407   for (; p; p = q)
3408     {
3409       q = p->next;
3410       gfc_free_expr (p->expr);
3411       free (p);
3412     }
3413 }
3414
3415
3416 /* Match an ALLOCATE statement.  */
3417
3418 match
3419 gfc_match_allocate (void)
3420 {
3421   gfc_alloc *head, *tail;
3422   gfc_expr *stat, *errmsg, *tmp, *source, *mold;
3423   gfc_typespec ts;
3424   gfc_symbol *sym;
3425   match m;
3426   locus old_locus, deferred_locus;
3427   bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
3428
3429   head = tail = NULL;
3430   stat = errmsg = source = mold = tmp = NULL;
3431   saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
3432
3433   if (gfc_match_char ('(') != MATCH_YES)
3434     goto syntax;
3435
3436   /* Match an optional type-spec.  */
3437   old_locus = gfc_current_locus;
3438   m = match_type_spec (&ts);
3439   if (m == MATCH_ERROR)
3440     goto cleanup;
3441   else if (m == MATCH_NO)
3442     {
3443       char name[GFC_MAX_SYMBOL_LEN + 3];
3444
3445       if (gfc_match ("%n :: ", name) == MATCH_YES)
3446         {
3447           gfc_error ("Error in type-spec at %L", &old_locus);
3448           goto cleanup;
3449         }
3450
3451       ts.type = BT_UNKNOWN;
3452     }
3453   else
3454     {
3455       if (gfc_match (" :: ") == MATCH_YES)
3456         {
3457           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
3458                               "ALLOCATE at %L", &old_locus) == FAILURE)
3459             goto cleanup;
3460
3461           if (ts.deferred)
3462             {
3463               gfc_error ("Type-spec at %L cannot contain a deferred "
3464                          "type parameter", &old_locus);
3465               goto cleanup;
3466             }
3467         }
3468       else
3469         {
3470           ts.type = BT_UNKNOWN;
3471           gfc_current_locus = old_locus;
3472         }
3473     }
3474
3475   for (;;)
3476     {
3477       if (head == NULL)
3478         head = tail = gfc_get_alloc ();
3479       else
3480         {
3481           tail->next = gfc_get_alloc ();
3482           tail = tail->next;
3483         }
3484
3485       m = gfc_match_variable (&tail->expr, 0);
3486       if (m == MATCH_NO)
3487         goto syntax;
3488       if (m == MATCH_ERROR)
3489         goto cleanup;
3490
3491       if (gfc_check_do_variable (tail->expr->symtree))
3492         goto cleanup;
3493
3494       if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
3495         {
3496           gfc_error ("Bad allocate-object at %C for a PURE procedure");
3497           goto cleanup;
3498         }
3499
3500       if (gfc_implicit_pure (NULL)
3501             && gfc_impure_variable (tail->expr->symtree->n.sym))
3502         gfc_current_ns->proc_name->attr.implicit_pure = 0;
3503
3504       if (tail->expr->ts.deferred)
3505         {
3506           saw_deferred = true;
3507           deferred_locus = tail->expr->where;
3508         }
3509
3510       if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS
3511           || gfc_find_state (COMP_CRITICAL) == SUCCESS)
3512         {
3513           gfc_ref *ref;
3514           bool coarray = tail->expr->symtree->n.sym->attr.codimension;
3515           for (ref = tail->expr->ref; ref; ref = ref->next)
3516             if (ref->type == REF_COMPONENT)
3517               coarray = ref->u.c.component->attr.codimension;
3518
3519           if (coarray && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
3520             {
3521               gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
3522               goto cleanup;
3523             }
3524           if (coarray && gfc_find_state (COMP_CRITICAL) == SUCCESS)
3525             {
3526               gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
3527               goto cleanup;
3528             }
3529         }
3530
3531       /* The ALLOCATE statement had an optional typespec.  Check the
3532          constraints.  */
3533       if (ts.type != BT_UNKNOWN)
3534         {
3535           /* Enforce F03:C624.  */
3536           if (!gfc_type_compatible (&tail->expr->ts, &ts))
3537             {
3538               gfc_error ("Type of entity at %L is type incompatible with "
3539                          "typespec", &tail->expr->where);
3540               goto cleanup;
3541             }
3542
3543           /* Enforce F03:C627.  */
3544           if (ts.kind != tail->expr->ts.kind)
3545             {
3546               gfc_error ("Kind type parameter for entity at %L differs from "
3547                          "the kind type parameter of the typespec",
3548                          &tail->expr->where);
3549               goto cleanup;
3550             }
3551         }
3552
3553       if (tail->expr->ts.type == BT_DERIVED)
3554         tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
3555
3556       /* FIXME: disable the checking on derived types and arrays.  */
3557       sym = tail->expr->symtree->n.sym;
3558       b1 = !(tail->expr->ref
3559            && (tail->expr->ref->type == REF_COMPONENT
3560                 || tail->expr->ref->type == REF_ARRAY));
3561       if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
3562         b2 = !(CLASS_DATA (sym)->attr.allocatable
3563                || CLASS_DATA (sym)->attr.class_pointer);
3564       else
3565         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3566                       || sym->attr.proc_pointer);
3567       b3 = sym && sym->ns && sym->ns->proc_name
3568            && (sym->ns->proc_name->attr.allocatable
3569                 || sym->ns->proc_name->attr.pointer
3570                 || sym->ns->proc_name->attr.proc_pointer);
3571       if (b1 && b2 && !b3)
3572         {
3573           gfc_error ("Allocate-object at %L is not a nonprocedure pointer "
3574                      "or an allocatable variable", &tail->expr->where);
3575           goto cleanup;
3576         }
3577
3578       if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
3579         {
3580           gfc_error ("Shape specification for allocatable scalar at %C");
3581           goto cleanup;
3582         }
3583
3584       if (gfc_match_char (',') != MATCH_YES)
3585         break;
3586
3587 alloc_opt_list:
3588
3589       m = gfc_match (" stat = %v", &tmp);
3590       if (m == MATCH_ERROR)
3591         goto cleanup;
3592       if (m == MATCH_YES)
3593         {
3594           /* Enforce C630.  */
3595           if (saw_stat)
3596             {
3597               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3598               goto cleanup;
3599             }
3600
3601           stat = tmp;
3602           tmp = NULL;
3603           saw_stat = true;
3604
3605           if (gfc_check_do_variable (stat->symtree))
3606             goto cleanup;
3607
3608           if (gfc_match_char (',') == MATCH_YES)
3609             goto alloc_opt_list;
3610         }
3611
3612       m = gfc_match (" errmsg = %v", &tmp);
3613       if (m == MATCH_ERROR)
3614         goto cleanup;
3615       if (m == MATCH_YES)
3616         {
3617           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
3618                               &tmp->where) == FAILURE)
3619             goto cleanup;
3620
3621           /* Enforce C630.  */
3622           if (saw_errmsg)
3623             {
3624               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3625               goto cleanup;
3626             }
3627
3628           errmsg = tmp;
3629           tmp = NULL;
3630           saw_errmsg = true;
3631
3632           if (gfc_match_char (',') == MATCH_YES)
3633             goto alloc_opt_list;
3634         }
3635
3636       m = gfc_match (" source = %e", &tmp);
3637       if (m == MATCH_ERROR)
3638         goto cleanup;
3639       if (m == MATCH_YES)
3640         {
3641           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
3642                               &tmp->where) == FAILURE)
3643             goto cleanup;
3644
3645           /* Enforce C630.  */
3646           if (saw_source)
3647             {
3648               gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
3649               goto cleanup;
3650             }
3651
3652           /* The next 2 conditionals check C631.  */
3653           if (ts.type != BT_UNKNOWN)
3654             {
3655               gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3656                          &tmp->where, &old_locus);
3657               goto cleanup;
3658             }
3659
3660           if (head->next)
3661             {
3662               gfc_error ("SOURCE tag at %L requires only a single entity in "
3663                          "the allocation-list", &tmp->where);
3664               goto cleanup;
3665             }
3666
3667           source = tmp;
3668           tmp = NULL;
3669           saw_source = true;
3670
3671           if (gfc_match_char (',') == MATCH_YES)
3672             goto alloc_opt_list;
3673         }
3674
3675       m = gfc_match (" mold = %e", &tmp);
3676       if (m == MATCH_ERROR)
3677         goto cleanup;
3678       if (m == MATCH_YES)
3679         {
3680           if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L",
3681                               &tmp->where) == FAILURE)
3682             goto cleanup;
3683
3684           /* Check F08:C636.  */
3685           if (saw_mold)
3686             {
3687               gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
3688               goto cleanup;
3689             }
3690
3691           /* Check F08:C637.  */
3692           if (ts.type != BT_UNKNOWN)
3693             {
3694               gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3695                          &tmp->where, &old_locus);
3696               goto cleanup;
3697             }
3698
3699           mold = tmp;
3700           tmp = NULL;
3701           saw_mold = true;
3702           mold->mold = 1;
3703
3704           if (gfc_match_char (',') == MATCH_YES)
3705             goto alloc_opt_list;
3706         }
3707
3708         gfc_gobble_whitespace ();
3709
3710         if (gfc_peek_char () == ')')
3711           break;
3712     }
3713
3714   if (gfc_match (" )%t") != MATCH_YES)
3715     goto syntax;
3716
3717   /* Check F08:C637.  */
3718   if (source && mold)
3719     {
3720       gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3721                   &mold->where, &source->where);
3722       goto cleanup;
3723     }
3724
3725   /* Check F03:C623,  */
3726   if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
3727     {
3728       gfc_error ("Allocate-object at %L with a deferred type parameter "
3729                  "requires either a type-spec or SOURCE tag or a MOLD tag",
3730                  &deferred_locus);
3731       goto cleanup;
3732     }
3733
3734   new_st.op = EXEC_ALLOCATE;
3735   new_st.expr1 = stat;
3736   new_st.expr2 = errmsg;
3737   if (source)
3738     new_st.expr3 = source;
3739   else
3740     new_st.expr3 = mold;
3741   new_st.ext.alloc.list = head;
3742   new_st.ext.alloc.ts = ts;
3743
3744   return MATCH_YES;
3745
3746 syntax:
3747   gfc_syntax_error (ST_ALLOCATE);
3748
3749 cleanup:
3750   gfc_free_expr (errmsg);
3751   gfc_free_expr (source);
3752   gfc_free_expr (stat);
3753   gfc_free_expr (mold);
3754   if (tmp && tmp->expr_type) gfc_free_expr (tmp);
3755   gfc_free_alloc_list (head);
3756   return MATCH_ERROR;
3757 }
3758
3759
3760 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3761    a set of pointer assignments to intrinsic NULL().  */
3762
3763 match
3764 gfc_match_nullify (void)
3765 {
3766   gfc_code *tail;
3767   gfc_expr *e, *p;
3768   match m;
3769
3770   tail = NULL;
3771
3772   if (gfc_match_char ('(') != MATCH_YES)
3773     goto syntax;
3774
3775   for (;;)
3776     {
3777       m = gfc_match_variable (&p, 0);
3778       if (m == MATCH_ERROR)
3779         goto cleanup;
3780       if (m == MATCH_NO)
3781         goto syntax;
3782
3783       if (gfc_check_do_variable (p->symtree))
3784         goto cleanup;
3785
3786       /* F2008, C1242.  */
3787       if (gfc_is_coindexed (p))
3788         {
3789           gfc_error ("Pointer object at %C shall not be conindexed");
3790           goto cleanup;
3791         }
3792
3793       /* build ' => NULL() '.  */
3794       e = gfc_get_null_expr (&gfc_current_locus);
3795
3796       /* Chain to list.  */
3797       if (tail == NULL)
3798         tail = &new_st;
3799       else
3800         {
3801           tail->next = gfc_get_code ();
3802           tail = tail->next;
3803         }
3804
3805       tail->op = EXEC_POINTER_ASSIGN;
3806       tail->expr1 = p;
3807       tail->expr2 = e;
3808
3809       if (gfc_match (" )%t") == MATCH_YES)
3810         break;
3811       if (gfc_match_char (',') != MATCH_YES)
3812         goto syntax;
3813     }
3814
3815   return MATCH_YES;
3816
3817 syntax:
3818   gfc_syntax_error (ST_NULLIFY);
3819
3820 cleanup:
3821   gfc_free_statements (new_st.next);
3822   new_st.next = NULL;
3823   gfc_free_expr (new_st.expr1);
3824   new_st.expr1 = NULL;
3825   gfc_free_expr (new_st.expr2);
3826   new_st.expr2 = NULL;
3827   return MATCH_ERROR;
3828 }
3829
3830
3831 /* Match a DEALLOCATE statement.  */
3832
3833 match
3834 gfc_match_deallocate (void)
3835 {
3836   gfc_alloc *head, *tail;
3837   gfc_expr *stat, *errmsg, *tmp;
3838   gfc_symbol *sym;
3839   match m;
3840   bool saw_stat, saw_errmsg, b1, b2;
3841
3842   head = tail = NULL;
3843   stat = errmsg = tmp = NULL;
3844   saw_stat = saw_errmsg = false;
3845
3846   if (gfc_match_char ('(') != MATCH_YES)
3847     goto syntax;
3848
3849   for (;;)
3850     {
3851       if (head == NULL)
3852         head = tail = gfc_get_alloc ();
3853       else
3854         {
3855           tail->next = gfc_get_alloc ();
3856           tail = tail->next;
3857         }
3858
3859       m = gfc_match_variable (&tail->expr, 0);
3860       if (m == MATCH_ERROR)
3861         goto cleanup;
3862       if (m == MATCH_NO)
3863         goto syntax;
3864
3865       if (gfc_check_do_variable (tail->expr->symtree))
3866         goto cleanup;
3867
3868       sym = tail->expr->symtree->n.sym;
3869
3870       if (gfc_pure (NULL) && gfc_impure_variable (sym))
3871         {
3872           gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3873           goto cleanup;
3874         }
3875
3876       if (gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
3877         gfc_current_ns->proc_name->attr.implicit_pure = 0;
3878
3879       if (gfc_is_coarray (tail->expr)
3880           && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
3881         {
3882           gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
3883           goto cleanup;
3884         }
3885
3886       if (gfc_is_coarray (tail->expr)
3887           && gfc_find_state (COMP_CRITICAL) == SUCCESS)
3888         {
3889           gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
3890           goto cleanup;
3891         }
3892
3893       /* FIXME: disable the checking on derived types.  */
3894       b1 = !(tail->expr->ref
3895            && (tail->expr->ref->type == REF_COMPONENT
3896                || tail->expr->ref->type == REF_ARRAY));
3897       if (sym && sym->ts.type == BT_CLASS)
3898         b2 = !(CLASS_DATA (sym)->attr.allocatable
3899                || CLASS_DATA (sym)->attr.class_pointer);
3900       else
3901         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3902                       || sym->attr.proc_pointer);
3903       if (b1 && b2)
3904         {
3905           gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3906                      "or an allocatable variable");
3907           goto cleanup;
3908         }
3909
3910       if (gfc_match_char (',') != MATCH_YES)
3911         break;
3912
3913 dealloc_opt_list:
3914
3915       m = gfc_match (" stat = %v", &tmp);
3916       if (m == MATCH_ERROR)
3917         goto cleanup;
3918       if (m == MATCH_YES)
3919         {
3920           if (saw_stat)
3921             {
3922               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3923               gfc_free_expr (tmp);
3924               goto cleanup;
3925             }
3926
3927           stat = tmp;
3928           saw_stat = true;
3929
3930           if (gfc_check_do_variable (stat->symtree))
3931             goto cleanup;
3932
3933           if (gfc_match_char (',') == MATCH_YES)
3934             goto dealloc_opt_list;
3935         }
3936
3937       m = gfc_match (" errmsg = %v", &tmp);
3938       if (m == MATCH_ERROR)
3939         goto cleanup;
3940       if (m == MATCH_YES)
3941         {
3942           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
3943                               &tmp->where) == FAILURE)
3944             goto cleanup;
3945
3946           if (saw_errmsg)
3947             {
3948               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3949               gfc_free_expr (tmp);
3950               goto cleanup;
3951             }
3952
3953           errmsg = tmp;
3954           saw_errmsg = true;
3955
3956           if (gfc_match_char (',') == MATCH_YES)
3957             goto dealloc_opt_list;
3958         }
3959
3960         gfc_gobble_whitespace ();
3961
3962         if (gfc_peek_char () == ')')
3963           break;
3964     }
3965
3966   if (gfc_match (" )%t") != MATCH_YES)
3967     goto syntax;
3968
3969   new_st.op = EXEC_DEALLOCATE;
3970   new_st.expr1 = stat;
3971   new_st.expr2 = errmsg;
3972   new_st.ext.alloc.list = head;
3973
3974   return MATCH_YES;
3975
3976 syntax:
3977   gfc_syntax_error (ST_DEALLOCATE);
3978
3979 cleanup:
3980   gfc_free_expr (errmsg);
3981   gfc_free_expr (stat);
3982   gfc_free_alloc_list (head);
3983   return MATCH_ERROR;
3984 }
3985
3986
3987 /* Match a RETURN statement.  */
3988
3989 match
3990 gfc_match_return (void)
3991 {
3992   gfc_expr *e;
3993   match m;
3994   gfc_compile_state s;
3995
3996   e = NULL;
3997
3998   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
3999     {
4000       gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4001       return MATCH_ERROR;
4002     }
4003
4004   if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
4005     {
4006       gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4007       return MATCH_ERROR;
4008     }
4009
4010   if (gfc_match_eos () == MATCH_YES)
4011     goto done;
4012
4013   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
4014     {
4015       gfc_error ("Alternate RETURN statement at %C is only allowed within "
4016                  "a SUBROUTINE");
4017       goto cleanup;
4018     }
4019
4020   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN "
4021                       "at %C") == FAILURE)
4022     return MATCH_ERROR;
4023
4024   if (gfc_current_form == FORM_FREE)
4025     {
4026       /* The following are valid, so we can't require a blank after the
4027         RETURN keyword:
4028           return+1
4029           return(1)  */
4030       char c = gfc_peek_ascii_char ();
4031       if (ISALPHA (c) || ISDIGIT (c))
4032         return MATCH_NO;
4033     }
4034
4035   m = gfc_match (" %e%t", &e);
4036   if (m == MATCH_YES)
4037     goto done;
4038   if (m == MATCH_ERROR)
4039     goto cleanup;
4040
4041   gfc_syntax_error (ST_RETURN);
4042
4043 cleanup:
4044   gfc_free_expr (e);
4045   return MATCH_ERROR;
4046
4047 done:
4048   gfc_enclosing_unit (&s);
4049   if (s == COMP_PROGRAM
4050       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
4051                         "main program at %C") == FAILURE)
4052       return MATCH_ERROR;
4053
4054   new_st.op = EXEC_RETURN;
4055   new_st.expr1 = e;
4056
4057   return MATCH_YES;
4058 }
4059
4060
4061 /* Match the call of a type-bound procedure, if CALL%var has already been
4062    matched and var found to be a derived-type variable.  */
4063
4064 static match
4065 match_typebound_call (gfc_symtree* varst)
4066 {
4067   gfc_expr* base;
4068   match m;
4069
4070   base = gfc_get_expr ();
4071   base->expr_type = EXPR_VARIABLE;
4072   base->symtree = varst;
4073   base->where = gfc_current_locus;
4074   gfc_set_sym_referenced (varst->n.sym);
4075
4076   m = gfc_match_varspec (base, 0, true, true);
4077   if (m == MATCH_NO)
4078     gfc_error ("Expected component reference at %C");
4079   if (m != MATCH_YES)
4080     return MATCH_ERROR;
4081
4082   if (gfc_match_eos () != MATCH_YES)
4083     {
4084       gfc_error ("Junk after CALL at %C");
4085       return MATCH_ERROR;
4086     }
4087
4088   if (base->expr_type == EXPR_COMPCALL)
4089     new_st.op = EXEC_COMPCALL;
4090   else if (base->expr_type == EXPR_PPC)
4091     new_st.op = EXEC_CALL_PPC;
4092   else
4093     {
4094       gfc_error ("Expected type-bound procedure or procedure pointer component "
4095                  "at %C");
4096       return MATCH_ERROR;
4097     }
4098   new_st.expr1 = base;
4099
4100   return MATCH_YES;
4101 }
4102
4103
4104 /* Match a CALL statement.  The tricky part here are possible
4105    alternate return specifiers.  We handle these by having all
4106    "subroutines" actually return an integer via a register that gives
4107    the return number.  If the call specifies alternate returns, we
4108    generate code for a SELECT statement whose case clauses contain
4109    GOTOs to the various labels.  */
4110
4111 match
4112 gfc_match_call (void)
4113 {
4114   char name[GFC_MAX_SYMBOL_LEN + 1];
4115   gfc_actual_arglist *a, *arglist;
4116   gfc_case *new_case;
4117   gfc_symbol *sym;
4118   gfc_symtree *st;
4119   gfc_code *c;
4120   match m;
4121   int i;
4122
4123   arglist = NULL;
4124
4125   m = gfc_match ("% %n", name);
4126   if (m == MATCH_NO)
4127     goto syntax;
4128   if (m != MATCH_YES)
4129     return m;
4130
4131   if (gfc_get_ha_sym_tree (name, &st))
4132     return MATCH_ERROR;
4133
4134   sym = st->n.sym;
4135
4136   /* If this is a variable of derived-type, it probably starts a type-bound
4137      procedure call.  */
4138   if ((sym->attr.flavor != FL_PROCEDURE
4139        || gfc_is_function_return_value (sym, gfc_current_ns))
4140       && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
4141     return match_typebound_call (st);
4142
4143   /* If it does not seem to be callable (include functions so that the
4144      right association is made.  They are thrown out in resolution.)
4145      ...  */
4146   if (!sym->attr.generic
4147         && !sym->attr.subroutine
4148         && !sym->attr.function)
4149     {
4150       if (!(sym->attr.external && !sym->attr.referenced))
4151         {
4152           /* ...create a symbol in this scope...  */
4153           if (sym->ns != gfc_current_ns
4154                 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
4155             return MATCH_ERROR;
4156
4157           if (sym != st->n.sym)
4158             sym = st->n.sym;
4159         }
4160
4161       /* ...and then to try to make the symbol into a subroutine.  */
4162       if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
4163         return MATCH_ERROR;
4164     }
4165
4166   gfc_set_sym_referenced (sym);
4167
4168   if (gfc_match_eos () != MATCH_YES)
4169     {
4170       m = gfc_match_actual_arglist (1, &arglist);
4171       if (m == MATCH_NO)
4172         goto syntax;
4173       if (m == MATCH_ERROR)
4174         goto cleanup;
4175
4176       if (gfc_match_eos () != MATCH_YES)
4177         goto syntax;
4178     }
4179
4180   /* If any alternate return labels were found, construct a SELECT
4181      statement that will jump to the right place.  */
4182
4183   i = 0;
4184   for (a = arglist; a; a = a->next)
4185     if (a->expr == NULL)
4186       i = 1;
4187
4188   if (i)
4189     {
4190       gfc_symtree *select_st;
4191       gfc_symbol *select_sym;
4192       char name[GFC_MAX_SYMBOL_LEN + 1];
4193
4194       new_st.next = c = gfc_get_code ();
4195       c->op = EXEC_SELECT;
4196       sprintf (name, "_result_%s", sym->name);
4197       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
4198
4199       select_sym = select_st->n.sym;
4200       select_sym->ts.type = BT_INTEGER;
4201       select_sym->ts.kind = gfc_default_integer_kind;
4202       gfc_set_sym_referenced (select_sym);
4203       c->expr1 = gfc_get_expr ();
4204       c->expr1->expr_type = EXPR_VARIABLE;
4205       c->expr1->symtree = select_st;
4206       c->expr1->ts = select_sym->ts;
4207       c->expr1->where = gfc_current_locus;
4208
4209       i = 0;
4210       for (a = arglist; a; a = a->next)
4211         {
4212           if (a->expr != NULL)
4213             continue;
4214
4215           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
4216             continue;
4217
4218           i++;
4219
4220           c->block = gfc_get_code ();
4221           c = c->block;
4222           c->op = EXEC_SELECT;
4223
4224           new_case = gfc_get_case ();
4225           new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
4226           new_case->low = new_case->high;
4227           c->ext.block.case_list = new_case;
4228
4229           c->next = gfc_get_code ();
4230           c->next->op = EXEC_GOTO;
4231           c->next->label1 = a->label;
4232         }
4233     }
4234
4235   new_st.op = EXEC_CALL;
4236   new_st.symtree = st;
4237   new_st.ext.actual = arglist;
4238
4239   return MATCH_YES;
4240
4241 syntax:
4242   gfc_syntax_error (ST_CALL);
4243
4244 cleanup:
4245   gfc_free_actual_arglist (arglist);
4246   return MATCH_ERROR;
4247 }
4248
4249
4250 /* Given a name, return a pointer to the common head structure,
4251    creating it if it does not exist. If FROM_MODULE is nonzero, we
4252    mangle the name so that it doesn't interfere with commons defined
4253    in the using namespace.
4254    TODO: Add to global symbol tree.  */
4255
4256 gfc_common_head *
4257 gfc_get_common (const char *name, int from_module)
4258 {
4259   gfc_symtree *st;
4260   static int serial = 0;
4261   char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
4262
4263   if (from_module)
4264     {
4265       /* A use associated common block is only needed to correctly layout
4266          the variables it contains.  */
4267       snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
4268       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
4269     }
4270   else
4271     {
4272       st = gfc_find_symtree (gfc_current_ns->common_root, name);
4273
4274       if (st == NULL)
4275         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
4276     }
4277
4278   if (st->n.common == NULL)
4279     {
4280       st->n.common = gfc_get_common_head ();
4281       st->n.common->where = gfc_current_locus;
4282       strcpy (st->n.common->name, name);
4283     }
4284
4285   return st->n.common;
4286 }
4287
4288
4289 /* Match a common block name.  */
4290
4291 match match_common_name (char *name)
4292 {
4293   match m;
4294
4295   if (gfc_match_char ('/') == MATCH_NO)
4296     {
4297       name[0] = '\0';
4298       return MATCH_YES;
4299     }
4300
4301   if (gfc_match_char ('/') == MATCH_YES)
4302     {
4303       name[0] = '\0';
4304       return MATCH_YES;
4305     }
4306
4307   m = gfc_match_name (name);
4308
4309   if (m == MATCH_ERROR)
4310     return MATCH_ERROR;
4311   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
4312     return MATCH_YES;
4313
4314   gfc_error ("Syntax error in common block name at %C");
4315   return MATCH_ERROR;
4316 }
4317
4318
4319 /* Match a COMMON statement.  */
4320
4321 match
4322 gfc_match_common (void)
4323 {
4324   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
4325   char name[GFC_MAX_SYMBOL_LEN + 1];
4326   gfc_common_head *t;
4327   gfc_array_spec *as;
4328   gfc_equiv *e1, *e2;
4329   match m;
4330   gfc_gsymbol *gsym;
4331
4332   old_blank_common = gfc_current_ns->blank_common.head;
4333   if (old_blank_common)
4334     {
4335       while (old_blank_common->common_next)
4336         old_blank_common = old_blank_common->common_next;
4337     }
4338
4339   as = NULL;
4340
4341   for (;;)
4342     {
4343       m = match_common_name (name);
4344       if (m == MATCH_ERROR)
4345         goto cleanup;
4346
4347       gsym = gfc_get_gsymbol (name);
4348       if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
4349         {
4350           gfc_error ("Symbol '%s' at %C is already an external symbol that "
4351                      "is not COMMON", name);
4352           goto cleanup;
4353         }
4354
4355       if (gsym->type == GSYM_UNKNOWN)
4356         {
4357           gsym->type = GSYM_COMMON;
4358           gsym->where = gfc_current_locus;
4359           gsym->defined = 1;
4360         }
4361
4362       gsym->used = 1;
4363
4364       if (name[0] == '\0')
4365         {
4366           t = &gfc_current_ns->blank_common;
4367           if (t->head == NULL)
4368             t->where = gfc_current_locus;
4369         }
4370       else
4371         {
4372           t = gfc_get_common (name, 0);
4373         }
4374       head = &t->head;
4375
4376       if (*head == NULL)
4377         tail = NULL;
4378       else
4379         {
4380           tail = *head;
4381           while (tail->common_next)
4382             tail = tail->common_next;
4383         }
4384
4385       /* Grab the list of symbols.  */
4386       for (;;)
4387         {
4388           m = gfc_match_symbol (&sym, 0);
4389           if (m == MATCH_ERROR)
4390             goto cleanup;
4391           if (m == MATCH_NO)
4392             goto syntax;
4393
4394           /* Store a ref to the common block for error checking.  */
4395           sym->common_block = t;
4396
4397           /* See if we know the current common block is bind(c), and if
4398              so, then see if we can check if the symbol is (which it'll
4399              need to be).  This can happen if the bind(c) attr stmt was
4400              applied to the common block, and the variable(s) already
4401              defined, before declaring the common block.  */
4402           if (t->is_bind_c == 1)
4403             {
4404               if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
4405                 {
4406                   /* If we find an error, just print it and continue,
4407                      cause it's just semantic, and we can see if there
4408                      are more errors.  */
4409                   gfc_error_now ("Variable '%s' at %L in common block '%s' "
4410                                  "at %C must be declared with a C "
4411                                  "interoperable kind since common block "
4412                                  "'%s' is bind(c)",
4413                                  sym->name, &(sym->declared_at), t->name,
4414                                  t->name);
4415                 }
4416
4417               if (sym->attr.is_bind_c == 1)
4418                 gfc_error_now ("Variable '%s' in common block "
4419                                "'%s' at %C can not be bind(c) since "
4420                                "it is not global", sym->name, t->name);
4421             }
4422
4423           if (sym->attr.in_common)
4424             {
4425               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
4426                          sym->name);
4427               goto cleanup;
4428             }
4429
4430           if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
4431                || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
4432             {
4433               if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
4434                                                "can only be COMMON in "
4435                                                "BLOCK DATA", sym->name)
4436                   == FAILURE)
4437                 goto cleanup;
4438             }
4439
4440           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
4441             goto cleanup;
4442
4443           if (tail != NULL)
4444             tail->common_next = sym;
4445           else
4446             *head = sym;
4447
4448           tail = sym;
4449
4450           /* Deal with an optional array specification after the
4451              symbol name.  */
4452           m = gfc_match_array_spec (&as, true, true);
4453           if (m == MATCH_ERROR)
4454             goto cleanup;
4455
4456           if (m == MATCH_YES)
4457             {
4458               if (as->type != AS_EXPLICIT)
4459                 {
4460                   gfc_error ("Array specification for symbol '%s' in COMMON "
4461                              "at %C must be explicit", sym->name);
4462                   goto cleanup;
4463                 }
4464
4465               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
4466                 goto cleanup;
4467
4468               if (sym->attr.pointer)
4469                 {
4470                   gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
4471                              "POINTER array", sym->name);
4472                   goto cleanup;
4473                 }
4474
4475               sym->as = as;
4476               as = NULL;
4477
4478             }
4479
4480           sym->common_head = t;
4481
4482           /* Check to see if the symbol is already in an equivalence group.
4483              If it is, set the other members as being in common.  */
4484           if (sym->attr.in_equivalence)
4485             {
4486               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
4487                 {
4488                   for (e2 = e1; e2; e2 = e2->eq)
4489                     if (e2->expr->symtree->n.sym == sym)
4490                       goto equiv_found;
4491
4492                   continue;
4493
4494           equiv_found:
4495
4496                   for (e2 = e1; e2; e2 = e2->eq)
4497                     {
4498                       other = e2->expr->symtree->n.sym;
4499                       if (other->common_head
4500                           && other->common_head != sym->common_head)
4501                         {
4502                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
4503                                      "%C is being indirectly equivalenced to "
4504                                      "another COMMON block '%s'",
4505                                      sym->name, sym->common_head->name,
4506                                      other->common_head->name);
4507                             goto cleanup;
4508                         }
4509                       other->attr.in_common = 1;
4510                       other->common_head = t;
4511                     }
4512                 }
4513             }
4514
4515
4516           gfc_gobble_whitespace ();
4517           if (gfc_match_eos () == MATCH_YES)
4518             goto done;
4519           if (gfc_peek_ascii_char () == '/')
4520             break;
4521           if (gfc_match_char (',') != MATCH_YES)
4522             goto syntax;
4523           gfc_gobble_whitespace ();
4524           if (gfc_peek_ascii_char () == '/')
4525             break;
4526         }
4527     }
4528
4529 done:
4530   return MATCH_YES;
4531
4532 syntax:
4533   gfc_syntax_error (ST_COMMON);
4534
4535 cleanup:
4536   if (old_blank_common)
4537     old_blank_common->common_next = NULL;
4538   else
4539     gfc_current_ns->blank_common.head = NULL;
4540   gfc_free_array_spec (as);
4541   return MATCH_ERROR;
4542 }
4543
4544
4545 /* Match a BLOCK DATA program unit.  */
4546
4547 match
4548 gfc_match_block_data (void)
4549 {
4550   char name[GFC_MAX_SYMBOL_LEN + 1];
4551   gfc_symbol *sym;
4552   match m;
4553
4554   if (gfc_match_eos () == MATCH_YES)
4555     {
4556       gfc_new_block = NULL;
4557       return MATCH_YES;
4558     }
4559
4560   m = gfc_match ("% %n%t", name);
4561   if (m != MATCH_YES)
4562     return MATCH_ERROR;
4563
4564   if (gfc_get_symbol (name, NULL, &sym))
4565     return MATCH_ERROR;
4566
4567   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
4568     return MATCH_ERROR;
4569
4570   gfc_new_block = sym;
4571
4572   return MATCH_YES;
4573 }
4574
4575
4576 /* Free a namelist structure.  */
4577
4578 void
4579 gfc_free_namelist (gfc_namelist *name)
4580 {
4581   gfc_namelist *n;
4582
4583   for (; name; name = n)
4584     {
4585       n = name->next;
4586       free (name);
4587     }
4588 }
4589
4590
4591 /* Match a NAMELIST statement.  */
4592
4593 match
4594 gfc_match_namelist (void)
4595 {
4596   gfc_symbol *group_name, *sym;
4597   gfc_namelist *nl;
4598   match m, m2;
4599
4600   m = gfc_match (" / %s /", &group_name);
4601   if (m == MATCH_NO)
4602     goto syntax;
4603   if (m == MATCH_ERROR)
4604     goto error;
4605
4606   for (;;)
4607     {
4608       if (group_name->ts.type != BT_UNKNOWN)
4609         {
4610           gfc_error ("Namelist group name '%s' at %C already has a basic "
4611                      "type of %s", group_name->name,
4612                      gfc_typename (&group_name->ts));
4613           return MATCH_ERROR;
4614         }
4615
4616       if (group_name->attr.flavor == FL_NAMELIST
4617           && group_name->attr.use_assoc
4618           && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
4619                              "at %C already is USE associated and can"
4620                              "not be respecified.", group_name->name)
4621              == FAILURE)
4622         return MATCH_ERROR;
4623
4624       if (group_name->attr.flavor != FL_NAMELIST
4625           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
4626                              group_name->name, NULL) == FAILURE)
4627         return MATCH_ERROR;
4628
4629       for (;;)
4630         {
4631           m = gfc_match_symbol (&sym, 1);
4632           if (m == MATCH_NO)
4633             goto syntax;
4634           if (m == MATCH_ERROR)
4635             goto error;
4636
4637           if (sym->attr.in_namelist == 0
4638               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
4639             goto error;
4640
4641           /* Use gfc_error_check here, rather than goto error, so that
4642              these are the only errors for the next two lines.  */
4643           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
4644             {
4645               gfc_error ("Assumed size array '%s' in namelist '%s' at "
4646                          "%C is not allowed", sym->name, group_name->name);
4647               gfc_error_check ();
4648             }
4649
4650           nl = gfc_get_namelist ();
4651           nl->sym = sym;
4652           sym->refs++;
4653
4654           if (group_name->namelist == NULL)
4655             group_name->namelist = group_name->namelist_tail = nl;
4656           else
4657             {
4658               group_name->namelist_tail->next = nl;
4659               group_name->namelist_tail = nl;
4660             }
4661
4662           if (gfc_match_eos () == MATCH_YES)
4663             goto done;
4664
4665           m = gfc_match_char (',');
4666
4667           if (gfc_match_char ('/') == MATCH_YES)
4668             {
4669               m2 = gfc_match (" %s /", &group_name);
4670               if (m2 == MATCH_YES)
4671                 break;
4672               if (m2 == MATCH_ERROR)
4673                 goto error;
4674               goto syntax;
4675             }
4676
4677           if (m != MATCH_YES)
4678             goto syntax;
4679         }
4680     }
4681
4682 done:
4683   return MATCH_YES;
4684
4685 syntax:
4686   gfc_syntax_error (ST_NAMELIST);
4687
4688 error:
4689   return MATCH_ERROR;
4690 }
4691
4692
4693 /* Match a MODULE statement.  */
4694
4695 match
4696 gfc_match_module (void)
4697 {
4698   match m;
4699
4700   m = gfc_match (" %s%t", &gfc_new_block);
4701   if (m != MATCH_YES)
4702     return m;
4703
4704   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
4705                       gfc_new_block->name, NULL) == FAILURE)
4706     return MATCH_ERROR;
4707
4708   return MATCH_YES;
4709 }
4710
4711
4712 /* Free equivalence sets and lists.  Recursively is the easiest way to
4713    do this.  */
4714
4715 void
4716 gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
4717 {
4718   if (eq == stop)
4719     return;
4720
4721   gfc_free_equiv (eq->eq);
4722   gfc_free_equiv_until (eq->next, stop);
4723   gfc_free_expr (eq->expr);
4724   free (eq);
4725 }
4726
4727
4728 void
4729 gfc_free_equiv (gfc_equiv *eq)
4730 {
4731   gfc_free_equiv_until (eq, NULL);
4732 }
4733
4734
4735 /* Match an EQUIVALENCE statement.  */
4736
4737 match
4738 gfc_match_equivalence (void)
4739 {
4740   gfc_equiv *eq, *set, *tail;
4741   gfc_ref *ref;
4742   gfc_symbol *sym;
4743   match m;
4744   gfc_common_head *common_head = NULL;
4745   bool common_flag;
4746   int cnt;
4747
4748   tail = NULL;
4749
4750   for (;;)
4751     {
4752       eq = gfc_get_equiv ();
4753       if (tail == NULL)
4754         tail = eq;
4755
4756       eq->next = gfc_current_ns->equiv;
4757       gfc_current_ns->equiv = eq;
4758
4759       if (gfc_match_char ('(') != MATCH_YES)
4760         goto syntax;
4761
4762       set = eq;
4763       common_flag = FALSE;
4764       cnt = 0;
4765
4766       for (;;)
4767         {
4768           m = gfc_match_equiv_variable (&set->expr);
4769           if (m == MATCH_ERROR)
4770             goto cleanup;
4771           if (m == MATCH_NO)
4772             goto syntax;
4773
4774           /*  count the number of objects.  */
4775           cnt++;
4776
4777           if (gfc_match_char ('%') == MATCH_YES)
4778             {
4779               gfc_error ("Derived type component %C is not a "
4780                          "permitted EQUIVALENCE member");
4781               goto cleanup;
4782             }
4783
4784           for (ref = set->expr->ref; ref; ref = ref->next)
4785             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
4786               {
4787                 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4788                            "be an array section");
4789                 goto cleanup;
4790               }
4791
4792           sym = set->expr->symtree->n.sym;
4793
4794           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
4795             goto cleanup;
4796
4797           if (sym->attr.in_common)
4798             {
4799               common_flag = TRUE;
4800               common_head = sym->common_head;
4801             }
4802
4803           if (gfc_match_char (')') == MATCH_YES)
4804             break;
4805
4806           if (gfc_match_char (',') != MATCH_YES)
4807             goto syntax;
4808
4809           set->eq = gfc_get_equiv ();
4810           set = set->eq;
4811         }
4812
4813       if (cnt < 2)
4814         {
4815           gfc_error ("EQUIVALENCE at %C requires two or more objects");
4816           goto cleanup;
4817         }
4818
4819       /* If one of the members of an equivalence is in common, then
4820          mark them all as being in common.  Before doing this, check
4821          that members of the equivalence group are not in different
4822          common blocks.  */
4823       if (common_flag)
4824         for (set = eq; set; set = set->eq)
4825           {
4826             sym = set->expr->symtree->n.sym;
4827             if (sym->common_head && sym->common_head != common_head)
4828               {
4829                 gfc_error ("Attempt to indirectly overlap COMMON "
4830                            "blocks %s and %s by EQUIVALENCE at %C",
4831                            sym->common_head->name, common_head->name);
4832                 goto cleanup;
4833               }
4834             sym->attr.in_common = 1;
4835             sym->common_head = common_head;
4836           }
4837
4838       if (gfc_match_eos () == MATCH_YES)
4839         break;
4840       if (gfc_match_char (',') != MATCH_YES)
4841         {
4842           gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4843           goto cleanup;
4844         }
4845     }
4846
4847   return MATCH_YES;
4848
4849 syntax:
4850   gfc_syntax_error (ST_EQUIVALENCE);
4851
4852 cleanup:
4853   eq = tail->next;
4854   tail->next = NULL;
4855
4856   gfc_free_equiv (gfc_current_ns->equiv);
4857   gfc_current_ns->equiv = eq;
4858
4859   return MATCH_ERROR;
4860 }
4861
4862
4863 /* Check that a statement function is not recursive. This is done by looking
4864    for the statement function symbol(sym) by looking recursively through its
4865    expression(e).  If a reference to sym is found, true is returned.
4866    12.5.4 requires that any variable of function that is implicitly typed
4867    shall have that type confirmed by any subsequent type declaration.  The
4868    implicit typing is conveniently done here.  */
4869 static bool
4870 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
4871
4872 static bool
4873 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
4874 {
4875
4876   if (e == NULL)
4877     return false;
4878
4879   switch (e->expr_type)
4880     {
4881     case EXPR_FUNCTION:
4882       if (e->symtree == NULL)
4883         return false;
4884
4885       /* Check the name before testing for nested recursion!  */
4886       if (sym->name == e->symtree->n.sym->name)
4887         return true;
4888
4889       /* Catch recursion via other statement functions.  */
4890       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
4891           && e->symtree->n.sym->value
4892           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
4893         return true;
4894
4895       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4896         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4897
4898       break;
4899
4900     case EXPR_VARIABLE:
4901       if (e->symtree && sym->name == e->symtree->n.sym->name)
4902         return true;
4903
4904       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4905         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4906       break;
4907
4908     default:
4909       break;
4910     }
4911
4912   return false;
4913 }
4914
4915
4916 static bool
4917 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
4918 {
4919   return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
4920 }
4921
4922
4923 /* Match a statement function declaration.  It is so easy to match
4924    non-statement function statements with a MATCH_ERROR as opposed to
4925    MATCH_NO that we suppress error message in most cases.  */
4926
4927 match
4928 gfc_match_st_function (void)
4929 {
4930   gfc_error_buf old_error;
4931   gfc_symbol *sym;
4932   gfc_expr *expr;
4933   match m;
4934
4935   m = gfc_match_symbol (&sym, 0);
4936   if (m != MATCH_YES)
4937     return m;
4938
4939   gfc_push_error (&old_error);
4940
4941   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
4942                          sym->name, NULL) == FAILURE)
4943     goto undo_error;
4944
4945   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
4946     goto undo_error;
4947
4948   m = gfc_match (" = %e%t", &expr);
4949   if (m == MATCH_NO)
4950     goto undo_error;
4951
4952   gfc_free_error (&old_error);
4953   if (m == MATCH_ERROR)
4954     return m;
4955
4956   if (recursive_stmt_fcn (expr, sym))
4957     {
4958       gfc_error ("Statement function at %L is recursive", &expr->where);
4959       return MATCH_ERROR;
4960     }
4961
4962   sym->value = expr;
4963
4964   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
4965                       "Statement function at %C") == FAILURE)
4966     return MATCH_ERROR;
4967
4968   return MATCH_YES;
4969
4970 undo_error:
4971   gfc_pop_error (&old_error);
4972   return MATCH_NO;
4973 }
4974
4975
4976 /***************** SELECT CASE subroutines ******************/
4977
4978 /* Free a single case structure.  */
4979
4980 static void
4981 free_case (gfc_case *p)
4982 {
4983   if (p->low == p->high)
4984     p->high = NULL;
4985   gfc_free_expr (p->low);
4986   gfc_free_expr (p->high);
4987   free (p);
4988 }
4989
4990
4991 /* Free a list of case structures.  */
4992
4993 void
4994 gfc_free_case_list (gfc_case *p)
4995 {
4996   gfc_case *q;
4997
4998   for (; p; p = q)
4999     {
5000       q = p->next;
5001       free_case (p);
5002     }
5003 }
5004
5005
5006 /* Match a single case selector.  */
5007
5008 static match
5009 match_case_selector (gfc_case **cp)
5010 {
5011   gfc_case *c;
5012   match m;
5013
5014   c = gfc_get_case ();
5015   c->where = gfc_current_locus;
5016
5017   if (gfc_match_char (':') == MATCH_YES)
5018     {
5019       m = gfc_match_init_expr (&c->high);
5020       if (m == MATCH_NO)
5021         goto need_expr;
5022       if (m == MATCH_ERROR)
5023         goto cleanup;
5024     }
5025   else
5026     {
5027       m = gfc_match_init_expr (&c->low);
5028       if (m == MATCH_ERROR)
5029         goto cleanup;
5030       if (m == MATCH_NO)
5031         goto need_expr;
5032
5033       /* If we're not looking at a ':' now, make a range out of a single
5034          target.  Else get the upper bound for the case range.  */
5035       if (gfc_match_char (':') != MATCH_YES)
5036         c->high = c->low;
5037       else
5038         {
5039           m = gfc_match_init_expr (&c->high);
5040           if (m == MATCH_ERROR)
5041             goto cleanup;
5042           /* MATCH_NO is fine.  It's OK if nothing is there!  */
5043         }
5044     }
5045
5046   *cp = c;
5047   return MATCH_YES;
5048
5049 need_expr:
5050   gfc_error ("Expected initialization expression in CASE at %C");
5051
5052 cleanup:
5053   free_case (c);
5054   return MATCH_ERROR;
5055 }
5056
5057
5058 /* Match the end of a case statement.  */
5059
5060 static match
5061 match_case_eos (void)
5062 {
5063   char name[GFC_MAX_SYMBOL_LEN + 1];
5064   match m;
5065
5066   if (gfc_match_eos () == MATCH_YES)
5067     return MATCH_YES;
5068
5069   /* If the case construct doesn't have a case-construct-name, we
5070      should have matched the EOS.  */
5071   if (!gfc_current_block ())
5072     return MATCH_NO;
5073
5074   gfc_gobble_whitespace ();
5075
5076   m = gfc_match_name (name);
5077   if (m != MATCH_YES)
5078     return m;
5079
5080   if (strcmp (name, gfc_current_block ()->name) != 0)
5081     {
5082       gfc_error ("Expected block name '%s' of SELECT construct at %C",
5083                  gfc_current_block ()->name);
5084       return MATCH_ERROR;
5085     }
5086
5087   return gfc_match_eos ();
5088 }
5089
5090
5091 /* Match a SELECT statement.  */
5092
5093 match
5094 gfc_match_select (void)
5095 {
5096   gfc_expr *expr;
5097   match m;
5098
5099   m = gfc_match_label ();
5100   if (m == MATCH_ERROR)
5101     return m;
5102
5103   m = gfc_match (" select case ( %e )%t", &expr);
5104   if (m != MATCH_YES)
5105     return m;
5106
5107   new_st.op = EXEC_SELECT;
5108   new_st.expr1 = expr;
5109
5110   return MATCH_YES;
5111 }
5112
5113
5114 /* Push the current selector onto the SELECT TYPE stack.  */
5115
5116 static void
5117 select_type_push (gfc_symbol *sel)
5118 {
5119   gfc_select_type_stack *top = gfc_get_select_type_stack ();
5120   top->selector = sel;
5121   top->tmp = NULL;
5122   top->prev = select_type_stack;
5123
5124   select_type_stack = top;
5125 }
5126
5127
5128 /* Set the temporary for the current SELECT TYPE selector.  */
5129
5130 static void
5131 select_type_set_tmp (gfc_typespec *ts)
5132 {
5133   char name[GFC_MAX_SYMBOL_LEN];
5134   gfc_symtree *tmp;
5135
5136   if (!ts)
5137     {
5138       select_type_stack->tmp = NULL;
5139       return;
5140     }
5141
5142   if (!gfc_type_is_extensible (ts->u.derived))
5143     return;
5144
5145   if (ts->type == BT_CLASS)
5146     sprintf (name, "__tmp_class_%s", ts->u.derived->name);
5147   else
5148     sprintf (name, "__tmp_type_%s", ts->u.derived->name);
5149   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
5150   gfc_add_type (tmp->n.sym, ts, NULL);
5151   gfc_set_sym_referenced (tmp->n.sym);
5152   if (select_type_stack->selector->ts.type == BT_CLASS &&
5153       CLASS_DATA (select_type_stack->selector)->attr.allocatable)
5154     gfc_add_allocatable (&tmp->n.sym->attr, NULL);
5155   else
5156     gfc_add_pointer (&tmp->n.sym->attr, NULL);
5157   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
5158   if (ts->type == BT_CLASS)
5159     gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
5160                             &tmp->n.sym->as, false);
5161   tmp->n.sym->attr.select_type_temporary = 1;
5162
5163   /* Add an association for it, so the rest of the parser knows it is
5164      an associate-name.  The target will be set during resolution.  */
5165   tmp->n.sym->assoc = gfc_get_association_list ();
5166   tmp->n.sym->assoc->dangling = 1;
5167   tmp->n.sym->assoc->st = tmp;
5168
5169   select_type_stack->tmp = tmp;
5170 }
5171
5172
5173 /* Match a SELECT TYPE statement.  */
5174
5175 match
5176 gfc_match_select_type (void)
5177 {
5178   gfc_expr *expr1, *expr2 = NULL;
5179   match m;
5180   char name[GFC_MAX_SYMBOL_LEN];
5181
5182   m = gfc_match_label ();
5183   if (m == MATCH_ERROR)
5184     return m;
5185
5186   m = gfc_match (" select type ( ");
5187   if (m != MATCH_YES)
5188     return m;
5189
5190   gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
5191
5192   m = gfc_match (" %n => %e", name, &expr2);
5193   if (m == MATCH_YES)
5194     {
5195       expr1 = gfc_get_expr();
5196       expr1->expr_type = EXPR_VARIABLE;
5197       if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
5198         {
5199           m = MATCH_ERROR;
5200           goto cleanup;
5201         }
5202       if (expr2->ts.type == BT_UNKNOWN)
5203         expr1->symtree->n.sym->attr.untyped = 1;
5204       else
5205         expr1->symtree->n.sym->ts = expr2->ts;
5206       expr1->symtree->n.sym->attr.flavor = FL_VARIABLE;
5207       expr1->symtree->n.sym->attr.referenced = 1;
5208       expr1->symtree->n.sym->attr.class_ok = 1;
5209     }
5210   else
5211     {
5212       m = gfc_match (" %e ", &expr1);
5213       if (m != MATCH_YES)
5214         goto cleanup;
5215     }
5216
5217   m = gfc_match (" )%t");
5218   if (m != MATCH_YES)
5219     goto cleanup;
5220
5221   /* Check for F03:C811.  */
5222   if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
5223     {
5224       gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
5225                  "use associate-name=>");
5226       m = MATCH_ERROR;
5227       goto cleanup;
5228     }
5229
5230   new_st.op = EXEC_SELECT_TYPE;
5231   new_st.expr1 = expr1;
5232   new_st.expr2 = expr2;
5233   new_st.ext.block.ns = gfc_current_ns;
5234
5235   select_type_push (expr1->symtree->n.sym);
5236
5237   return MATCH_YES;
5238
5239 cleanup:
5240   gfc_current_ns = gfc_current_ns->parent;
5241   return m;
5242 }
5243
5244
5245 /* Match a CASE statement.  */
5246
5247 match
5248 gfc_match_case (void)
5249 {
5250   gfc_case *c, *head, *tail;
5251   match m;
5252
5253   head = tail = NULL;
5254
5255   if (gfc_current_state () != COMP_SELECT)
5256     {
5257       gfc_error ("Unexpected CASE statement at %C");
5258       return MATCH_ERROR;
5259     }
5260
5261   if (gfc_match ("% default") == MATCH_YES)
5262     {
5263       m = match_case_eos ();
5264       if (m == MATCH_NO)
5265         goto syntax;
5266       if (m == MATCH_ERROR)
5267         goto cleanup;
5268
5269       new_st.op = EXEC_SELECT;
5270       c = gfc_get_case ();
5271       c->where = gfc_current_locus;
5272       new_st.ext.block.case_list = c;
5273       return MATCH_YES;
5274     }
5275
5276   if (gfc_match_char ('(') != MATCH_YES)
5277     goto syntax;
5278
5279   for (;;)
5280     {
5281       if (match_case_selector (&c) == MATCH_ERROR)
5282         goto cleanup;
5283
5284       if (head == NULL)
5285         head = c;
5286       else
5287         tail->next = c;
5288
5289       tail = c;
5290
5291       if (gfc_match_char (')') == MATCH_YES)
5292         break;
5293       if (gfc_match_char (',') != MATCH_YES)
5294         goto syntax;
5295     }
5296
5297   m = match_case_eos ();
5298   if (m == MATCH_NO)
5299     goto syntax;
5300   if (m == MATCH_ERROR)
5301     goto cleanup;
5302
5303   new_st.op = EXEC_SELECT;
5304   new_st.ext.block.case_list = head;
5305
5306   return MATCH_YES;
5307
5308 syntax:
5309   gfc_error ("Syntax error in CASE specification at %C");
5310
5311 cleanup:
5312   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
5313   return MATCH_ERROR;
5314 }
5315
5316
5317 /* Match a TYPE IS statement.  */
5318
5319 match
5320 gfc_match_type_is (void)
5321 {
5322   gfc_case *c = NULL;
5323   match m;
5324
5325   if (gfc_current_state () != COMP_SELECT_TYPE)
5326     {
5327       gfc_error ("Unexpected TYPE IS statement at %C");
5328       return MATCH_ERROR;
5329     }
5330
5331   if (gfc_match_char ('(') != MATCH_YES)
5332     goto syntax;
5333
5334   c = gfc_get_case ();
5335   c->where = gfc_current_locus;
5336
5337   /* TODO: Once unlimited polymorphism is implemented, we will need to call
5338      match_type_spec here.  */
5339   if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
5340     goto cleanup;
5341
5342   if (gfc_match_char (')') != MATCH_YES)
5343     goto syntax;
5344
5345   m = match_case_eos ();
5346   if (m == MATCH_NO)
5347     goto syntax;
5348   if (m == MATCH_ERROR)
5349     goto cleanup;
5350
5351   new_st.op = EXEC_SELECT_TYPE;
5352   new_st.ext.block.case_list = c;
5353
5354   /* Create temporary variable.  */
5355   select_type_set_tmp (&c->ts);
5356
5357   return MATCH_YES;
5358
5359 syntax:
5360   gfc_error ("Syntax error in TYPE IS specification at %C");
5361
5362 cleanup:
5363   if (c != NULL)
5364     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
5365   return MATCH_ERROR;
5366 }
5367
5368
5369 /* Match a CLASS IS or CLASS DEFAULT statement.  */
5370
5371 match
5372 gfc_match_class_is (void)
5373 {
5374   gfc_case *c = NULL;
5375   match m;
5376
5377   if (gfc_current_state () != COMP_SELECT_TYPE)
5378     return MATCH_NO;
5379
5380   if (gfc_match ("% default") == MATCH_YES)
5381     {
5382       m = match_case_eos ();
5383       if (m == MATCH_NO)
5384         goto syntax;
5385       if (m == MATCH_ERROR)
5386         goto cleanup;
5387
5388       new_st.op = EXEC_SELECT_TYPE;
5389       c = gfc_get_case ();
5390       c->where = gfc_current_locus;
5391       c->ts.type = BT_UNKNOWN;
5392       new_st.ext.block.case_list = c;
5393       select_type_set_tmp (NULL);
5394       return MATCH_YES;
5395     }
5396
5397   m = gfc_match ("% is");
5398   if (m == MATCH_NO)
5399     goto syntax;
5400   if (m == MATCH_ERROR)
5401     goto cleanup;
5402
5403   if (gfc_match_char ('(') != MATCH_YES)
5404     goto syntax;
5405
5406   c = gfc_get_case ();
5407   c->where = gfc_current_locus;
5408
5409   if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
5410     goto cleanup;
5411
5412   if (c->ts.type == BT_DERIVED)
5413     c->ts.type = BT_CLASS;
5414
5415   if (gfc_match_char (')') != MATCH_YES)
5416     goto syntax;
5417
5418   m = match_case_eos ();
5419   if (m == MATCH_NO)
5420     goto syntax;
5421   if (m == MATCH_ERROR)
5422     goto cleanup;
5423
5424   new_st.op = EXEC_SELECT_TYPE;
5425   new_st.ext.block.case_list = c;
5426
5427   /* Create temporary variable.  */
5428   select_type_set_tmp (&c->ts);
5429
5430   return MATCH_YES;
5431
5432 syntax:
5433   gfc_error ("Syntax error in CLASS IS specification at %C");
5434
5435 cleanup:
5436   if (c != NULL)
5437     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
5438   return MATCH_ERROR;
5439 }
5440
5441
5442 /********************* WHERE subroutines ********************/
5443
5444 /* Match the rest of a simple WHERE statement that follows an IF statement.
5445  */
5446
5447 static match
5448 match_simple_where (void)
5449 {
5450   gfc_expr *expr;
5451   gfc_code *c;
5452   match m;
5453
5454   m = gfc_match (" ( %e )", &expr);
5455   if (m != MATCH_YES)
5456     return m;
5457
5458   m = gfc_match_assignment ();
5459   if (m == MATCH_NO)
5460     goto syntax;
5461   if (m == MATCH_ERROR)
5462     goto cleanup;
5463
5464   if (gfc_match_eos () != MATCH_YES)
5465     goto syntax;
5466
5467   c = gfc_get_code ();
5468
5469   c->op = EXEC_WHERE;
5470   c->expr1 = expr;
5471   c->next = gfc_get_code ();
5472
5473   *c->next = new_st;
5474   gfc_clear_new_st ();
5475
5476   new_st.op = EXEC_WHERE;
5477   new_st.block = c;
5478
5479   return MATCH_YES;
5480
5481 syntax:
5482   gfc_syntax_error (ST_WHERE);
5483
5484 cleanup:
5485   gfc_free_expr (expr);
5486   return MATCH_ERROR;
5487 }
5488
5489
5490 /* Match a WHERE statement.  */
5491
5492 match
5493 gfc_match_where (gfc_statement *st)
5494 {
5495   gfc_expr *expr;
5496   match m0, m;
5497   gfc_code *c;
5498
5499   m0 = gfc_match_label ();
5500   if (m0 == MATCH_ERROR)
5501     return m0;
5502
5503   m = gfc_match (" where ( %e )", &expr);
5504   if (m != MATCH_YES)
5505     return m;
5506
5507   if (gfc_match_eos () == MATCH_YES)
5508     {
5509       *st = ST_WHERE_BLOCK;
5510       new_st.op = EXEC_WHERE;
5511       new_st.expr1 = expr;
5512       return MATCH_YES;
5513     }
5514
5515   m = gfc_match_assignment ();
5516   if (m == MATCH_NO)
5517     gfc_syntax_error (ST_WHERE);
5518
5519   if (m != MATCH_YES)
5520     {
5521       gfc_free_expr (expr);
5522       return MATCH_ERROR;
5523     }
5524
5525   /* We've got a simple WHERE statement.  */
5526   *st = ST_WHERE;
5527   c = gfc_get_code ();
5528
5529   c->op = EXEC_WHERE;
5530   c->expr1 = expr;
5531   c->next = gfc_get_code ();
5532
5533   *c->next = new_st;
5534   gfc_clear_new_st ();
5535
5536   new_st.op = EXEC_WHERE;
5537   new_st.block = c;
5538
5539   return MATCH_YES;
5540 }
5541
5542
5543 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
5544    new_st if successful.  */
5545
5546 match
5547 gfc_match_elsewhere (void)
5548 {
5549   char name[GFC_MAX_SYMBOL_LEN + 1];
5550   gfc_expr *expr;
5551   match m;
5552
5553   if (gfc_current_state () != COMP_WHERE)
5554     {
5555       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
5556       return MATCH_ERROR;
5557     }
5558
5559   expr = NULL;
5560
5561   if (gfc_match_char ('(') == MATCH_YES)
5562     {
5563       m = gfc_match_expr (&expr);
5564       if (m == MATCH_NO)
5565         goto syntax;
5566       if (m == MATCH_ERROR)
5567         return MATCH_ERROR;
5568
5569       if (gfc_match_char (')') != MATCH_YES)
5570         goto syntax;
5571     }
5572
5573   if (gfc_match_eos () != MATCH_YES)
5574     {
5575       /* Only makes sense if we have a where-construct-name.  */
5576       if (!gfc_current_block ())
5577         {
5578           m = MATCH_ERROR;
5579           goto cleanup;
5580         }
5581       /* Better be a name at this point.  */
5582       m = gfc_match_name (name);
5583       if (m == MATCH_NO)
5584         goto syntax;
5585       if (m == MATCH_ERROR)
5586         goto cleanup;
5587
5588       if (gfc_match_eos () != MATCH_YES)
5589         goto syntax;
5590
5591       if (strcmp (name, gfc_current_block ()->name) != 0)
5592         {
5593           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
5594                      name, gfc_current_block ()->name);
5595           goto cleanup;
5596         }
5597     }
5598
5599   new_st.op = EXEC_WHERE;
5600   new_st.expr1 = expr;
5601   return MATCH_YES;
5602
5603 syntax:
5604   gfc_syntax_error (ST_ELSEWHERE);
5605
5606 cleanup:
5607   gfc_free_expr (expr);
5608   return MATCH_ERROR;
5609 }