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