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_PROCEDURE && derived->attr.generic)
1924     derived = gfc_find_dt_in_generic (derived);
1925
1926   if (derived && derived->attr.flavor == FL_DERIVED)
1927     {
1928       ts->type = BT_DERIVED;
1929       ts->u.derived = derived;
1930       return MATCH_YES;
1931     }
1932
1933   gfc_current_locus = old_locus;
1934   return MATCH_NO;
1935 }
1936
1937
1938 /* Match a Fortran 2003 type-spec (F03:R401).  This is similar to
1939    gfc_match_decl_type_spec() from decl.c, with the following exceptions:
1940    It only includes the intrinsic types from the Fortran 2003 standard
1941    (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
1942    the implicit_flag is not needed, so it was removed. Derived types are
1943    identified by their name alone.  */
1944
1945 static match
1946 match_type_spec (gfc_typespec *ts)
1947 {
1948   match m;
1949   locus old_locus;
1950
1951   gfc_clear_ts (ts);
1952   gfc_gobble_whitespace ();
1953   old_locus = gfc_current_locus;
1954
1955   if (match_derived_type_spec (ts) == MATCH_YES)
1956     {
1957       /* Enforce F03:C401.  */
1958       if (ts->u.derived->attr.abstract)
1959         {
1960           gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
1961                      ts->u.derived->name, &old_locus);
1962           return MATCH_ERROR;
1963         }
1964       return MATCH_YES;
1965     }
1966
1967   if (gfc_match ("integer") == MATCH_YES)
1968     {
1969       ts->type = BT_INTEGER;
1970       ts->kind = gfc_default_integer_kind;
1971       goto kind_selector;
1972     }
1973
1974   if (gfc_match ("real") == MATCH_YES)
1975     {
1976       ts->type = BT_REAL;
1977       ts->kind = gfc_default_real_kind;
1978       goto kind_selector;
1979     }
1980
1981   if (gfc_match ("double precision") == MATCH_YES)
1982     {
1983       ts->type = BT_REAL;
1984       ts->kind = gfc_default_double_kind;
1985       return MATCH_YES;
1986     }
1987
1988   if (gfc_match ("complex") == MATCH_YES)
1989     {
1990       ts->type = BT_COMPLEX;
1991       ts->kind = gfc_default_complex_kind;
1992       goto kind_selector;
1993     }
1994
1995   if (gfc_match ("character") == MATCH_YES)
1996     {
1997       ts->type = BT_CHARACTER;
1998
1999       m = gfc_match_char_spec (ts);
2000
2001       if (m == MATCH_NO)
2002         m = MATCH_YES;
2003
2004       return m;
2005     }
2006
2007   if (gfc_match ("logical") == MATCH_YES)
2008     {
2009       ts->type = BT_LOGICAL;
2010       ts->kind = gfc_default_logical_kind;
2011       goto kind_selector;
2012     }
2013
2014   /* If a type is not matched, simply return MATCH_NO.  */
2015   gfc_current_locus = old_locus;
2016   return MATCH_NO;
2017
2018 kind_selector:
2019
2020   gfc_gobble_whitespace ();
2021   if (gfc_peek_ascii_char () == '*')
2022     {
2023       gfc_error ("Invalid type-spec at %C");
2024       return MATCH_ERROR;
2025     }
2026
2027   m = gfc_match_kind_spec (ts, false);
2028
2029   if (m == MATCH_NO)
2030     m = MATCH_YES;              /* No kind specifier found.  */
2031
2032   return m;
2033 }
2034
2035
2036 /******************** FORALL subroutines ********************/
2037
2038 /* Free a list of FORALL iterators.  */
2039
2040 void
2041 gfc_free_forall_iterator (gfc_forall_iterator *iter)
2042 {
2043   gfc_forall_iterator *next;
2044
2045   while (iter)
2046     {
2047       next = iter->next;
2048       gfc_free_expr (iter->var);
2049       gfc_free_expr (iter->start);
2050       gfc_free_expr (iter->end);
2051       gfc_free_expr (iter->stride);
2052       free (iter);
2053       iter = next;
2054     }
2055 }
2056
2057
2058 /* Match an iterator as part of a FORALL statement.  The format is:
2059
2060      <var> = <start>:<end>[:<stride>]
2061
2062    On MATCH_NO, the caller tests for the possibility that there is a
2063    scalar mask expression.  */
2064
2065 static match
2066 match_forall_iterator (gfc_forall_iterator **result)
2067 {
2068   gfc_forall_iterator *iter;
2069   locus where;
2070   match m;
2071
2072   where = gfc_current_locus;
2073   iter = XCNEW (gfc_forall_iterator);
2074
2075   m = gfc_match_expr (&iter->var);
2076   if (m != MATCH_YES)
2077     goto cleanup;
2078
2079   if (gfc_match_char ('=') != MATCH_YES
2080       || iter->var->expr_type != EXPR_VARIABLE)
2081     {
2082       m = MATCH_NO;
2083       goto cleanup;
2084     }
2085
2086   m = gfc_match_expr (&iter->start);
2087   if (m != MATCH_YES)
2088     goto cleanup;
2089
2090   if (gfc_match_char (':') != MATCH_YES)
2091     goto syntax;
2092
2093   m = gfc_match_expr (&iter->end);
2094   if (m == MATCH_NO)
2095     goto syntax;
2096   if (m == MATCH_ERROR)
2097     goto cleanup;
2098
2099   if (gfc_match_char (':') == MATCH_NO)
2100     iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
2101   else
2102     {
2103       m = gfc_match_expr (&iter->stride);
2104       if (m == MATCH_NO)
2105         goto syntax;
2106       if (m == MATCH_ERROR)
2107         goto cleanup;
2108     }
2109
2110   /* Mark the iteration variable's symbol as used as a FORALL index.  */
2111   iter->var->symtree->n.sym->forall_index = true;
2112
2113   *result = iter;
2114   return MATCH_YES;
2115
2116 syntax:
2117   gfc_error ("Syntax error in FORALL iterator at %C");
2118   m = MATCH_ERROR;
2119
2120 cleanup:
2121
2122   gfc_current_locus = where;
2123   gfc_free_forall_iterator (iter);
2124   return m;
2125 }
2126
2127
2128 /* Match the header of a FORALL statement.  */
2129
2130 static match
2131 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
2132 {
2133   gfc_forall_iterator *head, *tail, *new_iter;
2134   gfc_expr *msk;
2135   match m;
2136
2137   gfc_gobble_whitespace ();
2138
2139   head = tail = NULL;
2140   msk = NULL;
2141
2142   if (gfc_match_char ('(') != MATCH_YES)
2143     return MATCH_NO;
2144
2145   m = match_forall_iterator (&new_iter);
2146   if (m == MATCH_ERROR)
2147     goto cleanup;
2148   if (m == MATCH_NO)
2149     goto syntax;
2150
2151   head = tail = new_iter;
2152
2153   for (;;)
2154     {
2155       if (gfc_match_char (',') != MATCH_YES)
2156         break;
2157
2158       m = match_forall_iterator (&new_iter);
2159       if (m == MATCH_ERROR)
2160         goto cleanup;
2161
2162       if (m == MATCH_YES)
2163         {
2164           tail->next = new_iter;
2165           tail = new_iter;
2166           continue;
2167         }
2168
2169       /* Have to have a mask expression.  */
2170
2171       m = gfc_match_expr (&msk);
2172       if (m == MATCH_NO)
2173         goto syntax;
2174       if (m == MATCH_ERROR)
2175         goto cleanup;
2176
2177       break;
2178     }
2179
2180   if (gfc_match_char (')') == MATCH_NO)
2181     goto syntax;
2182
2183   *phead = head;
2184   *mask = msk;
2185   return MATCH_YES;
2186
2187 syntax:
2188   gfc_syntax_error (ST_FORALL);
2189
2190 cleanup:
2191   gfc_free_expr (msk);
2192   gfc_free_forall_iterator (head);
2193
2194   return MATCH_ERROR;
2195 }
2196
2197 /* Match the rest of a simple FORALL statement that follows an
2198    IF statement.  */
2199
2200 static match
2201 match_simple_forall (void)
2202 {
2203   gfc_forall_iterator *head;
2204   gfc_expr *mask;
2205   gfc_code *c;
2206   match m;
2207
2208   mask = NULL;
2209   head = NULL;
2210   c = NULL;
2211
2212   m = match_forall_header (&head, &mask);
2213
2214   if (m == MATCH_NO)
2215     goto syntax;
2216   if (m != MATCH_YES)
2217     goto cleanup;
2218
2219   m = gfc_match_assignment ();
2220
2221   if (m == MATCH_ERROR)
2222     goto cleanup;
2223   if (m == MATCH_NO)
2224     {
2225       m = gfc_match_pointer_assignment ();
2226       if (m == MATCH_ERROR)
2227         goto cleanup;
2228       if (m == MATCH_NO)
2229         goto syntax;
2230     }
2231
2232   c = gfc_get_code ();
2233   *c = new_st;
2234   c->loc = gfc_current_locus;
2235
2236   if (gfc_match_eos () != MATCH_YES)
2237     goto syntax;
2238
2239   gfc_clear_new_st ();
2240   new_st.op = EXEC_FORALL;
2241   new_st.expr1 = mask;
2242   new_st.ext.forall_iterator = head;
2243   new_st.block = gfc_get_code ();
2244
2245   new_st.block->op = EXEC_FORALL;
2246   new_st.block->next = c;
2247
2248   return MATCH_YES;
2249
2250 syntax:
2251   gfc_syntax_error (ST_FORALL);
2252
2253 cleanup:
2254   gfc_free_forall_iterator (head);
2255   gfc_free_expr (mask);
2256
2257   return MATCH_ERROR;
2258 }
2259
2260
2261 /* Match a FORALL statement.  */
2262
2263 match
2264 gfc_match_forall (gfc_statement *st)
2265 {
2266   gfc_forall_iterator *head;
2267   gfc_expr *mask;
2268   gfc_code *c;
2269   match m0, m;
2270
2271   head = NULL;
2272   mask = NULL;
2273   c = NULL;
2274
2275   m0 = gfc_match_label ();
2276   if (m0 == MATCH_ERROR)
2277     return MATCH_ERROR;
2278
2279   m = gfc_match (" forall");
2280   if (m != MATCH_YES)
2281     return m;
2282
2283   m = match_forall_header (&head, &mask);
2284   if (m == MATCH_ERROR)
2285     goto cleanup;
2286   if (m == MATCH_NO)
2287     goto syntax;
2288
2289   if (gfc_match_eos () == MATCH_YES)
2290     {
2291       *st = ST_FORALL_BLOCK;
2292       new_st.op = EXEC_FORALL;
2293       new_st.expr1 = mask;
2294       new_st.ext.forall_iterator = head;
2295       return MATCH_YES;
2296     }
2297
2298   m = gfc_match_assignment ();
2299   if (m == MATCH_ERROR)
2300     goto cleanup;
2301   if (m == MATCH_NO)
2302     {
2303       m = gfc_match_pointer_assignment ();
2304       if (m == MATCH_ERROR)
2305         goto cleanup;
2306       if (m == MATCH_NO)
2307         goto syntax;
2308     }
2309
2310   c = gfc_get_code ();
2311   *c = new_st;
2312   c->loc = gfc_current_locus;
2313
2314   gfc_clear_new_st ();
2315   new_st.op = EXEC_FORALL;
2316   new_st.expr1 = mask;
2317   new_st.ext.forall_iterator = head;
2318   new_st.block = gfc_get_code ();
2319   new_st.block->op = EXEC_FORALL;
2320   new_st.block->next = c;
2321
2322   *st = ST_FORALL;
2323   return MATCH_YES;
2324
2325 syntax:
2326   gfc_syntax_error (ST_FORALL);
2327
2328 cleanup:
2329   gfc_free_forall_iterator (head);
2330   gfc_free_expr (mask);
2331   gfc_free_statements (c);
2332   return MATCH_NO;
2333 }
2334
2335
2336 /* Match a DO statement.  */
2337
2338 match
2339 gfc_match_do (void)
2340 {
2341   gfc_iterator iter, *ip;
2342   locus old_loc;
2343   gfc_st_label *label;
2344   match m;
2345
2346   old_loc = gfc_current_locus;
2347
2348   label = NULL;
2349   iter.var = iter.start = iter.end = iter.step = NULL;
2350
2351   m = gfc_match_label ();
2352   if (m == MATCH_ERROR)
2353     return m;
2354
2355   if (gfc_match (" do") != MATCH_YES)
2356     return MATCH_NO;
2357
2358   m = gfc_match_st_label (&label);
2359   if (m == MATCH_ERROR)
2360     goto cleanup;
2361
2362   /* Match an infinite DO, make it like a DO WHILE(.TRUE.).  */
2363
2364   if (gfc_match_eos () == MATCH_YES)
2365     {
2366       iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
2367       new_st.op = EXEC_DO_WHILE;
2368       goto done;
2369     }
2370
2371   /* Match an optional comma, if no comma is found, a space is obligatory.  */
2372   if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
2373     return MATCH_NO;
2374
2375   /* Check for balanced parens.  */
2376
2377   if (gfc_match_parens () == MATCH_ERROR)
2378     return MATCH_ERROR;
2379
2380   if (gfc_match (" concurrent") == MATCH_YES)
2381     {
2382       gfc_forall_iterator *head;
2383       gfc_expr *mask;
2384
2385       if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: DO CONCURRENT "
2386                            "construct at %C") == FAILURE)
2387         return MATCH_ERROR;
2388
2389
2390       mask = NULL;
2391       head = NULL;
2392       m = match_forall_header (&head, &mask);
2393
2394       if (m == MATCH_NO)
2395         return m;
2396       if (m == MATCH_ERROR)
2397         goto concurr_cleanup;
2398
2399       if (gfc_match_eos () != MATCH_YES)
2400         goto concurr_cleanup;
2401
2402       if (label != NULL
2403            && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2404         goto concurr_cleanup;
2405
2406       new_st.label1 = label;
2407       new_st.op = EXEC_DO_CONCURRENT;
2408       new_st.expr1 = mask;
2409       new_st.ext.forall_iterator = head;
2410
2411       return MATCH_YES;
2412
2413 concurr_cleanup:
2414       gfc_syntax_error (ST_DO);
2415       gfc_free_expr (mask);
2416       gfc_free_forall_iterator (head);
2417       return MATCH_ERROR;
2418     }
2419
2420   /* See if we have a DO WHILE.  */
2421   if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
2422     {
2423       new_st.op = EXEC_DO_WHILE;
2424       goto done;
2425     }
2426
2427   /* The abortive DO WHILE may have done something to the symbol
2428      table, so we start over.  */
2429   gfc_undo_symbols ();
2430   gfc_current_locus = old_loc;
2431
2432   gfc_match_label ();           /* This won't error.  */
2433   gfc_match (" do ");           /* This will work.  */
2434
2435   gfc_match_st_label (&label);  /* Can't error out.  */
2436   gfc_match_char (',');         /* Optional comma.  */
2437
2438   m = gfc_match_iterator (&iter, 0);
2439   if (m == MATCH_NO)
2440     return MATCH_NO;
2441   if (m == MATCH_ERROR)
2442     goto cleanup;
2443
2444   iter.var->symtree->n.sym->attr.implied_index = 0;
2445   gfc_check_do_variable (iter.var->symtree);
2446
2447   if (gfc_match_eos () != MATCH_YES)
2448     {
2449       gfc_syntax_error (ST_DO);
2450       goto cleanup;
2451     }
2452
2453   new_st.op = EXEC_DO;
2454
2455 done:
2456   if (label != NULL
2457       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2458     goto cleanup;
2459
2460   new_st.label1 = label;
2461
2462   if (new_st.op == EXEC_DO_WHILE)
2463     new_st.expr1 = iter.end;
2464   else
2465     {
2466       new_st.ext.iterator = ip = gfc_get_iterator ();
2467       *ip = iter;
2468     }
2469
2470   return MATCH_YES;
2471
2472 cleanup:
2473   gfc_free_iterator (&iter, 0);
2474
2475   return MATCH_ERROR;
2476 }
2477
2478
2479 /* Match an EXIT or CYCLE statement.  */
2480
2481 static match
2482 match_exit_cycle (gfc_statement st, gfc_exec_op op)
2483 {
2484   gfc_state_data *p, *o;
2485   gfc_symbol *sym;
2486   match m;
2487   int cnt;
2488
2489   if (gfc_match_eos () == MATCH_YES)
2490     sym = NULL;
2491   else
2492     {
2493       char name[GFC_MAX_SYMBOL_LEN + 1];
2494       gfc_symtree* stree;
2495
2496       m = gfc_match ("% %n%t", name);
2497       if (m == MATCH_ERROR)
2498         return MATCH_ERROR;
2499       if (m == MATCH_NO)
2500         {
2501           gfc_syntax_error (st);
2502           return MATCH_ERROR;
2503         }
2504
2505       /* Find the corresponding symbol.  If there's a BLOCK statement
2506          between here and the label, it is not in gfc_current_ns but a parent
2507          namespace!  */
2508       stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
2509       if (!stree)
2510         {
2511           gfc_error ("Name '%s' in %s statement at %C is unknown",
2512                      name, gfc_ascii_statement (st));
2513           return MATCH_ERROR;
2514         }
2515
2516       sym = stree->n.sym;
2517       if (sym->attr.flavor != FL_LABEL)
2518         {
2519           gfc_error ("Name '%s' in %s statement at %C is not a construct name",
2520                      name, gfc_ascii_statement (st));
2521           return MATCH_ERROR;
2522         }
2523     }
2524
2525   /* Find the loop specified by the label (or lack of a label).  */
2526   for (o = NULL, p = gfc_state_stack; p; p = p->previous)
2527     if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
2528       o = p;
2529     else if (p->state == COMP_CRITICAL)
2530       {
2531         gfc_error("%s statement at %C leaves CRITICAL construct",
2532                   gfc_ascii_statement (st));
2533         return MATCH_ERROR;
2534       }
2535     else if (p->state == COMP_DO_CONCURRENT
2536              && (op == EXEC_EXIT || (sym && sym != p->sym)))
2537       {
2538         /* F2008, C821 & C845.  */
2539         gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2540                   gfc_ascii_statement (st));
2541         return MATCH_ERROR;
2542       }
2543     else if ((sym && sym == p->sym)
2544              || (!sym && (p->state == COMP_DO
2545                           || p->state == COMP_DO_CONCURRENT)))
2546       break;
2547
2548   if (p == NULL)
2549     {
2550       if (sym == NULL)
2551         gfc_error ("%s statement at %C is not within a construct",
2552                    gfc_ascii_statement (st));
2553       else
2554         gfc_error ("%s statement at %C is not within construct '%s'",
2555                    gfc_ascii_statement (st), sym->name);
2556
2557       return MATCH_ERROR;
2558     }
2559
2560   /* Special checks for EXIT from non-loop constructs.  */
2561   switch (p->state)
2562     {
2563     case COMP_DO:
2564     case COMP_DO_CONCURRENT:
2565       break;
2566
2567     case COMP_CRITICAL:
2568       /* This is already handled above.  */
2569       gcc_unreachable ();
2570
2571     case COMP_ASSOCIATE:
2572     case COMP_BLOCK:
2573     case COMP_IF:
2574     case COMP_SELECT:
2575     case COMP_SELECT_TYPE:
2576       gcc_assert (sym);
2577       if (op == EXEC_CYCLE)
2578         {
2579           gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2580                      " construct '%s'", sym->name);
2581           return MATCH_ERROR;
2582         }
2583       gcc_assert (op == EXEC_EXIT);
2584       if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: EXIT statement with no"
2585                           " do-construct-name at %C") == FAILURE)
2586         return MATCH_ERROR;
2587       break;
2588
2589     default:
2590       gfc_error ("%s statement at %C is not applicable to construct '%s'",
2591                  gfc_ascii_statement (st), sym->name);
2592       return MATCH_ERROR;
2593     }
2594
2595   if (o != NULL)
2596     {
2597       gfc_error ("%s statement at %C leaving OpenMP structured block",
2598                  gfc_ascii_statement (st));
2599       return MATCH_ERROR;
2600     }
2601
2602   for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
2603     o = o->previous;
2604   if (cnt > 0
2605       && o != NULL
2606       && o->state == COMP_OMP_STRUCTURED_BLOCK
2607       && (o->head->op == EXEC_OMP_DO
2608           || o->head->op == EXEC_OMP_PARALLEL_DO))
2609     {
2610       int collapse = 1;
2611       gcc_assert (o->head->next != NULL
2612                   && (o->head->next->op == EXEC_DO
2613                       || o->head->next->op == EXEC_DO_WHILE)
2614                   && o->previous != NULL
2615                   && o->previous->tail->op == o->head->op);
2616       if (o->previous->tail->ext.omp_clauses != NULL
2617           && o->previous->tail->ext.omp_clauses->collapse > 1)
2618         collapse = o->previous->tail->ext.omp_clauses->collapse;
2619       if (st == ST_EXIT && cnt <= collapse)
2620         {
2621           gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2622           return MATCH_ERROR;
2623         }
2624       if (st == ST_CYCLE && cnt < collapse)
2625         {
2626           gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2627                      " !$OMP DO loop");
2628           return MATCH_ERROR;
2629         }
2630     }
2631
2632   /* Save the first statement in the construct - needed by the backend.  */
2633   new_st.ext.which_construct = p->construct;
2634
2635   new_st.op = op;
2636
2637   return MATCH_YES;
2638 }
2639
2640
2641 /* Match the EXIT statement.  */
2642
2643 match
2644 gfc_match_exit (void)
2645 {
2646   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
2647 }
2648
2649
2650 /* Match the CYCLE statement.  */
2651
2652 match
2653 gfc_match_cycle (void)
2654 {
2655   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
2656 }
2657
2658
2659 /* Match a number or character constant after an (ALL) STOP or PAUSE statement.  */
2660
2661 static match
2662 gfc_match_stopcode (gfc_statement st)
2663 {
2664   gfc_expr *e;
2665   match m;
2666
2667   e = NULL;
2668
2669   if (gfc_match_eos () != MATCH_YES)
2670     {
2671       m = gfc_match_init_expr (&e);
2672       if (m == MATCH_ERROR)
2673         goto cleanup;
2674       if (m == MATCH_NO)
2675         goto syntax;
2676
2677       if (gfc_match_eos () != MATCH_YES)
2678         goto syntax;
2679     }
2680
2681   if (gfc_pure (NULL))
2682     {
2683       gfc_error ("%s statement not allowed in PURE procedure at %C",
2684                  gfc_ascii_statement (st));
2685       goto cleanup;
2686     }
2687
2688   if (gfc_implicit_pure (NULL))
2689     gfc_current_ns->proc_name->attr.implicit_pure = 0;
2690
2691   if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
2692     {
2693       gfc_error ("Image control statement STOP at %C in CRITICAL block");
2694       goto cleanup;
2695     }
2696   if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
2697     {
2698       gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2699       goto cleanup;
2700     }
2701
2702   if (e != NULL)
2703     {
2704       if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
2705         {
2706           gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2707                      &e->where);
2708           goto cleanup;
2709         }
2710
2711       if (e->rank != 0)
2712         {
2713           gfc_error ("STOP code at %L must be scalar",
2714                      &e->where);
2715           goto cleanup;
2716         }
2717
2718       if (e->ts.type == BT_CHARACTER
2719           && e->ts.kind != gfc_default_character_kind)
2720         {
2721           gfc_error ("STOP code at %L must be default character KIND=%d",
2722                      &e->where, (int) gfc_default_character_kind);
2723           goto cleanup;
2724         }
2725
2726       if (e->ts.type == BT_INTEGER
2727           && e->ts.kind != gfc_default_integer_kind)
2728         {
2729           gfc_error ("STOP code at %L must be default integer KIND=%d",
2730                      &e->where, (int) gfc_default_integer_kind);
2731           goto cleanup;
2732         }
2733     }
2734
2735   switch (st)
2736     {
2737     case ST_STOP:
2738       new_st.op = EXEC_STOP;
2739       break;
2740     case ST_ERROR_STOP:
2741       new_st.op = EXEC_ERROR_STOP;
2742       break;
2743     case ST_PAUSE:
2744       new_st.op = EXEC_PAUSE;
2745       break;
2746     default:
2747       gcc_unreachable ();
2748     }
2749
2750   new_st.expr1 = e;
2751   new_st.ext.stop_code = -1;
2752
2753   return MATCH_YES;
2754
2755 syntax:
2756   gfc_syntax_error (st);
2757
2758 cleanup:
2759
2760   gfc_free_expr (e);
2761   return MATCH_ERROR;
2762 }
2763
2764
2765 /* Match the (deprecated) PAUSE statement.  */
2766
2767 match
2768 gfc_match_pause (void)
2769 {
2770   match m;
2771
2772   m = gfc_match_stopcode (ST_PAUSE);
2773   if (m == MATCH_YES)
2774     {
2775       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
2776           " at %C")
2777           == FAILURE)
2778         m = MATCH_ERROR;
2779     }
2780   return m;
2781 }
2782
2783
2784 /* Match the STOP statement.  */
2785
2786 match
2787 gfc_match_stop (void)
2788 {
2789   return gfc_match_stopcode (ST_STOP);
2790 }
2791
2792
2793 /* Match the ERROR STOP statement.  */
2794
2795 match
2796 gfc_match_error_stop (void)
2797 {
2798   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C")
2799       == FAILURE)
2800     return MATCH_ERROR;
2801
2802   return gfc_match_stopcode (ST_ERROR_STOP);
2803 }
2804
2805
2806 /* Match LOCK/UNLOCK statement. Syntax:
2807      LOCK ( lock-variable [ , lock-stat-list ] )
2808      UNLOCK ( lock-variable [ , sync-stat-list ] )
2809    where lock-stat is ACQUIRED_LOCK or sync-stat
2810    and sync-stat is STAT= or ERRMSG=.  */
2811
2812 static match
2813 lock_unlock_statement (gfc_statement st)
2814 {
2815   match m;
2816   gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg;
2817   bool saw_acq_lock, saw_stat, saw_errmsg;
2818
2819   tmp = lockvar = acq_lock = stat = errmsg = NULL;
2820   saw_acq_lock = saw_stat = saw_errmsg = false;
2821
2822   if (gfc_pure (NULL))
2823     {
2824       gfc_error ("Image control statement %s at %C in PURE procedure",
2825                  st == ST_LOCK ? "LOCK" : "UNLOCK");
2826       return MATCH_ERROR;
2827     }
2828
2829   if (gfc_implicit_pure (NULL))
2830     gfc_current_ns->proc_name->attr.implicit_pure = 0;
2831
2832   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
2833     {
2834        gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2835        return MATCH_ERROR;
2836     }
2837
2838   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
2839     {
2840       gfc_error ("Image control statement %s at %C in CRITICAL block",
2841                  st == ST_LOCK ? "LOCK" : "UNLOCK");
2842       return MATCH_ERROR;
2843     }
2844
2845   if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
2846     {
2847       gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
2848                  st == ST_LOCK ? "LOCK" : "UNLOCK");
2849       return MATCH_ERROR;
2850     }
2851
2852   if (gfc_match_char ('(') != MATCH_YES)
2853     goto syntax;
2854
2855   if (gfc_match ("%e", &lockvar) != MATCH_YES)
2856     goto syntax;
2857   m = gfc_match_char (',');
2858   if (m == MATCH_ERROR)
2859     goto syntax;
2860   if (m == MATCH_NO)
2861     {
2862       m = gfc_match_char (')');
2863       if (m == MATCH_YES)
2864         goto done;
2865       goto syntax;
2866     }
2867
2868   for (;;)
2869     {
2870       m = gfc_match (" stat = %v", &tmp);
2871       if (m == MATCH_ERROR)
2872         goto syntax;
2873       if (m == MATCH_YES)
2874         {
2875           if (saw_stat)
2876             {
2877               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2878               goto cleanup;
2879             }
2880           stat = tmp;
2881           saw_stat = true;
2882
2883           m = gfc_match_char (',');
2884           if (m == MATCH_YES)
2885             continue;
2886
2887           tmp = NULL;
2888           break;
2889         }
2890
2891       m = gfc_match (" errmsg = %v", &tmp);
2892       if (m == MATCH_ERROR)
2893         goto syntax;
2894       if (m == MATCH_YES)
2895         {
2896           if (saw_errmsg)
2897             {
2898               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2899               goto cleanup;
2900             }
2901           errmsg = tmp;
2902           saw_errmsg = true;
2903
2904           m = gfc_match_char (',');
2905           if (m == MATCH_YES)
2906             continue;
2907
2908           tmp = NULL;
2909           break;
2910         }
2911
2912       m = gfc_match (" acquired_lock = %v", &tmp);
2913       if (m == MATCH_ERROR || st == ST_UNLOCK)
2914         goto syntax;
2915       if (m == MATCH_YES)
2916         {
2917           if (saw_acq_lock)
2918             {
2919               gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
2920                          &tmp->where);
2921               goto cleanup;
2922             }
2923           acq_lock = tmp;
2924           saw_acq_lock = true;
2925
2926           m = gfc_match_char (',');
2927           if (m == MATCH_YES)
2928             continue;
2929
2930           tmp = NULL;
2931           break;
2932         }
2933
2934       break;
2935     }
2936
2937   if (m == MATCH_ERROR)
2938     goto syntax;
2939
2940   if (gfc_match (" )%t") != MATCH_YES)
2941     goto syntax;
2942
2943 done:
2944   switch (st)
2945     {
2946     case ST_LOCK:
2947       new_st.op = EXEC_LOCK;
2948       break;
2949     case ST_UNLOCK:
2950       new_st.op = EXEC_UNLOCK;
2951       break;
2952     default:
2953       gcc_unreachable ();
2954     }
2955
2956   new_st.expr1 = lockvar;
2957   new_st.expr2 = stat;
2958   new_st.expr3 = errmsg;
2959   new_st.expr4 = acq_lock;
2960
2961   return MATCH_YES;
2962
2963 syntax:
2964   gfc_syntax_error (st);
2965
2966 cleanup:
2967   gfc_free_expr (tmp);
2968   gfc_free_expr (lockvar);
2969   gfc_free_expr (acq_lock);
2970   gfc_free_expr (stat);
2971   gfc_free_expr (errmsg);
2972
2973   return MATCH_ERROR;
2974 }
2975
2976
2977 match
2978 gfc_match_lock (void)
2979 {
2980   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: LOCK statement at %C")
2981       == FAILURE)
2982     return MATCH_ERROR;
2983
2984   return lock_unlock_statement (ST_LOCK);
2985 }
2986
2987
2988 match
2989 gfc_match_unlock (void)
2990 {
2991   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: UNLOCK statement at %C")
2992       == FAILURE)
2993     return MATCH_ERROR;
2994
2995   return lock_unlock_statement (ST_UNLOCK);
2996 }
2997
2998
2999 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3000      SYNC ALL [(sync-stat-list)]
3001      SYNC MEMORY [(sync-stat-list)]
3002      SYNC IMAGES (image-set [, sync-stat-list] )
3003    with sync-stat is int-expr or *.  */
3004
3005 static match
3006 sync_statement (gfc_statement st)
3007 {
3008   match m;
3009   gfc_expr *tmp, *imageset, *stat, *errmsg;
3010   bool saw_stat, saw_errmsg;
3011
3012   tmp = imageset = stat = errmsg = NULL;
3013   saw_stat = saw_errmsg = false;
3014
3015   if (gfc_pure (NULL))
3016     {
3017       gfc_error ("Image control statement SYNC at %C in PURE procedure");
3018       return MATCH_ERROR;
3019     }
3020
3021   if (gfc_implicit_pure (NULL))
3022     gfc_current_ns->proc_name->attr.implicit_pure = 0;
3023
3024   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C")
3025       == FAILURE)
3026     return MATCH_ERROR;
3027
3028   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3029     {
3030        gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3031        return MATCH_ERROR;
3032     }
3033
3034   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
3035     {
3036       gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3037       return MATCH_ERROR;
3038     }
3039
3040   if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
3041     {
3042       gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3043       return MATCH_ERROR;
3044     }
3045
3046   if (gfc_match_eos () == MATCH_YES)
3047     {
3048       if (st == ST_SYNC_IMAGES)
3049         goto syntax;
3050       goto done;
3051     }
3052
3053   if (gfc_match_char ('(') != MATCH_YES)
3054     goto syntax;
3055
3056   if (st == ST_SYNC_IMAGES)
3057     {
3058       /* Denote '*' as imageset == NULL.  */
3059       m = gfc_match_char ('*');
3060       if (m == MATCH_ERROR)
3061         goto syntax;
3062       if (m == MATCH_NO)
3063         {
3064           if (gfc_match ("%e", &imageset) != MATCH_YES)
3065             goto syntax;
3066         }
3067       m = gfc_match_char (',');
3068       if (m == MATCH_ERROR)
3069         goto syntax;
3070       if (m == MATCH_NO)
3071         {
3072           m = gfc_match_char (')');
3073           if (m == MATCH_YES)
3074             goto done;
3075           goto syntax;
3076         }
3077     }
3078
3079   for (;;)
3080     {
3081       m = gfc_match (" stat = %v", &tmp);
3082       if (m == MATCH_ERROR)
3083         goto syntax;
3084       if (m == MATCH_YES)
3085         {
3086           if (saw_stat)
3087             {
3088               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3089               goto cleanup;
3090             }
3091           stat = tmp;
3092           saw_stat = true;
3093
3094           if (gfc_match_char (',') == MATCH_YES)
3095             continue;
3096
3097           tmp = NULL;
3098           break;
3099         }
3100
3101       m = gfc_match (" errmsg = %v", &tmp);
3102       if (m == MATCH_ERROR)
3103         goto syntax;
3104       if (m == MATCH_YES)
3105         {
3106           if (saw_errmsg)
3107             {
3108               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3109               goto cleanup;
3110             }
3111           errmsg = tmp;
3112           saw_errmsg = true;
3113
3114           if (gfc_match_char (',') == MATCH_YES)
3115             continue;
3116
3117           tmp = NULL;
3118           break;
3119         }
3120
3121         break;
3122     }
3123
3124   if (m == MATCH_ERROR)
3125     goto syntax;
3126
3127   if (gfc_match (" )%t") != MATCH_YES)
3128     goto syntax;
3129
3130 done:
3131   switch (st)
3132     {
3133     case ST_SYNC_ALL:
3134       new_st.op = EXEC_SYNC_ALL;
3135       break;
3136     case ST_SYNC_IMAGES:
3137       new_st.op = EXEC_SYNC_IMAGES;
3138       break;
3139     case ST_SYNC_MEMORY:
3140       new_st.op = EXEC_SYNC_MEMORY;
3141       break;
3142     default:
3143       gcc_unreachable ();
3144     }
3145
3146   new_st.expr1 = imageset;
3147   new_st.expr2 = stat;
3148   new_st.expr3 = errmsg;
3149
3150   return MATCH_YES;
3151
3152 syntax:
3153   gfc_syntax_error (st);
3154
3155 cleanup:
3156   gfc_free_expr (tmp);
3157   gfc_free_expr (imageset);
3158   gfc_free_expr (stat);
3159   gfc_free_expr (errmsg);
3160
3161   return MATCH_ERROR;
3162 }
3163
3164
3165 /* Match SYNC ALL statement.  */
3166
3167 match
3168 gfc_match_sync_all (void)
3169 {
3170   return sync_statement (ST_SYNC_ALL);
3171 }
3172
3173
3174 /* Match SYNC IMAGES statement.  */
3175
3176 match
3177 gfc_match_sync_images (void)
3178 {
3179   return sync_statement (ST_SYNC_IMAGES);
3180 }
3181
3182
3183 /* Match SYNC MEMORY statement.  */
3184
3185 match
3186 gfc_match_sync_memory (void)
3187 {
3188   return sync_statement (ST_SYNC_MEMORY);
3189 }
3190
3191
3192 /* Match a CONTINUE statement.  */
3193
3194 match
3195 gfc_match_continue (void)
3196 {
3197   if (gfc_match_eos () != MATCH_YES)
3198     {
3199       gfc_syntax_error (ST_CONTINUE);
3200       return MATCH_ERROR;
3201     }
3202
3203   new_st.op = EXEC_CONTINUE;
3204   return MATCH_YES;
3205 }
3206
3207
3208 /* Match the (deprecated) ASSIGN statement.  */
3209
3210 match
3211 gfc_match_assign (void)
3212 {
3213   gfc_expr *expr;
3214   gfc_st_label *label;
3215
3216   if (gfc_match (" %l", &label) == MATCH_YES)
3217     {
3218       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
3219         return MATCH_ERROR;
3220       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
3221         {
3222           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
3223                               "statement at %C")
3224               == FAILURE)
3225             return MATCH_ERROR;
3226
3227           expr->symtree->n.sym->attr.assign = 1;
3228
3229           new_st.op = EXEC_LABEL_ASSIGN;
3230           new_st.label1 = label;
3231           new_st.expr1 = expr;
3232           return MATCH_YES;
3233         }
3234     }
3235   return MATCH_NO;
3236 }
3237
3238
3239 /* Match the GO TO statement.  As a computed GOTO statement is
3240    matched, it is transformed into an equivalent SELECT block.  No
3241    tree is necessary, and the resulting jumps-to-jumps are
3242    specifically optimized away by the back end.  */
3243
3244 match
3245 gfc_match_goto (void)
3246 {
3247   gfc_code *head, *tail;
3248   gfc_expr *expr;
3249   gfc_case *cp;
3250   gfc_st_label *label;
3251   int i;
3252   match m;
3253
3254   if (gfc_match (" %l%t", &label) == MATCH_YES)
3255     {
3256       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
3257         return MATCH_ERROR;
3258
3259       new_st.op = EXEC_GOTO;
3260       new_st.label1 = label;
3261       return MATCH_YES;
3262     }
3263
3264   /* The assigned GO TO statement.  */
3265
3266   if (gfc_match_variable (&expr, 0) == MATCH_YES)
3267     {
3268       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
3269                           "statement at %C")
3270           == FAILURE)
3271         return MATCH_ERROR;
3272
3273       new_st.op = EXEC_GOTO;
3274       new_st.expr1 = expr;
3275
3276       if (gfc_match_eos () == MATCH_YES)
3277         return MATCH_YES;
3278
3279       /* Match label list.  */
3280       gfc_match_char (',');
3281       if (gfc_match_char ('(') != MATCH_YES)
3282         {
3283           gfc_syntax_error (ST_GOTO);
3284           return MATCH_ERROR;
3285         }
3286       head = tail = NULL;
3287
3288       do
3289         {
3290           m = gfc_match_st_label (&label);
3291           if (m != MATCH_YES)
3292             goto syntax;
3293
3294           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
3295             goto cleanup;
3296
3297           if (head == NULL)
3298             head = tail = gfc_get_code ();
3299           else
3300             {
3301               tail->block = gfc_get_code ();
3302               tail = tail->block;
3303             }
3304
3305           tail->label1 = label;
3306           tail->op = EXEC_GOTO;
3307         }
3308       while (gfc_match_char (',') == MATCH_YES);
3309
3310       if (gfc_match (")%t") != MATCH_YES)
3311         goto syntax;
3312
3313       if (head == NULL)
3314         {
3315            gfc_error ("Statement label list in GOTO at %C cannot be empty");
3316            goto syntax;
3317         }
3318       new_st.block = head;
3319
3320       return MATCH_YES;
3321     }
3322
3323   /* Last chance is a computed GO TO statement.  */
3324   if (gfc_match_char ('(') != MATCH_YES)
3325     {
3326       gfc_syntax_error (ST_GOTO);
3327       return MATCH_ERROR;
3328     }
3329
3330   head = tail = NULL;
3331   i = 1;
3332
3333   do
3334     {
3335       m = gfc_match_st_label (&label);
3336       if (m != MATCH_YES)
3337         goto syntax;
3338
3339       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
3340         goto cleanup;
3341
3342       if (head == NULL)
3343         head = tail = gfc_get_code ();
3344       else
3345         {
3346           tail->block = gfc_get_code ();
3347           tail = tail->block;
3348         }
3349
3350       cp = gfc_get_case ();
3351       cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
3352                                              NULL, i++);
3353
3354       tail->op = EXEC_SELECT;
3355       tail->ext.block.case_list = cp;
3356
3357       tail->next = gfc_get_code ();
3358       tail->next->op = EXEC_GOTO;
3359       tail->next->label1 = label;
3360     }
3361   while (gfc_match_char (',') == MATCH_YES);
3362
3363   if (gfc_match_char (')') != MATCH_YES)
3364     goto syntax;
3365
3366   if (head == NULL)
3367     {
3368       gfc_error ("Statement label list in GOTO at %C cannot be empty");
3369       goto syntax;
3370     }
3371
3372   /* Get the rest of the statement.  */
3373   gfc_match_char (',');
3374
3375   if (gfc_match (" %e%t", &expr) != MATCH_YES)
3376     goto syntax;
3377
3378   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO "
3379                       "at %C") == FAILURE)
3380     return MATCH_ERROR;
3381
3382   /* At this point, a computed GOTO has been fully matched and an
3383      equivalent SELECT statement constructed.  */
3384
3385   new_st.op = EXEC_SELECT;
3386   new_st.expr1 = NULL;
3387
3388   /* Hack: For a "real" SELECT, the expression is in expr. We put
3389      it in expr2 so we can distinguish then and produce the correct
3390      diagnostics.  */
3391   new_st.expr2 = expr;
3392   new_st.block = head;
3393   return MATCH_YES;
3394
3395 syntax:
3396   gfc_syntax_error (ST_GOTO);
3397 cleanup:
3398   gfc_free_statements (head);
3399   return MATCH_ERROR;
3400 }
3401
3402
3403 /* Frees a list of gfc_alloc structures.  */
3404
3405 void
3406 gfc_free_alloc_list (gfc_alloc *p)
3407 {
3408   gfc_alloc *q;
3409
3410   for (; p; p = q)
3411     {
3412       q = p->next;
3413       gfc_free_expr (p->expr);
3414       free (p);
3415     }
3416 }
3417
3418
3419 /* Match an ALLOCATE statement.  */
3420
3421 match
3422 gfc_match_allocate (void)
3423 {
3424   gfc_alloc *head, *tail;
3425   gfc_expr *stat, *errmsg, *tmp, *source, *mold;
3426   gfc_typespec ts;
3427   gfc_symbol *sym;
3428   match m;
3429   locus old_locus, deferred_locus;
3430   bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
3431
3432   head = tail = NULL;
3433   stat = errmsg = source = mold = tmp = NULL;
3434   saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
3435
3436   if (gfc_match_char ('(') != MATCH_YES)
3437     goto syntax;
3438
3439   /* Match an optional type-spec.  */
3440   old_locus = gfc_current_locus;
3441   m = match_type_spec (&ts);
3442   if (m == MATCH_ERROR)
3443     goto cleanup;
3444   else if (m == MATCH_NO)
3445     {
3446       char name[GFC_MAX_SYMBOL_LEN + 3];
3447
3448       if (gfc_match ("%n :: ", name) == MATCH_YES)
3449         {
3450           gfc_error ("Error in type-spec at %L", &old_locus);
3451           goto cleanup;
3452         }
3453
3454       ts.type = BT_UNKNOWN;
3455     }
3456   else
3457     {
3458       if (gfc_match (" :: ") == MATCH_YES)
3459         {
3460           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
3461                               "ALLOCATE at %L", &old_locus) == FAILURE)
3462             goto cleanup;
3463
3464           if (ts.deferred)
3465             {
3466               gfc_error ("Type-spec at %L cannot contain a deferred "
3467                          "type parameter", &old_locus);
3468               goto cleanup;
3469             }
3470         }
3471       else
3472         {
3473           ts.type = BT_UNKNOWN;
3474           gfc_current_locus = old_locus;
3475         }
3476     }
3477
3478   for (;;)
3479     {
3480       if (head == NULL)
3481         head = tail = gfc_get_alloc ();
3482       else
3483         {
3484           tail->next = gfc_get_alloc ();
3485           tail = tail->next;
3486         }
3487
3488       m = gfc_match_variable (&tail->expr, 0);
3489       if (m == MATCH_NO)
3490         goto syntax;
3491       if (m == MATCH_ERROR)
3492         goto cleanup;
3493
3494       if (gfc_check_do_variable (tail->expr->symtree))
3495         goto cleanup;
3496
3497       if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
3498         {
3499           gfc_error ("Bad allocate-object at %C for a PURE procedure");
3500           goto cleanup;
3501         }
3502
3503       if (gfc_implicit_pure (NULL)
3504             && gfc_impure_variable (tail->expr->symtree->n.sym))
3505         gfc_current_ns->proc_name->attr.implicit_pure = 0;
3506
3507       if (tail->expr->ts.deferred)
3508         {
3509           saw_deferred = true;
3510           deferred_locus = tail->expr->where;
3511         }
3512
3513       if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS
3514           || gfc_find_state (COMP_CRITICAL) == SUCCESS)
3515         {
3516           gfc_ref *ref;
3517           bool coarray = tail->expr->symtree->n.sym->attr.codimension;
3518           for (ref = tail->expr->ref; ref; ref = ref->next)
3519             if (ref->type == REF_COMPONENT)
3520               coarray = ref->u.c.component->attr.codimension;
3521
3522           if (coarray && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
3523             {
3524               gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
3525               goto cleanup;
3526             }
3527           if (coarray && gfc_find_state (COMP_CRITICAL) == SUCCESS)
3528             {
3529               gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
3530               goto cleanup;
3531             }
3532         }
3533
3534       /* The ALLOCATE statement had an optional typespec.  Check the
3535          constraints.  */
3536       if (ts.type != BT_UNKNOWN)
3537         {
3538           /* Enforce F03:C624.  */
3539           if (!gfc_type_compatible (&tail->expr->ts, &ts))
3540             {
3541               gfc_error ("Type of entity at %L is type incompatible with "
3542                          "typespec", &tail->expr->where);
3543               goto cleanup;
3544             }
3545
3546           /* Enforce F03:C627.  */
3547           if (ts.kind != tail->expr->ts.kind)
3548             {
3549               gfc_error ("Kind type parameter for entity at %L differs from "
3550                          "the kind type parameter of the typespec",
3551                          &tail->expr->where);
3552               goto cleanup;
3553             }
3554         }
3555
3556       if (tail->expr->ts.type == BT_DERIVED)
3557         tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
3558
3559       /* FIXME: disable the checking on derived types and arrays.  */
3560       sym = tail->expr->symtree->n.sym;
3561       b1 = !(tail->expr->ref
3562            && (tail->expr->ref->type == REF_COMPONENT
3563                 || tail->expr->ref->type == REF_ARRAY));
3564       if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
3565         b2 = !(CLASS_DATA (sym)->attr.allocatable
3566                || CLASS_DATA (sym)->attr.class_pointer);
3567       else
3568         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3569                       || sym->attr.proc_pointer);
3570       b3 = sym && sym->ns && sym->ns->proc_name
3571            && (sym->ns->proc_name->attr.allocatable
3572                 || sym->ns->proc_name->attr.pointer
3573                 || sym->ns->proc_name->attr.proc_pointer);
3574       if (b1 && b2 && !b3)
3575         {
3576           gfc_error ("Allocate-object at %L is not a nonprocedure pointer "
3577                      "or an allocatable variable", &tail->expr->where);
3578           goto cleanup;
3579         }
3580
3581       if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
3582         {
3583           gfc_error ("Shape specification for allocatable scalar at %C");
3584           goto cleanup;
3585         }
3586
3587       if (gfc_match_char (',') != MATCH_YES)
3588         break;
3589
3590 alloc_opt_list:
3591
3592       m = gfc_match (" stat = %v", &tmp);
3593       if (m == MATCH_ERROR)
3594         goto cleanup;
3595       if (m == MATCH_YES)
3596         {
3597           /* Enforce C630.  */
3598           if (saw_stat)
3599             {
3600               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3601               goto cleanup;
3602             }
3603
3604           stat = tmp;
3605           tmp = NULL;
3606           saw_stat = true;
3607
3608           if (gfc_check_do_variable (stat->symtree))
3609             goto cleanup;
3610
3611           if (gfc_match_char (',') == MATCH_YES)
3612             goto alloc_opt_list;
3613         }
3614
3615       m = gfc_match (" errmsg = %v", &tmp);
3616       if (m == MATCH_ERROR)
3617         goto cleanup;
3618       if (m == MATCH_YES)
3619         {
3620           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
3621                               &tmp->where) == FAILURE)
3622             goto cleanup;
3623
3624           /* Enforce C630.  */
3625           if (saw_errmsg)
3626             {
3627               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3628               goto cleanup;
3629             }
3630
3631           errmsg = tmp;
3632           tmp = NULL;
3633           saw_errmsg = true;
3634
3635           if (gfc_match_char (',') == MATCH_YES)
3636             goto alloc_opt_list;
3637         }
3638
3639       m = gfc_match (" source = %e", &tmp);
3640       if (m == MATCH_ERROR)
3641         goto cleanup;
3642       if (m == MATCH_YES)
3643         {
3644           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
3645                               &tmp->where) == FAILURE)
3646             goto cleanup;
3647
3648           /* Enforce C630.  */
3649           if (saw_source)
3650             {
3651               gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
3652               goto cleanup;
3653             }
3654
3655           /* The next 2 conditionals check C631.  */
3656           if (ts.type != BT_UNKNOWN)
3657             {
3658               gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3659                          &tmp->where, &old_locus);
3660               goto cleanup;
3661             }
3662
3663           if (head->next)
3664             {
3665               gfc_error ("SOURCE tag at %L requires only a single entity in "
3666                          "the allocation-list", &tmp->where);
3667               goto cleanup;
3668             }
3669
3670           source = tmp;
3671           tmp = NULL;
3672           saw_source = true;
3673
3674           if (gfc_match_char (',') == MATCH_YES)
3675             goto alloc_opt_list;
3676         }
3677
3678       m = gfc_match (" mold = %e", &tmp);
3679       if (m == MATCH_ERROR)
3680         goto cleanup;
3681       if (m == MATCH_YES)
3682         {
3683           if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L",
3684                               &tmp->where) == FAILURE)
3685             goto cleanup;
3686
3687           /* Check F08:C636.  */
3688           if (saw_mold)
3689             {
3690               gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
3691               goto cleanup;
3692             }
3693
3694           /* Check F08:C637.  */
3695           if (ts.type != BT_UNKNOWN)
3696             {
3697               gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3698                          &tmp->where, &old_locus);
3699               goto cleanup;
3700             }
3701
3702           mold = tmp;
3703           tmp = NULL;
3704           saw_mold = true;
3705           mold->mold = 1;
3706
3707           if (gfc_match_char (',') == MATCH_YES)
3708             goto alloc_opt_list;
3709         }
3710
3711         gfc_gobble_whitespace ();
3712
3713         if (gfc_peek_char () == ')')
3714           break;
3715     }
3716
3717   if (gfc_match (" )%t") != MATCH_YES)
3718     goto syntax;
3719
3720   /* Check F08:C637.  */
3721   if (source && mold)
3722     {
3723       gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3724                   &mold->where, &source->where);
3725       goto cleanup;
3726     }
3727
3728   /* Check F03:C623,  */
3729   if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
3730     {
3731       gfc_error ("Allocate-object at %L with a deferred type parameter "
3732                  "requires either a type-spec or SOURCE tag or a MOLD tag",
3733                  &deferred_locus);
3734       goto cleanup;
3735     }
3736
3737   new_st.op = EXEC_ALLOCATE;
3738   new_st.expr1 = stat;
3739   new_st.expr2 = errmsg;
3740   if (source)
3741     new_st.expr3 = source;
3742   else
3743     new_st.expr3 = mold;
3744   new_st.ext.alloc.list = head;
3745   new_st.ext.alloc.ts = ts;
3746
3747   return MATCH_YES;
3748
3749 syntax:
3750   gfc_syntax_error (ST_ALLOCATE);
3751
3752 cleanup:
3753   gfc_free_expr (errmsg);
3754   gfc_free_expr (source);
3755   gfc_free_expr (stat);
3756   gfc_free_expr (mold);
3757   if (tmp && tmp->expr_type) gfc_free_expr (tmp);
3758   gfc_free_alloc_list (head);
3759   return MATCH_ERROR;
3760 }
3761
3762
3763 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3764    a set of pointer assignments to intrinsic NULL().  */
3765
3766 match
3767 gfc_match_nullify (void)
3768 {
3769   gfc_code *tail;
3770   gfc_expr *e, *p;
3771   match m;
3772
3773   tail = NULL;
3774
3775   if (gfc_match_char ('(') != MATCH_YES)
3776     goto syntax;
3777
3778   for (;;)
3779     {
3780       m = gfc_match_variable (&p, 0);
3781       if (m == MATCH_ERROR)
3782         goto cleanup;
3783       if (m == MATCH_NO)
3784         goto syntax;
3785
3786       if (gfc_check_do_variable (p->symtree))
3787         goto cleanup;
3788
3789       /* F2008, C1242.  */
3790       if (gfc_is_coindexed (p))
3791         {
3792           gfc_error ("Pointer object at %C shall not be conindexed");
3793           goto cleanup;
3794         }
3795
3796       /* build ' => NULL() '.  */
3797       e = gfc_get_null_expr (&gfc_current_locus);
3798
3799       /* Chain to list.  */
3800       if (tail == NULL)
3801         tail = &new_st;
3802       else
3803         {
3804           tail->next = gfc_get_code ();
3805           tail = tail->next;
3806         }
3807
3808       tail->op = EXEC_POINTER_ASSIGN;
3809       tail->expr1 = p;
3810       tail->expr2 = e;
3811
3812       if (gfc_match (" )%t") == MATCH_YES)
3813         break;
3814       if (gfc_match_char (',') != MATCH_YES)
3815         goto syntax;
3816     }
3817
3818   return MATCH_YES;
3819
3820 syntax:
3821   gfc_syntax_error (ST_NULLIFY);
3822
3823 cleanup:
3824   gfc_free_statements (new_st.next);
3825   new_st.next = NULL;
3826   gfc_free_expr (new_st.expr1);
3827   new_st.expr1 = NULL;
3828   gfc_free_expr (new_st.expr2);
3829   new_st.expr2 = NULL;
3830   return MATCH_ERROR;
3831 }
3832
3833
3834 /* Match a DEALLOCATE statement.  */
3835
3836 match
3837 gfc_match_deallocate (void)
3838 {
3839   gfc_alloc *head, *tail;
3840   gfc_expr *stat, *errmsg, *tmp;
3841   gfc_symbol *sym;
3842   match m;
3843   bool saw_stat, saw_errmsg, b1, b2;
3844
3845   head = tail = NULL;
3846   stat = errmsg = tmp = NULL;
3847   saw_stat = saw_errmsg = false;
3848
3849   if (gfc_match_char ('(') != MATCH_YES)
3850     goto syntax;
3851
3852   for (;;)
3853     {
3854       if (head == NULL)
3855         head = tail = gfc_get_alloc ();
3856       else
3857         {
3858           tail->next = gfc_get_alloc ();
3859           tail = tail->next;
3860         }
3861
3862       m = gfc_match_variable (&tail->expr, 0);
3863       if (m == MATCH_ERROR)
3864         goto cleanup;
3865       if (m == MATCH_NO)
3866         goto syntax;
3867
3868       if (gfc_check_do_variable (tail->expr->symtree))
3869         goto cleanup;
3870
3871       sym = tail->expr->symtree->n.sym;
3872
3873       if (gfc_pure (NULL) && gfc_impure_variable (sym))
3874         {
3875           gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3876           goto cleanup;
3877         }
3878
3879       if (gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
3880         gfc_current_ns->proc_name->attr.implicit_pure = 0;
3881
3882       if (gfc_is_coarray (tail->expr)
3883           && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
3884         {
3885           gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
3886           goto cleanup;
3887         }
3888
3889       if (gfc_is_coarray (tail->expr)
3890           && gfc_find_state (COMP_CRITICAL) == SUCCESS)
3891         {
3892           gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
3893           goto cleanup;
3894         }
3895
3896       /* FIXME: disable the checking on derived types.  */
3897       b1 = !(tail->expr->ref
3898            && (tail->expr->ref->type == REF_COMPONENT
3899                || tail->expr->ref->type == REF_ARRAY));
3900       if (sym && sym->ts.type == BT_CLASS)
3901         b2 = !(CLASS_DATA (sym)->attr.allocatable
3902                || CLASS_DATA (sym)->attr.class_pointer);
3903       else
3904         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3905                       || sym->attr.proc_pointer);
3906       if (b1 && b2)
3907         {
3908           gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3909                      "or an allocatable variable");
3910           goto cleanup;
3911         }
3912
3913       if (gfc_match_char (',') != MATCH_YES)
3914         break;
3915
3916 dealloc_opt_list:
3917
3918       m = gfc_match (" stat = %v", &tmp);
3919       if (m == MATCH_ERROR)
3920         goto cleanup;
3921       if (m == MATCH_YES)
3922         {
3923           if (saw_stat)
3924             {
3925               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3926               gfc_free_expr (tmp);
3927               goto cleanup;
3928             }
3929
3930           stat = tmp;
3931           saw_stat = true;
3932
3933           if (gfc_check_do_variable (stat->symtree))
3934             goto cleanup;
3935
3936           if (gfc_match_char (',') == MATCH_YES)
3937             goto dealloc_opt_list;
3938         }
3939
3940       m = gfc_match (" errmsg = %v", &tmp);
3941       if (m == MATCH_ERROR)
3942         goto cleanup;
3943       if (m == MATCH_YES)
3944         {
3945           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
3946                               &tmp->where) == FAILURE)
3947             goto cleanup;
3948
3949           if (saw_errmsg)
3950             {
3951               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3952               gfc_free_expr (tmp);
3953               goto cleanup;
3954             }
3955
3956           errmsg = tmp;
3957           saw_errmsg = true;
3958
3959           if (gfc_match_char (',') == MATCH_YES)
3960             goto dealloc_opt_list;
3961         }
3962
3963         gfc_gobble_whitespace ();
3964
3965         if (gfc_peek_char () == ')')
3966           break;
3967     }
3968
3969   if (gfc_match (" )%t") != MATCH_YES)
3970     goto syntax;
3971
3972   new_st.op = EXEC_DEALLOCATE;
3973   new_st.expr1 = stat;
3974   new_st.expr2 = errmsg;
3975   new_st.ext.alloc.list = head;
3976
3977   return MATCH_YES;
3978
3979 syntax:
3980   gfc_syntax_error (ST_DEALLOCATE);
3981
3982 cleanup:
3983   gfc_free_expr (errmsg);
3984   gfc_free_expr (stat);
3985   gfc_free_alloc_list (head);
3986   return MATCH_ERROR;
3987 }
3988
3989
3990 /* Match a RETURN statement.  */
3991
3992 match
3993 gfc_match_return (void)
3994 {
3995   gfc_expr *e;
3996   match m;
3997   gfc_compile_state s;
3998
3999   e = NULL;
4000
4001   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
4002     {
4003       gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4004       return MATCH_ERROR;
4005     }
4006
4007   if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
4008     {
4009       gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4010       return MATCH_ERROR;
4011     }
4012
4013   if (gfc_match_eos () == MATCH_YES)
4014     goto done;
4015
4016   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
4017     {
4018       gfc_error ("Alternate RETURN statement at %C is only allowed within "
4019                  "a SUBROUTINE");
4020       goto cleanup;
4021     }
4022
4023   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN "
4024                       "at %C") == FAILURE)
4025     return MATCH_ERROR;
4026
4027   if (gfc_current_form == FORM_FREE)
4028     {
4029       /* The following are valid, so we can't require a blank after the
4030         RETURN keyword:
4031           return+1
4032           return(1)  */
4033       char c = gfc_peek_ascii_char ();
4034       if (ISALPHA (c) || ISDIGIT (c))
4035         return MATCH_NO;
4036     }
4037
4038   m = gfc_match (" %e%t", &e);
4039   if (m == MATCH_YES)
4040     goto done;
4041   if (m == MATCH_ERROR)
4042     goto cleanup;
4043
4044   gfc_syntax_error (ST_RETURN);
4045
4046 cleanup:
4047   gfc_free_expr (e);
4048   return MATCH_ERROR;
4049
4050 done:
4051   gfc_enclosing_unit (&s);
4052   if (s == COMP_PROGRAM
4053       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
4054                         "main program at %C") == FAILURE)
4055       return MATCH_ERROR;
4056
4057   new_st.op = EXEC_RETURN;
4058   new_st.expr1 = e;
4059
4060   return MATCH_YES;
4061 }
4062
4063
4064 /* Match the call of a type-bound procedure, if CALL%var has already been
4065    matched and var found to be a derived-type variable.  */
4066
4067 static match
4068 match_typebound_call (gfc_symtree* varst)
4069 {
4070   gfc_expr* base;
4071   match m;
4072
4073   base = gfc_get_expr ();
4074   base->expr_type = EXPR_VARIABLE;
4075   base->symtree = varst;
4076   base->where = gfc_current_locus;
4077   gfc_set_sym_referenced (varst->n.sym);
4078
4079   m = gfc_match_varspec (base, 0, true, true);
4080   if (m == MATCH_NO)
4081     gfc_error ("Expected component reference at %C");
4082   if (m != MATCH_YES)
4083     return MATCH_ERROR;
4084
4085   if (gfc_match_eos () != MATCH_YES)
4086     {
4087       gfc_error ("Junk after CALL at %C");
4088       return MATCH_ERROR;
4089     }
4090
4091   if (base->expr_type == EXPR_COMPCALL)
4092     new_st.op = EXEC_COMPCALL;
4093   else if (base->expr_type == EXPR_PPC)
4094     new_st.op = EXEC_CALL_PPC;
4095   else
4096     {
4097       gfc_error ("Expected type-bound procedure or procedure pointer component "
4098                  "at %C");
4099       return MATCH_ERROR;
4100     }
4101   new_st.expr1 = base;
4102
4103   return MATCH_YES;
4104 }
4105
4106
4107 /* Match a CALL statement.  The tricky part here are possible
4108    alternate return specifiers.  We handle these by having all
4109    "subroutines" actually return an integer via a register that gives
4110    the return number.  If the call specifies alternate returns, we
4111    generate code for a SELECT statement whose case clauses contain
4112    GOTOs to the various labels.  */
4113
4114 match
4115 gfc_match_call (void)
4116 {
4117   char name[GFC_MAX_SYMBOL_LEN + 1];
4118   gfc_actual_arglist *a, *arglist;
4119   gfc_case *new_case;
4120   gfc_symbol *sym;
4121   gfc_symtree *st;
4122   gfc_code *c;
4123   match m;
4124   int i;
4125
4126   arglist = NULL;
4127
4128   m = gfc_match ("% %n", name);
4129   if (m == MATCH_NO)
4130     goto syntax;
4131   if (m != MATCH_YES)
4132     return m;
4133
4134   if (gfc_get_ha_sym_tree (name, &st))
4135     return MATCH_ERROR;
4136
4137   sym = st->n.sym;
4138
4139   /* If this is a variable of derived-type, it probably starts a type-bound
4140      procedure call.  */
4141   if ((sym->attr.flavor != FL_PROCEDURE
4142        || gfc_is_function_return_value (sym, gfc_current_ns))
4143       && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
4144     return match_typebound_call (st);
4145
4146   /* If it does not seem to be callable (include functions so that the
4147      right association is made.  They are thrown out in resolution.)
4148      ...  */
4149   if (!sym->attr.generic
4150         && !sym->attr.subroutine
4151         && !sym->attr.function)
4152     {
4153       if (!(sym->attr.external && !sym->attr.referenced))
4154         {
4155           /* ...create a symbol in this scope...  */
4156           if (sym->ns != gfc_current_ns
4157                 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
4158             return MATCH_ERROR;
4159
4160           if (sym != st->n.sym)
4161             sym = st->n.sym;
4162         }
4163
4164       /* ...and then to try to make the symbol into a subroutine.  */
4165       if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
4166         return MATCH_ERROR;
4167     }
4168
4169   gfc_set_sym_referenced (sym);
4170
4171   if (gfc_match_eos () != MATCH_YES)
4172     {
4173       m = gfc_match_actual_arglist (1, &arglist);
4174       if (m == MATCH_NO)
4175         goto syntax;
4176       if (m == MATCH_ERROR)
4177         goto cleanup;
4178
4179       if (gfc_match_eos () != MATCH_YES)
4180         goto syntax;
4181     }
4182
4183   /* If any alternate return labels were found, construct a SELECT
4184      statement that will jump to the right place.  */
4185
4186   i = 0;
4187   for (a = arglist; a; a = a->next)
4188     if (a->expr == NULL)
4189       i = 1;
4190
4191   if (i)
4192     {
4193       gfc_symtree *select_st;
4194       gfc_symbol *select_sym;
4195       char name[GFC_MAX_SYMBOL_LEN + 1];
4196
4197       new_st.next = c = gfc_get_code ();
4198       c->op = EXEC_SELECT;
4199       sprintf (name, "_result_%s", sym->name);
4200       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
4201
4202       select_sym = select_st->n.sym;
4203       select_sym->ts.type = BT_INTEGER;
4204       select_sym->ts.kind = gfc_default_integer_kind;
4205       gfc_set_sym_referenced (select_sym);
4206       c->expr1 = gfc_get_expr ();
4207       c->expr1->expr_type = EXPR_VARIABLE;
4208       c->expr1->symtree = select_st;
4209       c->expr1->ts = select_sym->ts;
4210       c->expr1->where = gfc_current_locus;
4211
4212       i = 0;
4213       for (a = arglist; a; a = a->next)
4214         {
4215           if (a->expr != NULL)
4216             continue;
4217
4218           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
4219             continue;
4220
4221           i++;
4222
4223           c->block = gfc_get_code ();
4224           c = c->block;
4225           c->op = EXEC_SELECT;
4226
4227           new_case = gfc_get_case ();
4228           new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
4229           new_case->low = new_case->high;
4230           c->ext.block.case_list = new_case;
4231
4232           c->next = gfc_get_code ();
4233           c->next->op = EXEC_GOTO;
4234           c->next->label1 = a->label;
4235         }
4236     }
4237
4238   new_st.op = EXEC_CALL;
4239   new_st.symtree = st;
4240   new_st.ext.actual = arglist;
4241
4242   return MATCH_YES;
4243
4244 syntax:
4245   gfc_syntax_error (ST_CALL);
4246
4247 cleanup:
4248   gfc_free_actual_arglist (arglist);
4249   return MATCH_ERROR;
4250 }
4251
4252
4253 /* Given a name, return a pointer to the common head structure,
4254    creating it if it does not exist. If FROM_MODULE is nonzero, we
4255    mangle the name so that it doesn't interfere with commons defined
4256    in the using namespace.
4257    TODO: Add to global symbol tree.  */
4258
4259 gfc_common_head *
4260 gfc_get_common (const char *name, int from_module)
4261 {
4262   gfc_symtree *st;
4263   static int serial = 0;
4264   char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
4265
4266   if (from_module)
4267     {
4268       /* A use associated common block is only needed to correctly layout
4269          the variables it contains.  */
4270       snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
4271       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
4272     }
4273   else
4274     {
4275       st = gfc_find_symtree (gfc_current_ns->common_root, name);
4276
4277       if (st == NULL)
4278         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
4279     }
4280
4281   if (st->n.common == NULL)
4282     {
4283       st->n.common = gfc_get_common_head ();
4284       st->n.common->where = gfc_current_locus;
4285       strcpy (st->n.common->name, name);
4286     }
4287
4288   return st->n.common;
4289 }
4290
4291
4292 /* Match a common block name.  */
4293
4294 match match_common_name (char *name)
4295 {
4296   match m;
4297
4298   if (gfc_match_char ('/') == MATCH_NO)
4299     {
4300       name[0] = '\0';
4301       return MATCH_YES;
4302     }
4303
4304   if (gfc_match_char ('/') == MATCH_YES)
4305     {
4306       name[0] = '\0';
4307       return MATCH_YES;
4308     }
4309
4310   m = gfc_match_name (name);
4311
4312   if (m == MATCH_ERROR)
4313     return MATCH_ERROR;
4314   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
4315     return MATCH_YES;
4316
4317   gfc_error ("Syntax error in common block name at %C");
4318   return MATCH_ERROR;
4319 }
4320
4321
4322 /* Match a COMMON statement.  */
4323
4324 match
4325 gfc_match_common (void)
4326 {
4327   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
4328   char name[GFC_MAX_SYMBOL_LEN + 1];
4329   gfc_common_head *t;
4330   gfc_array_spec *as;
4331   gfc_equiv *e1, *e2;
4332   match m;
4333   gfc_gsymbol *gsym;
4334
4335   old_blank_common = gfc_current_ns->blank_common.head;
4336   if (old_blank_common)
4337     {
4338       while (old_blank_common->common_next)
4339         old_blank_common = old_blank_common->common_next;
4340     }
4341
4342   as = NULL;
4343
4344   for (;;)
4345     {
4346       m = match_common_name (name);
4347       if (m == MATCH_ERROR)
4348         goto cleanup;
4349
4350       gsym = gfc_get_gsymbol (name);
4351       if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
4352         {
4353           gfc_error ("Symbol '%s' at %C is already an external symbol that "
4354                      "is not COMMON", name);
4355           goto cleanup;
4356         }
4357
4358       if (gsym->type == GSYM_UNKNOWN)
4359         {
4360           gsym->type = GSYM_COMMON;
4361           gsym->where = gfc_current_locus;
4362           gsym->defined = 1;
4363         }
4364
4365       gsym->used = 1;
4366
4367       if (name[0] == '\0')
4368         {
4369           t = &gfc_current_ns->blank_common;
4370           if (t->head == NULL)
4371             t->where = gfc_current_locus;
4372         }
4373       else
4374         {
4375           t = gfc_get_common (name, 0);
4376         }
4377       head = &t->head;
4378
4379       if (*head == NULL)
4380         tail = NULL;
4381       else
4382         {
4383           tail = *head;
4384           while (tail->common_next)
4385             tail = tail->common_next;
4386         }
4387
4388       /* Grab the list of symbols.  */
4389       for (;;)
4390         {
4391           m = gfc_match_symbol (&sym, 0);
4392           if (m == MATCH_ERROR)
4393             goto cleanup;
4394           if (m == MATCH_NO)
4395             goto syntax;
4396
4397           /* Store a ref to the common block for error checking.  */
4398           sym->common_block = t;
4399
4400           /* See if we know the current common block is bind(c), and if
4401              so, then see if we can check if the symbol is (which it'll
4402              need to be).  This can happen if the bind(c) attr stmt was
4403              applied to the common block, and the variable(s) already
4404              defined, before declaring the common block.  */
4405           if (t->is_bind_c == 1)
4406             {
4407               if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
4408                 {
4409                   /* If we find an error, just print it and continue,
4410                      cause it's just semantic, and we can see if there
4411                      are more errors.  */
4412                   gfc_error_now ("Variable '%s' at %L in common block '%s' "
4413                                  "at %C must be declared with a C "
4414                                  "interoperable kind since common block "
4415                                  "'%s' is bind(c)",
4416                                  sym->name, &(sym->declared_at), t->name,
4417                                  t->name);
4418                 }
4419
4420               if (sym->attr.is_bind_c == 1)
4421                 gfc_error_now ("Variable '%s' in common block "
4422                                "'%s' at %C can not be bind(c) since "
4423                                "it is not global", sym->name, t->name);
4424             }
4425
4426           if (sym->attr.in_common)
4427             {
4428               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
4429                          sym->name);
4430               goto cleanup;
4431             }
4432
4433           if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
4434                || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
4435             {
4436               if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
4437                                                "can only be COMMON in "
4438                                                "BLOCK DATA", sym->name)
4439                   == FAILURE)
4440                 goto cleanup;
4441             }
4442
4443           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
4444             goto cleanup;
4445
4446           if (tail != NULL)
4447             tail->common_next = sym;
4448           else
4449             *head = sym;
4450
4451           tail = sym;
4452
4453           /* Deal with an optional array specification after the
4454              symbol name.  */
4455           m = gfc_match_array_spec (&as, true, true);
4456           if (m == MATCH_ERROR)
4457             goto cleanup;
4458
4459           if (m == MATCH_YES)
4460             {
4461               if (as->type != AS_EXPLICIT)
4462                 {
4463                   gfc_error ("Array specification for symbol '%s' in COMMON "
4464                              "at %C must be explicit", sym->name);
4465                   goto cleanup;
4466                 }
4467
4468               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
4469                 goto cleanup;
4470
4471               if (sym->attr.pointer)
4472                 {
4473                   gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
4474                              "POINTER array", sym->name);
4475                   goto cleanup;
4476                 }
4477
4478               sym->as = as;
4479               as = NULL;
4480
4481             }
4482
4483           sym->common_head = t;
4484
4485           /* Check to see if the symbol is already in an equivalence group.
4486              If it is, set the other members as being in common.  */
4487           if (sym->attr.in_equivalence)
4488             {
4489               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
4490                 {
4491                   for (e2 = e1; e2; e2 = e2->eq)
4492                     if (e2->expr->symtree->n.sym == sym)
4493                       goto equiv_found;
4494
4495                   continue;
4496
4497           equiv_found:
4498
4499                   for (e2 = e1; e2; e2 = e2->eq)
4500                     {
4501                       other = e2->expr->symtree->n.sym;
4502                       if (other->common_head
4503                           && other->common_head != sym->common_head)
4504                         {
4505                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
4506                                      "%C is being indirectly equivalenced to "
4507                                      "another COMMON block '%s'",
4508                                      sym->name, sym->common_head->name,
4509                                      other->common_head->name);
4510                             goto cleanup;
4511                         }
4512                       other->attr.in_common = 1;
4513                       other->common_head = t;
4514                     }
4515                 }
4516             }
4517
4518
4519           gfc_gobble_whitespace ();
4520           if (gfc_match_eos () == MATCH_YES)
4521             goto done;
4522           if (gfc_peek_ascii_char () == '/')
4523             break;
4524           if (gfc_match_char (',') != MATCH_YES)
4525             goto syntax;
4526           gfc_gobble_whitespace ();
4527           if (gfc_peek_ascii_char () == '/')
4528             break;
4529         }
4530     }
4531
4532 done:
4533   return MATCH_YES;
4534
4535 syntax:
4536   gfc_syntax_error (ST_COMMON);
4537
4538 cleanup:
4539   if (old_blank_common)
4540     old_blank_common->common_next = NULL;
4541   else
4542     gfc_current_ns->blank_common.head = NULL;
4543   gfc_free_array_spec (as);
4544   return MATCH_ERROR;
4545 }
4546
4547
4548 /* Match a BLOCK DATA program unit.  */
4549
4550 match
4551 gfc_match_block_data (void)
4552 {
4553   char name[GFC_MAX_SYMBOL_LEN + 1];
4554   gfc_symbol *sym;
4555   match m;
4556
4557   if (gfc_match_eos () == MATCH_YES)
4558     {
4559       gfc_new_block = NULL;
4560       return MATCH_YES;
4561     }
4562
4563   m = gfc_match ("% %n%t", name);
4564   if (m != MATCH_YES)
4565     return MATCH_ERROR;
4566
4567   if (gfc_get_symbol (name, NULL, &sym))
4568     return MATCH_ERROR;
4569
4570   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
4571     return MATCH_ERROR;
4572
4573   gfc_new_block = sym;
4574
4575   return MATCH_YES;
4576 }
4577
4578
4579 /* Free a namelist structure.  */
4580
4581 void
4582 gfc_free_namelist (gfc_namelist *name)
4583 {
4584   gfc_namelist *n;
4585
4586   for (; name; name = n)
4587     {
4588       n = name->next;
4589       free (name);
4590     }
4591 }
4592
4593
4594 /* Match a NAMELIST statement.  */
4595
4596 match
4597 gfc_match_namelist (void)
4598 {
4599   gfc_symbol *group_name, *sym;
4600   gfc_namelist *nl;
4601   match m, m2;
4602
4603   m = gfc_match (" / %s /", &group_name);
4604   if (m == MATCH_NO)
4605     goto syntax;
4606   if (m == MATCH_ERROR)
4607     goto error;
4608
4609   for (;;)
4610     {
4611       if (group_name->ts.type != BT_UNKNOWN)
4612         {
4613           gfc_error ("Namelist group name '%s' at %C already has a basic "
4614                      "type of %s", group_name->name,
4615                      gfc_typename (&group_name->ts));
4616           return MATCH_ERROR;
4617         }
4618
4619       if (group_name->attr.flavor == FL_NAMELIST
4620           && group_name->attr.use_assoc
4621           && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
4622                              "at %C already is USE associated and can"
4623                              "not be respecified.", group_name->name)
4624              == FAILURE)
4625         return MATCH_ERROR;
4626
4627       if (group_name->attr.flavor != FL_NAMELIST
4628           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
4629                              group_name->name, NULL) == FAILURE)
4630         return MATCH_ERROR;
4631
4632       for (;;)
4633         {
4634           m = gfc_match_symbol (&sym, 1);
4635           if (m == MATCH_NO)
4636             goto syntax;
4637           if (m == MATCH_ERROR)
4638             goto error;
4639
4640           if (sym->attr.in_namelist == 0
4641               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
4642             goto error;
4643
4644           /* Use gfc_error_check here, rather than goto error, so that
4645              these are the only errors for the next two lines.  */
4646           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
4647             {
4648               gfc_error ("Assumed size array '%s' in namelist '%s' at "
4649                          "%C is not allowed", sym->name, group_name->name);
4650               gfc_error_check ();
4651             }
4652
4653           nl = gfc_get_namelist ();
4654           nl->sym = sym;
4655           sym->refs++;
4656
4657           if (group_name->namelist == NULL)
4658             group_name->namelist = group_name->namelist_tail = nl;
4659           else
4660             {
4661               group_name->namelist_tail->next = nl;
4662               group_name->namelist_tail = nl;
4663             }
4664
4665           if (gfc_match_eos () == MATCH_YES)
4666             goto done;
4667
4668           m = gfc_match_char (',');
4669
4670           if (gfc_match_char ('/') == MATCH_YES)
4671             {
4672               m2 = gfc_match (" %s /", &group_name);
4673               if (m2 == MATCH_YES)
4674                 break;
4675               if (m2 == MATCH_ERROR)
4676                 goto error;
4677               goto syntax;
4678             }
4679
4680           if (m != MATCH_YES)
4681             goto syntax;
4682         }
4683     }
4684
4685 done:
4686   return MATCH_YES;
4687
4688 syntax:
4689   gfc_syntax_error (ST_NAMELIST);
4690
4691 error:
4692   return MATCH_ERROR;
4693 }
4694
4695
4696 /* Match a MODULE statement.  */
4697
4698 match
4699 gfc_match_module (void)
4700 {
4701   match m;
4702
4703   m = gfc_match (" %s%t", &gfc_new_block);
4704   if (m != MATCH_YES)
4705     return m;
4706
4707   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
4708                       gfc_new_block->name, NULL) == FAILURE)
4709     return MATCH_ERROR;
4710
4711   return MATCH_YES;
4712 }
4713
4714
4715 /* Free equivalence sets and lists.  Recursively is the easiest way to
4716    do this.  */
4717
4718 void
4719 gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
4720 {
4721   if (eq == stop)
4722     return;
4723
4724   gfc_free_equiv (eq->eq);
4725   gfc_free_equiv_until (eq->next, stop);
4726   gfc_free_expr (eq->expr);
4727   free (eq);
4728 }
4729
4730
4731 void
4732 gfc_free_equiv (gfc_equiv *eq)
4733 {
4734   gfc_free_equiv_until (eq, NULL);
4735 }
4736
4737
4738 /* Match an EQUIVALENCE statement.  */
4739
4740 match
4741 gfc_match_equivalence (void)
4742 {
4743   gfc_equiv *eq, *set, *tail;
4744   gfc_ref *ref;
4745   gfc_symbol *sym;
4746   match m;
4747   gfc_common_head *common_head = NULL;
4748   bool common_flag;
4749   int cnt;
4750
4751   tail = NULL;
4752
4753   for (;;)
4754     {
4755       eq = gfc_get_equiv ();
4756       if (tail == NULL)
4757         tail = eq;
4758
4759       eq->next = gfc_current_ns->equiv;
4760       gfc_current_ns->equiv = eq;
4761
4762       if (gfc_match_char ('(') != MATCH_YES)
4763         goto syntax;
4764
4765       set = eq;
4766       common_flag = FALSE;
4767       cnt = 0;
4768
4769       for (;;)
4770         {
4771           m = gfc_match_equiv_variable (&set->expr);
4772           if (m == MATCH_ERROR)
4773             goto cleanup;
4774           if (m == MATCH_NO)
4775             goto syntax;
4776
4777           /*  count the number of objects.  */
4778           cnt++;
4779
4780           if (gfc_match_char ('%') == MATCH_YES)
4781             {
4782               gfc_error ("Derived type component %C is not a "
4783                          "permitted EQUIVALENCE member");
4784               goto cleanup;
4785             }
4786
4787           for (ref = set->expr->ref; ref; ref = ref->next)
4788             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
4789               {
4790                 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4791                            "be an array section");
4792                 goto cleanup;
4793               }
4794
4795           sym = set->expr->symtree->n.sym;
4796
4797           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
4798             goto cleanup;
4799
4800           if (sym->attr.in_common)
4801             {
4802               common_flag = TRUE;
4803               common_head = sym->common_head;
4804             }
4805
4806           if (gfc_match_char (')') == MATCH_YES)
4807             break;
4808
4809           if (gfc_match_char (',') != MATCH_YES)
4810             goto syntax;
4811
4812           set->eq = gfc_get_equiv ();
4813           set = set->eq;
4814         }
4815
4816       if (cnt < 2)
4817         {
4818           gfc_error ("EQUIVALENCE at %C requires two or more objects");
4819           goto cleanup;
4820         }
4821
4822       /* If one of the members of an equivalence is in common, then
4823          mark them all as being in common.  Before doing this, check
4824          that members of the equivalence group are not in different
4825          common blocks.  */
4826       if (common_flag)
4827         for (set = eq; set; set = set->eq)
4828           {
4829             sym = set->expr->symtree->n.sym;
4830             if (sym->common_head && sym->common_head != common_head)
4831               {
4832                 gfc_error ("Attempt to indirectly overlap COMMON "
4833                            "blocks %s and %s by EQUIVALENCE at %C",
4834                            sym->common_head->name, common_head->name);
4835                 goto cleanup;
4836               }
4837             sym->attr.in_common = 1;
4838             sym->common_head = common_head;
4839           }
4840
4841       if (gfc_match_eos () == MATCH_YES)
4842         break;
4843       if (gfc_match_char (',') != MATCH_YES)
4844         {
4845           gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4846           goto cleanup;
4847         }
4848     }
4849
4850   return MATCH_YES;
4851
4852 syntax:
4853   gfc_syntax_error (ST_EQUIVALENCE);
4854
4855 cleanup:
4856   eq = tail->next;
4857   tail->next = NULL;
4858
4859   gfc_free_equiv (gfc_current_ns->equiv);
4860   gfc_current_ns->equiv = eq;
4861
4862   return MATCH_ERROR;
4863 }
4864
4865
4866 /* Check that a statement function is not recursive. This is done by looking
4867    for the statement function symbol(sym) by looking recursively through its
4868    expression(e).  If a reference to sym is found, true is returned.
4869    12.5.4 requires that any variable of function that is implicitly typed
4870    shall have that type confirmed by any subsequent type declaration.  The
4871    implicit typing is conveniently done here.  */
4872 static bool
4873 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
4874
4875 static bool
4876 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
4877 {
4878
4879   if (e == NULL)
4880     return false;
4881
4882   switch (e->expr_type)
4883     {
4884     case EXPR_FUNCTION:
4885       if (e->symtree == NULL)
4886         return false;
4887
4888       /* Check the name before testing for nested recursion!  */
4889       if (sym->name == e->symtree->n.sym->name)
4890         return true;
4891
4892       /* Catch recursion via other statement functions.  */
4893       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
4894           && e->symtree->n.sym->value
4895           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
4896         return true;
4897
4898       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4899         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4900
4901       break;
4902
4903     case EXPR_VARIABLE:
4904       if (e->symtree && sym->name == e->symtree->n.sym->name)
4905         return true;
4906
4907       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4908         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4909       break;
4910
4911     default:
4912       break;
4913     }
4914
4915   return false;
4916 }
4917
4918
4919 static bool
4920 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
4921 {
4922   return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
4923 }
4924
4925
4926 /* Match a statement function declaration.  It is so easy to match
4927    non-statement function statements with a MATCH_ERROR as opposed to
4928    MATCH_NO that we suppress error message in most cases.  */
4929
4930 match
4931 gfc_match_st_function (void)
4932 {
4933   gfc_error_buf old_error;
4934   gfc_symbol *sym;
4935   gfc_expr *expr;
4936   match m;
4937
4938   m = gfc_match_symbol (&sym, 0);
4939   if (m != MATCH_YES)
4940     return m;
4941
4942   gfc_push_error (&old_error);
4943
4944   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
4945                          sym->name, NULL) == FAILURE)
4946     goto undo_error;
4947
4948   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
4949     goto undo_error;
4950
4951   m = gfc_match (" = %e%t", &expr);
4952   if (m == MATCH_NO)
4953     goto undo_error;
4954
4955   gfc_free_error (&old_error);
4956   if (m == MATCH_ERROR)
4957     return m;
4958
4959   if (recursive_stmt_fcn (expr, sym))
4960     {
4961       gfc_error ("Statement function at %L is recursive", &expr->where);
4962       return MATCH_ERROR;
4963     }
4964
4965   sym->value = expr;
4966
4967   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
4968                       "Statement function at %C") == FAILURE)
4969     return MATCH_ERROR;
4970
4971   return MATCH_YES;
4972
4973 undo_error:
4974   gfc_pop_error (&old_error);
4975   return MATCH_NO;
4976 }
4977
4978
4979 /***************** SELECT CASE subroutines ******************/
4980
4981 /* Free a single case structure.  */
4982
4983 static void
4984 free_case (gfc_case *p)
4985 {
4986   if (p->low == p->high)
4987     p->high = NULL;
4988   gfc_free_expr (p->low);
4989   gfc_free_expr (p->high);
4990   free (p);
4991 }
4992
4993
4994 /* Free a list of case structures.  */
4995
4996 void
4997 gfc_free_case_list (gfc_case *p)
4998 {
4999   gfc_case *q;
5000
5001   for (; p; p = q)
5002     {
5003       q = p->next;
5004       free_case (p);
5005     }
5006 }
5007
5008
5009 /* Match a single case selector.  */
5010
5011 static match
5012 match_case_selector (gfc_case **cp)
5013 {
5014   gfc_case *c;
5015   match m;
5016
5017   c = gfc_get_case ();
5018   c->where = gfc_current_locus;
5019
5020   if (gfc_match_char (':') == MATCH_YES)
5021     {
5022       m = gfc_match_init_expr (&c->high);
5023       if (m == MATCH_NO)
5024         goto need_expr;
5025       if (m == MATCH_ERROR)
5026         goto cleanup;
5027     }
5028   else
5029     {
5030       m = gfc_match_init_expr (&c->low);
5031       if (m == MATCH_ERROR)
5032         goto cleanup;
5033       if (m == MATCH_NO)
5034         goto need_expr;
5035
5036       /* If we're not looking at a ':' now, make a range out of a single
5037          target.  Else get the upper bound for the case range.  */
5038       if (gfc_match_char (':') != MATCH_YES)
5039         c->high = c->low;
5040       else
5041         {
5042           m = gfc_match_init_expr (&c->high);
5043           if (m == MATCH_ERROR)
5044             goto cleanup;
5045           /* MATCH_NO is fine.  It's OK if nothing is there!  */
5046         }
5047     }
5048
5049   *cp = c;
5050   return MATCH_YES;
5051
5052 need_expr:
5053   gfc_error ("Expected initialization expression in CASE at %C");
5054
5055 cleanup:
5056   free_case (c);
5057   return MATCH_ERROR;
5058 }
5059
5060
5061 /* Match the end of a case statement.  */
5062
5063 static match
5064 match_case_eos (void)
5065 {
5066   char name[GFC_MAX_SYMBOL_LEN + 1];
5067   match m;
5068
5069   if (gfc_match_eos () == MATCH_YES)
5070     return MATCH_YES;
5071
5072   /* If the case construct doesn't have a case-construct-name, we
5073      should have matched the EOS.  */
5074   if (!gfc_current_block ())
5075     return MATCH_NO;
5076
5077   gfc_gobble_whitespace ();
5078
5079   m = gfc_match_name (name);
5080   if (m != MATCH_YES)
5081     return m;
5082
5083   if (strcmp (name, gfc_current_block ()->name) != 0)
5084     {
5085       gfc_error ("Expected block name '%s' of SELECT construct at %C",
5086                  gfc_current_block ()->name);
5087       return MATCH_ERROR;
5088     }
5089
5090   return gfc_match_eos ();
5091 }
5092
5093
5094 /* Match a SELECT statement.  */
5095
5096 match
5097 gfc_match_select (void)
5098 {
5099   gfc_expr *expr;
5100   match m;
5101
5102   m = gfc_match_label ();
5103   if (m == MATCH_ERROR)
5104     return m;
5105
5106   m = gfc_match (" select case ( %e )%t", &expr);
5107   if (m != MATCH_YES)
5108     return m;
5109
5110   new_st.op = EXEC_SELECT;
5111   new_st.expr1 = expr;
5112
5113   return MATCH_YES;
5114 }
5115
5116
5117 /* Push the current selector onto the SELECT TYPE stack.  */
5118
5119 static void
5120 select_type_push (gfc_symbol *sel)
5121 {
5122   gfc_select_type_stack *top = gfc_get_select_type_stack ();
5123   top->selector = sel;
5124   top->tmp = NULL;
5125   top->prev = select_type_stack;
5126
5127   select_type_stack = top;
5128 }
5129
5130
5131 /* Set the temporary for the current SELECT TYPE selector.  */
5132
5133 static void
5134 select_type_set_tmp (gfc_typespec *ts)
5135 {
5136   char name[GFC_MAX_SYMBOL_LEN];
5137   gfc_symtree *tmp;
5138
5139   if (!ts)
5140     {
5141       select_type_stack->tmp = NULL;
5142       return;
5143     }
5144
5145   if (!gfc_type_is_extensible (ts->u.derived))
5146     return;
5147
5148   if (ts->type == BT_CLASS)
5149     sprintf (name, "__tmp_class_%s", ts->u.derived->name);
5150   else
5151     sprintf (name, "__tmp_type_%s", ts->u.derived->name);
5152   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
5153   gfc_add_type (tmp->n.sym, ts, NULL);
5154   gfc_set_sym_referenced (tmp->n.sym);
5155   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
5156   tmp->n.sym->attr.select_type_temporary = 1;
5157   if (ts->type == BT_CLASS)
5158     gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
5159                             &tmp->n.sym->as, false);
5160
5161   /* Add an association for it, so the rest of the parser knows it is
5162      an associate-name.  The target will be set during resolution.  */
5163   tmp->n.sym->assoc = gfc_get_association_list ();
5164   tmp->n.sym->assoc->dangling = 1;
5165   tmp->n.sym->assoc->st = tmp;
5166
5167   select_type_stack->tmp = tmp;
5168 }
5169
5170
5171 /* Match a SELECT TYPE statement.  */
5172
5173 match
5174 gfc_match_select_type (void)
5175 {
5176   gfc_expr *expr1, *expr2 = NULL;
5177   match m;
5178   char name[GFC_MAX_SYMBOL_LEN];
5179
5180   m = gfc_match_label ();
5181   if (m == MATCH_ERROR)
5182     return m;
5183
5184   m = gfc_match (" select type ( ");
5185   if (m != MATCH_YES)
5186     return m;
5187
5188   gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
5189
5190   m = gfc_match (" %n => %e", name, &expr2);
5191   if (m == MATCH_YES)
5192     {
5193       expr1 = gfc_get_expr();
5194       expr1->expr_type = EXPR_VARIABLE;
5195       if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
5196         {
5197           m = MATCH_ERROR;
5198           goto cleanup;
5199         }
5200       if (expr2->ts.type == BT_UNKNOWN)
5201         expr1->symtree->n.sym->attr.untyped = 1;
5202       else
5203         expr1->symtree->n.sym->ts = expr2->ts;
5204       expr1->symtree->n.sym->attr.flavor = FL_VARIABLE;
5205       expr1->symtree->n.sym->attr.referenced = 1;
5206       expr1->symtree->n.sym->attr.class_ok = 1;
5207     }
5208   else
5209     {
5210       m = gfc_match (" %e ", &expr1);
5211       if (m != MATCH_YES)
5212         goto cleanup;
5213     }
5214
5215   m = gfc_match (" )%t");
5216   if (m != MATCH_YES)
5217     goto cleanup;
5218
5219   /* Check for F03:C811.  */
5220   if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
5221     {
5222       gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
5223                  "use associate-name=>");
5224       m = MATCH_ERROR;
5225       goto cleanup;
5226     }
5227
5228   new_st.op = EXEC_SELECT_TYPE;
5229   new_st.expr1 = expr1;
5230   new_st.expr2 = expr2;
5231   new_st.ext.block.ns = gfc_current_ns;
5232
5233   select_type_push (expr1->symtree->n.sym);
5234
5235   return MATCH_YES;
5236
5237 cleanup:
5238   gfc_current_ns = gfc_current_ns->parent;
5239   return m;
5240 }
5241
5242
5243 /* Match a CASE statement.  */
5244
5245 match
5246 gfc_match_case (void)
5247 {
5248   gfc_case *c, *head, *tail;
5249   match m;
5250
5251   head = tail = NULL;
5252
5253   if (gfc_current_state () != COMP_SELECT)
5254     {
5255       gfc_error ("Unexpected CASE statement at %C");
5256       return MATCH_ERROR;
5257     }
5258
5259   if (gfc_match ("% default") == MATCH_YES)
5260     {
5261       m = match_case_eos ();
5262       if (m == MATCH_NO)
5263         goto syntax;
5264       if (m == MATCH_ERROR)
5265         goto cleanup;
5266
5267       new_st.op = EXEC_SELECT;
5268       c = gfc_get_case ();
5269       c->where = gfc_current_locus;
5270       new_st.ext.block.case_list = c;
5271       return MATCH_YES;
5272     }
5273
5274   if (gfc_match_char ('(') != MATCH_YES)
5275     goto syntax;
5276
5277   for (;;)
5278     {
5279       if (match_case_selector (&c) == MATCH_ERROR)
5280         goto cleanup;
5281
5282       if (head == NULL)
5283         head = c;
5284       else
5285         tail->next = c;
5286
5287       tail = c;
5288
5289       if (gfc_match_char (')') == MATCH_YES)
5290         break;
5291       if (gfc_match_char (',') != MATCH_YES)
5292         goto syntax;
5293     }
5294
5295   m = match_case_eos ();
5296   if (m == MATCH_NO)
5297     goto syntax;
5298   if (m == MATCH_ERROR)
5299     goto cleanup;
5300
5301   new_st.op = EXEC_SELECT;
5302   new_st.ext.block.case_list = head;
5303
5304   return MATCH_YES;
5305
5306 syntax:
5307   gfc_error ("Syntax error in CASE specification at %C");
5308
5309 cleanup:
5310   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
5311   return MATCH_ERROR;
5312 }
5313
5314
5315 /* Match a TYPE IS statement.  */
5316
5317 match
5318 gfc_match_type_is (void)
5319 {
5320   gfc_case *c = NULL;
5321   match m;
5322
5323   if (gfc_current_state () != COMP_SELECT_TYPE)
5324     {
5325       gfc_error ("Unexpected TYPE IS statement at %C");
5326       return MATCH_ERROR;
5327     }
5328
5329   if (gfc_match_char ('(') != MATCH_YES)
5330     goto syntax;
5331
5332   c = gfc_get_case ();
5333   c->where = gfc_current_locus;
5334
5335   /* TODO: Once unlimited polymorphism is implemented, we will need to call
5336      match_type_spec here.  */
5337   if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
5338     goto cleanup;
5339
5340   if (gfc_match_char (')') != MATCH_YES)
5341     goto syntax;
5342
5343   m = match_case_eos ();
5344   if (m == MATCH_NO)
5345     goto syntax;
5346   if (m == MATCH_ERROR)
5347     goto cleanup;
5348
5349   new_st.op = EXEC_SELECT_TYPE;
5350   new_st.ext.block.case_list = c;
5351
5352   /* Create temporary variable.  */
5353   select_type_set_tmp (&c->ts);
5354
5355   return MATCH_YES;
5356
5357 syntax:
5358   gfc_error ("Syntax error in TYPE IS specification at %C");
5359
5360 cleanup:
5361   if (c != NULL)
5362     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
5363   return MATCH_ERROR;
5364 }
5365
5366
5367 /* Match a CLASS IS or CLASS DEFAULT statement.  */
5368
5369 match
5370 gfc_match_class_is (void)
5371 {
5372   gfc_case *c = NULL;
5373   match m;
5374
5375   if (gfc_current_state () != COMP_SELECT_TYPE)
5376     return MATCH_NO;
5377
5378   if (gfc_match ("% default") == MATCH_YES)
5379     {
5380       m = match_case_eos ();
5381       if (m == MATCH_NO)
5382         goto syntax;
5383       if (m == MATCH_ERROR)
5384         goto cleanup;
5385
5386       new_st.op = EXEC_SELECT_TYPE;
5387       c = gfc_get_case ();
5388       c->where = gfc_current_locus;
5389       c->ts.type = BT_UNKNOWN;
5390       new_st.ext.block.case_list = c;
5391       select_type_set_tmp (NULL);
5392       return MATCH_YES;
5393     }
5394
5395   m = gfc_match ("% is");
5396   if (m == MATCH_NO)
5397     goto syntax;
5398   if (m == MATCH_ERROR)
5399     goto cleanup;
5400
5401   if (gfc_match_char ('(') != MATCH_YES)
5402     goto syntax;
5403
5404   c = gfc_get_case ();
5405   c->where = gfc_current_locus;
5406
5407   if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
5408     goto cleanup;
5409
5410   if (c->ts.type == BT_DERIVED)
5411     c->ts.type = BT_CLASS;
5412
5413   if (gfc_match_char (')') != MATCH_YES)
5414     goto syntax;
5415
5416   m = match_case_eos ();
5417   if (m == MATCH_NO)
5418     goto syntax;
5419   if (m == MATCH_ERROR)
5420     goto cleanup;
5421
5422   new_st.op = EXEC_SELECT_TYPE;
5423   new_st.ext.block.case_list = c;
5424
5425   /* Create temporary variable.  */
5426   select_type_set_tmp (&c->ts);
5427
5428   return MATCH_YES;
5429
5430 syntax:
5431   gfc_error ("Syntax error in CLASS IS specification at %C");
5432
5433 cleanup:
5434   if (c != NULL)
5435     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
5436   return MATCH_ERROR;
5437 }
5438
5439
5440 /********************* WHERE subroutines ********************/
5441
5442 /* Match the rest of a simple WHERE statement that follows an IF statement.
5443  */
5444
5445 static match
5446 match_simple_where (void)
5447 {
5448   gfc_expr *expr;
5449   gfc_code *c;
5450   match m;
5451
5452   m = gfc_match (" ( %e )", &expr);
5453   if (m != MATCH_YES)
5454     return m;
5455
5456   m = gfc_match_assignment ();
5457   if (m == MATCH_NO)
5458     goto syntax;
5459   if (m == MATCH_ERROR)
5460     goto cleanup;
5461
5462   if (gfc_match_eos () != MATCH_YES)
5463     goto syntax;
5464
5465   c = gfc_get_code ();
5466
5467   c->op = EXEC_WHERE;
5468   c->expr1 = expr;
5469   c->next = gfc_get_code ();
5470
5471   *c->next = new_st;
5472   gfc_clear_new_st ();
5473
5474   new_st.op = EXEC_WHERE;
5475   new_st.block = c;
5476
5477   return MATCH_YES;
5478
5479 syntax:
5480   gfc_syntax_error (ST_WHERE);
5481
5482 cleanup:
5483   gfc_free_expr (expr);
5484   return MATCH_ERROR;
5485 }
5486
5487
5488 /* Match a WHERE statement.  */
5489
5490 match
5491 gfc_match_where (gfc_statement *st)
5492 {
5493   gfc_expr *expr;
5494   match m0, m;
5495   gfc_code *c;
5496
5497   m0 = gfc_match_label ();
5498   if (m0 == MATCH_ERROR)
5499     return m0;
5500
5501   m = gfc_match (" where ( %e )", &expr);
5502   if (m != MATCH_YES)
5503     return m;
5504
5505   if (gfc_match_eos () == MATCH_YES)
5506     {
5507       *st = ST_WHERE_BLOCK;
5508       new_st.op = EXEC_WHERE;
5509       new_st.expr1 = expr;
5510       return MATCH_YES;
5511     }
5512
5513   m = gfc_match_assignment ();
5514   if (m == MATCH_NO)
5515     gfc_syntax_error (ST_WHERE);
5516
5517   if (m != MATCH_YES)
5518     {
5519       gfc_free_expr (expr);
5520       return MATCH_ERROR;
5521     }
5522
5523   /* We've got a simple WHERE statement.  */
5524   *st = ST_WHERE;
5525   c = gfc_get_code ();
5526
5527   c->op = EXEC_WHERE;
5528   c->expr1 = expr;
5529   c->next = gfc_get_code ();
5530
5531   *c->next = new_st;
5532   gfc_clear_new_st ();
5533
5534   new_st.op = EXEC_WHERE;
5535   new_st.block = c;
5536
5537   return MATCH_YES;
5538 }
5539
5540
5541 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
5542    new_st if successful.  */
5543
5544 match
5545 gfc_match_elsewhere (void)
5546 {
5547   char name[GFC_MAX_SYMBOL_LEN + 1];
5548   gfc_expr *expr;
5549   match m;
5550
5551   if (gfc_current_state () != COMP_WHERE)
5552     {
5553       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
5554       return MATCH_ERROR;
5555     }
5556
5557   expr = NULL;
5558
5559   if (gfc_match_char ('(') == MATCH_YES)
5560     {
5561       m = gfc_match_expr (&expr);
5562       if (m == MATCH_NO)
5563         goto syntax;
5564       if (m == MATCH_ERROR)
5565         return MATCH_ERROR;
5566
5567       if (gfc_match_char (')') != MATCH_YES)
5568         goto syntax;
5569     }
5570
5571   if (gfc_match_eos () != MATCH_YES)
5572     {
5573       /* Only makes sense if we have a where-construct-name.  */
5574       if (!gfc_current_block ())
5575         {
5576           m = MATCH_ERROR;
5577           goto cleanup;
5578         }
5579       /* Better be a name at this point.  */
5580       m = gfc_match_name (name);
5581       if (m == MATCH_NO)
5582         goto syntax;
5583       if (m == MATCH_ERROR)
5584         goto cleanup;
5585
5586       if (gfc_match_eos () != MATCH_YES)
5587         goto syntax;
5588
5589       if (strcmp (name, gfc_current_block ()->name) != 0)
5590         {
5591           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
5592                      name, gfc_current_block ()->name);
5593           goto cleanup;
5594         }
5595     }
5596
5597   new_st.op = EXEC_WHERE;
5598   new_st.expr1 = expr;
5599   return MATCH_YES;
5600
5601 syntax:
5602   gfc_syntax_error (ST_ELSEWHERE);
5603
5604 cleanup:
5605   gfc_free_expr (expr);
5606   return MATCH_ERROR;
5607 }