gcc/fortran/match.c

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