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 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_OMP_DO
2598           || o->head->op == EXEC_OMP_PARALLEL_DO))
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 !$OMP DO 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                      " !$OMP DO loop");
2618           return MATCH_ERROR;
2619         }
2620     }
2621
2622   /* Save the first statement in the construct - needed by the backend.  */
2623   new_st.ext.which_construct = p->construct;
2624
2625   new_st.op = op;
2626
2627   return MATCH_YES;
2628 }
2629
2630
2631 /* Match the EXIT statement.  */
2632
2633 match
2634 gfc_match_exit (void)
2635 {
2636   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
2637 }
2638
2639
2640 /* Match the CYCLE statement.  */
2641
2642 match
2643 gfc_match_cycle (void)
2644 {
2645   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
2646 }
2647
2648
2649 /* Match a number or character constant after an (ALL) STOP or PAUSE statement.  */
2650
2651 static match
2652 gfc_match_stopcode (gfc_statement st)
2653 {
2654   gfc_expr *e;
2655   match m;
2656
2657   e = NULL;
2658
2659   if (gfc_match_eos () != MATCH_YES)
2660     {
2661       m = gfc_match_init_expr (&e);
2662       if (m == MATCH_ERROR)
2663         goto cleanup;
2664       if (m == MATCH_NO)
2665         goto syntax;
2666
2667       if (gfc_match_eos () != MATCH_YES)
2668         goto syntax;
2669     }
2670
2671   if (gfc_pure (NULL))
2672     {
2673       gfc_error ("%s statement not allowed in PURE procedure at %C",
2674                  gfc_ascii_statement (st));
2675       goto cleanup;
2676     }
2677
2678   gfc_unset_implicit_pure (NULL);
2679
2680   if (st == ST_STOP && gfc_find_state (COMP_CRITICAL))
2681     {
2682       gfc_error ("Image control statement STOP at %C in CRITICAL block");
2683       goto cleanup;
2684     }
2685   if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT))
2686     {
2687       gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2688       goto cleanup;
2689     }
2690
2691   if (e != NULL)
2692     {
2693       if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
2694         {
2695           gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2696                      &e->where);
2697           goto cleanup;
2698         }
2699
2700       if (e->rank != 0)
2701         {
2702           gfc_error ("STOP code at %L must be scalar",
2703                      &e->where);
2704           goto cleanup;
2705         }
2706
2707       if (e->ts.type == BT_CHARACTER
2708           && e->ts.kind != gfc_default_character_kind)
2709         {
2710           gfc_error ("STOP code at %L must be default character KIND=%d",
2711                      &e->where, (int) gfc_default_character_kind);
2712           goto cleanup;
2713         }
2714
2715       if (e->ts.type == BT_INTEGER
2716           && e->ts.kind != gfc_default_integer_kind)
2717         {
2718           gfc_error ("STOP code at %L must be default integer KIND=%d",
2719                      &e->where, (int) gfc_default_integer_kind);
2720           goto cleanup;
2721         }
2722     }
2723
2724   switch (st)
2725     {
2726     case ST_STOP:
2727       new_st.op = EXEC_STOP;
2728       break;
2729     case ST_ERROR_STOP:
2730       new_st.op = EXEC_ERROR_STOP;
2731       break;
2732     case ST_PAUSE:
2733       new_st.op = EXEC_PAUSE;
2734       break;
2735     default:
2736       gcc_unreachable ();
2737     }
2738
2739   new_st.expr1 = e;
2740   new_st.ext.stop_code = -1;
2741
2742   return MATCH_YES;
2743
2744 syntax:
2745   gfc_syntax_error (st);
2746
2747 cleanup:
2748
2749   gfc_free_expr (e);
2750   return MATCH_ERROR;
2751 }
2752
2753
2754 /* Match the (deprecated) PAUSE statement.  */
2755
2756 match
2757 gfc_match_pause (void)
2758 {
2759   match m;
2760
2761   m = gfc_match_stopcode (ST_PAUSE);
2762   if (m == MATCH_YES)
2763     {
2764       if (!gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement at %C"))
2765         m = MATCH_ERROR;
2766     }
2767   return m;
2768 }
2769
2770
2771 /* Match the STOP statement.  */
2772
2773 match
2774 gfc_match_stop (void)
2775 {
2776   return gfc_match_stopcode (ST_STOP);
2777 }
2778
2779
2780 /* Match the ERROR STOP statement.  */
2781
2782 match
2783 gfc_match_error_stop (void)
2784 {
2785   if (!gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C"))
2786     return MATCH_ERROR;
2787
2788   return gfc_match_stopcode (ST_ERROR_STOP);
2789 }
2790
2791
2792 /* Match LOCK/UNLOCK statement. Syntax:
2793      LOCK ( lock-variable [ , lock-stat-list ] )
2794      UNLOCK ( lock-variable [ , sync-stat-list ] )
2795    where lock-stat is ACQUIRED_LOCK or sync-stat
2796    and sync-stat is STAT= or ERRMSG=.  */
2797
2798 static match
2799 lock_unlock_statement (gfc_statement st)
2800 {
2801   match m;
2802   gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg;
2803   bool saw_acq_lock, saw_stat, saw_errmsg;
2804
2805   tmp = lockvar = acq_lock = stat = errmsg = NULL;
2806   saw_acq_lock = saw_stat = saw_errmsg = false;
2807
2808   if (gfc_pure (NULL))
2809     {
2810       gfc_error ("Image control statement %s at %C in PURE procedure",
2811                  st == ST_LOCK ? "LOCK" : "UNLOCK");
2812       return MATCH_ERROR;
2813     }
2814
2815   gfc_unset_implicit_pure (NULL);
2816
2817   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
2818     {
2819        gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2820        return MATCH_ERROR;
2821     }
2822
2823   if (gfc_find_state (COMP_CRITICAL))
2824     {
2825       gfc_error ("Image control statement %s at %C in CRITICAL block",
2826                  st == ST_LOCK ? "LOCK" : "UNLOCK");
2827       return MATCH_ERROR;
2828     }
2829
2830   if (gfc_find_state (COMP_DO_CONCURRENT))
2831     {
2832       gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
2833                  st == ST_LOCK ? "LOCK" : "UNLOCK");
2834       return MATCH_ERROR;
2835     }
2836
2837   if (gfc_match_char ('(') != MATCH_YES)
2838     goto syntax;
2839
2840   if (gfc_match ("%e", &lockvar) != MATCH_YES)
2841     goto syntax;
2842   m = gfc_match_char (',');
2843   if (m == MATCH_ERROR)
2844     goto syntax;
2845   if (m == MATCH_NO)
2846     {
2847       m = gfc_match_char (')');
2848       if (m == MATCH_YES)
2849         goto done;
2850       goto syntax;
2851     }
2852
2853   for (;;)
2854     {
2855       m = gfc_match (" stat = %v", &tmp);
2856       if (m == MATCH_ERROR)
2857         goto syntax;
2858       if (m == MATCH_YES)
2859         {
2860           if (saw_stat)
2861             {
2862               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2863               goto cleanup;
2864             }
2865           stat = tmp;
2866           saw_stat = true;
2867
2868           m = gfc_match_char (',');
2869           if (m == MATCH_YES)
2870             continue;
2871
2872           tmp = NULL;
2873           break;
2874         }
2875
2876       m = gfc_match (" errmsg = %v", &tmp);
2877       if (m == MATCH_ERROR)
2878         goto syntax;
2879       if (m == MATCH_YES)
2880         {
2881           if (saw_errmsg)
2882             {
2883               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2884               goto cleanup;
2885             }
2886           errmsg = tmp;
2887           saw_errmsg = true;
2888
2889           m = gfc_match_char (',');
2890           if (m == MATCH_YES)
2891             continue;
2892
2893           tmp = NULL;
2894           break;
2895         }
2896
2897       m = gfc_match (" acquired_lock = %v", &tmp);
2898       if (m == MATCH_ERROR || st == ST_UNLOCK)
2899         goto syntax;
2900       if (m == MATCH_YES)
2901         {
2902           if (saw_acq_lock)
2903             {
2904               gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
2905                          &tmp->where);
2906               goto cleanup;
2907             }
2908           acq_lock = tmp;
2909           saw_acq_lock = true;
2910
2911           m = gfc_match_char (',');
2912           if (m == MATCH_YES)
2913             continue;
2914
2915           tmp = NULL;
2916           break;
2917         }
2918
2919       break;
2920     }
2921
2922   if (m == MATCH_ERROR)
2923     goto syntax;
2924
2925   if (gfc_match (" )%t") != MATCH_YES)
2926     goto syntax;
2927
2928 done:
2929   switch (st)
2930     {
2931     case ST_LOCK:
2932       new_st.op = EXEC_LOCK;
2933       break;
2934     case ST_UNLOCK:
2935       new_st.op = EXEC_UNLOCK;
2936       break;
2937     default:
2938       gcc_unreachable ();
2939     }
2940
2941   new_st.expr1 = lockvar;
2942   new_st.expr2 = stat;
2943   new_st.expr3 = errmsg;
2944   new_st.expr4 = acq_lock;
2945
2946   return MATCH_YES;
2947
2948 syntax:
2949   gfc_syntax_error (st);
2950
2951 cleanup:
2952   if (acq_lock != tmp)
2953     gfc_free_expr (acq_lock);
2954   if (errmsg != tmp)
2955     gfc_free_expr (errmsg);
2956   if (stat != tmp)
2957     gfc_free_expr (stat);
2958
2959   gfc_free_expr (tmp);
2960   gfc_free_expr (lockvar);
2961
2962   return MATCH_ERROR;
2963 }
2964
2965
2966 match
2967 gfc_match_lock (void)
2968 {
2969   if (!gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C"))
2970     return MATCH_ERROR;
2971
2972   return lock_unlock_statement (ST_LOCK);
2973 }
2974
2975
2976 match
2977 gfc_match_unlock (void)
2978 {
2979   if (!gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C"))
2980     return MATCH_ERROR;
2981
2982   return lock_unlock_statement (ST_UNLOCK);
2983 }
2984
2985
2986 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2987      SYNC ALL [(sync-stat-list)]
2988      SYNC MEMORY [(sync-stat-list)]
2989      SYNC IMAGES (image-set [, sync-stat-list] )
2990    with sync-stat is int-expr or *.  */
2991
2992 static match
2993 sync_statement (gfc_statement st)
2994 {
2995   match m;
2996   gfc_expr *tmp, *imageset, *stat, *errmsg;
2997   bool saw_stat, saw_errmsg;
2998
2999   tmp = imageset = stat = errmsg = NULL;
3000   saw_stat = saw_errmsg = false;
3001
3002   if (gfc_pure (NULL))
3003     {
3004       gfc_error ("Image control statement SYNC at %C in PURE procedure");
3005       return MATCH_ERROR;
3006     }
3007
3008   gfc_unset_implicit_pure (NULL);
3009
3010   if (!gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C"))
3011     return MATCH_ERROR;
3012
3013   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3014     {
3015        gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3016        return MATCH_ERROR;
3017     }
3018
3019   if (gfc_find_state (COMP_CRITICAL))
3020     {
3021       gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3022       return MATCH_ERROR;
3023     }
3024
3025   if (gfc_find_state (COMP_DO_CONCURRENT))
3026     {
3027       gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3028       return MATCH_ERROR;
3029     }
3030
3031   if (gfc_match_eos () == MATCH_YES)
3032     {
3033       if (st == ST_SYNC_IMAGES)
3034         goto syntax;
3035       goto done;
3036     }
3037
3038   if (gfc_match_char ('(') != MATCH_YES)
3039     goto syntax;
3040
3041   if (st == ST_SYNC_IMAGES)
3042     {
3043       /* Denote '*' as imageset == NULL.  */
3044       m = gfc_match_char ('*');
3045       if (m == MATCH_ERROR)
3046         goto syntax;
3047       if (m == MATCH_NO)
3048         {
3049           if (gfc_match ("%e", &imageset) != MATCH_YES)
3050             goto syntax;
3051         }
3052       m = gfc_match_char (',');
3053       if (m == MATCH_ERROR)
3054         goto syntax;
3055       if (m == MATCH_NO)
3056         {
3057           m = gfc_match_char (')');
3058           if (m == MATCH_YES)
3059             goto done;
3060           goto syntax;
3061         }
3062     }
3063
3064   for (;;)
3065     {
3066       m = gfc_match (" stat = %v", &tmp);
3067       if (m == MATCH_ERROR)
3068         goto syntax;
3069       if (m == MATCH_YES)
3070         {
3071           if (saw_stat)
3072             {
3073               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3074               goto cleanup;
3075             }
3076           stat = tmp;
3077           saw_stat = true;
3078
3079           if (gfc_match_char (',') == MATCH_YES)
3080             continue;
3081
3082           tmp = NULL;
3083           break;
3084         }
3085
3086       m = gfc_match (" errmsg = %v", &tmp);
3087       if (m == MATCH_ERROR)
3088         goto syntax;
3089       if (m == MATCH_YES)
3090         {
3091           if (saw_errmsg)
3092             {
3093               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3094               goto cleanup;
3095             }
3096           errmsg = tmp;
3097           saw_errmsg = true;
3098
3099           if (gfc_match_char (',') == MATCH_YES)
3100             continue;
3101
3102           tmp = NULL;
3103           break;
3104         }
3105
3106         break;
3107     }
3108
3109   if (gfc_match (" )%t") != MATCH_YES)
3110     goto syntax;
3111
3112 done:
3113   switch (st)
3114     {
3115     case ST_SYNC_ALL:
3116       new_st.op = EXEC_SYNC_ALL;
3117       break;
3118     case ST_SYNC_IMAGES:
3119       new_st.op = EXEC_SYNC_IMAGES;
3120       break;
3121     case ST_SYNC_MEMORY:
3122       new_st.op = EXEC_SYNC_MEMORY;
3123       break;
3124     default:
3125       gcc_unreachable ();
3126     }
3127
3128   new_st.expr1 = imageset;
3129   new_st.expr2 = stat;
3130   new_st.expr3 = errmsg;
3131
3132   return MATCH_YES;
3133
3134 syntax:
3135   gfc_syntax_error (st);
3136
3137 cleanup:
3138   if (stat != tmp)
3139     gfc_free_expr (stat);
3140   if (errmsg != tmp)
3141     gfc_free_expr (errmsg);
3142
3143   gfc_free_expr (tmp);
3144   gfc_free_expr (imageset);
3145
3146   return MATCH_ERROR;
3147 }
3148
3149
3150 /* Match SYNC ALL statement.  */
3151
3152 match
3153 gfc_match_sync_all (void)
3154 {
3155   return sync_statement (ST_SYNC_ALL);
3156 }
3157
3158
3159 /* Match SYNC IMAGES statement.  */
3160
3161 match
3162 gfc_match_sync_images (void)
3163 {
3164   return sync_statement (ST_SYNC_IMAGES);
3165 }
3166
3167
3168 /* Match SYNC MEMORY statement.  */
3169
3170 match
3171 gfc_match_sync_memory (void)
3172 {
3173   return sync_statement (ST_SYNC_MEMORY);
3174 }
3175
3176
3177 /* Match a CONTINUE statement.  */
3178
3179 match
3180 gfc_match_continue (void)
3181 {
3182   if (gfc_match_eos () != MATCH_YES)
3183     {
3184       gfc_syntax_error (ST_CONTINUE);
3185       return MATCH_ERROR;
3186     }
3187
3188   new_st.op = EXEC_CONTINUE;
3189   return MATCH_YES;
3190 }
3191
3192
3193 /* Match the (deprecated) ASSIGN statement.  */
3194
3195 match
3196 gfc_match_assign (void)
3197 {
3198   gfc_expr *expr;
3199   gfc_st_label *label;
3200
3201   if (gfc_match (" %l", &label) == MATCH_YES)
3202     {
3203       if (!gfc_reference_st_label (label, ST_LABEL_UNKNOWN))
3204         return MATCH_ERROR;
3205       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
3206         {
3207           if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN statement at %C"))
3208             return MATCH_ERROR;
3209
3210           expr->symtree->n.sym->attr.assign = 1;
3211
3212           new_st.op = EXEC_LABEL_ASSIGN;
3213           new_st.label1 = label;
3214           new_st.expr1 = expr;
3215           return MATCH_YES;
3216         }
3217     }
3218   return MATCH_NO;
3219 }
3220
3221
3222 /* Match the GO TO statement.  As a computed GOTO statement is
3223    matched, it is transformed into an equivalent SELECT block.  No
3224    tree is necessary, and the resulting jumps-to-jumps are
3225    specifically optimized away by the back end.  */
3226
3227 match
3228 gfc_match_goto (void)
3229 {
3230   gfc_code *head, *tail;
3231   gfc_expr *expr;
3232   gfc_case *cp;
3233   gfc_st_label *label;
3234   int i;
3235   match m;
3236
3237   if (gfc_match (" %l%t", &label) == MATCH_YES)
3238     {
3239       if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
3240         return MATCH_ERROR;
3241
3242       new_st.op = EXEC_GOTO;
3243       new_st.label1 = label;
3244       return MATCH_YES;
3245     }
3246
3247   /* The assigned GO TO statement.  */
3248
3249   if (gfc_match_variable (&expr, 0) == MATCH_YES)
3250     {
3251       if (!gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO statement at %C"))
3252         return MATCH_ERROR;
3253
3254       new_st.op = EXEC_GOTO;
3255       new_st.expr1 = expr;
3256
3257       if (gfc_match_eos () == MATCH_YES)
3258         return MATCH_YES;
3259
3260       /* Match label list.  */
3261       gfc_match_char (',');
3262       if (gfc_match_char ('(') != MATCH_YES)
3263         {
3264           gfc_syntax_error (ST_GOTO);
3265           return MATCH_ERROR;
3266         }
3267       head = tail = NULL;
3268
3269       do
3270         {
3271           m = gfc_match_st_label (&label);
3272           if (m != MATCH_YES)
3273             goto syntax;
3274
3275           if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
3276             goto cleanup;
3277
3278           if (head == NULL)
3279             head = tail = gfc_get_code (EXEC_GOTO);
3280           else
3281             {
3282               tail->block = gfc_get_code (EXEC_GOTO);
3283               tail = tail->block;
3284             }
3285
3286           tail->label1 = label;
3287         }
3288       while (gfc_match_char (',') == MATCH_YES);
3289
3290       if (gfc_match (")%t") != MATCH_YES)
3291         goto syntax;
3292
3293       if (head == NULL)
3294         {
3295            gfc_error ("Statement label list in GOTO at %C cannot be empty");
3296            goto syntax;
3297         }
3298       new_st.block = head;
3299
3300       return MATCH_YES;
3301     }
3302
3303   /* Last chance is a computed GO TO statement.  */
3304   if (gfc_match_char ('(') != MATCH_YES)
3305     {
3306       gfc_syntax_error (ST_GOTO);
3307       return MATCH_ERROR;
3308     }
3309
3310   head = tail = NULL;
3311   i = 1;
3312
3313   do
3314     {
3315       m = gfc_match_st_label (&label);
3316       if (m != MATCH_YES)
3317         goto syntax;
3318
3319       if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
3320         goto cleanup;
3321
3322       if (head == NULL)
3323         head = tail = gfc_get_code (EXEC_SELECT);
3324       else
3325         {
3326           tail->block = gfc_get_code (EXEC_SELECT);
3327           tail = tail->block;
3328         }
3329
3330       cp = gfc_get_case ();
3331       cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
3332                                              NULL, i++);
3333
3334       tail->ext.block.case_list = cp;
3335
3336       tail->next = gfc_get_code (EXEC_GOTO);
3337       tail->next->label1 = label;
3338     }
3339   while (gfc_match_char (',') == MATCH_YES);
3340
3341   if (gfc_match_char (')') != MATCH_YES)
3342     goto syntax;
3343
3344   if (head == NULL)
3345     {
3346       gfc_error ("Statement label list in GOTO at %C cannot be empty");
3347       goto syntax;
3348     }
3349
3350   /* Get the rest of the statement.  */
3351   gfc_match_char (',');
3352
3353   if (gfc_match (" %e%t", &expr) != MATCH_YES)
3354     goto syntax;
3355
3356   if (!gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO at %C"))
3357     return MATCH_ERROR;
3358
3359   /* At this point, a computed GOTO has been fully matched and an
3360      equivalent SELECT statement constructed.  */
3361
3362   new_st.op = EXEC_SELECT;
3363   new_st.expr1 = NULL;
3364
3365   /* Hack: For a "real" SELECT, the expression is in expr. We put
3366      it in expr2 so we can distinguish then and produce the correct
3367      diagnostics.  */
3368   new_st.expr2 = expr;
3369   new_st.block = head;
3370   return MATCH_YES;
3371
3372 syntax:
3373   gfc_syntax_error (ST_GOTO);
3374 cleanup:
3375   gfc_free_statements (head);
3376   return MATCH_ERROR;
3377 }
3378
3379
3380 /* Frees a list of gfc_alloc structures.  */
3381
3382 void
3383 gfc_free_alloc_list (gfc_alloc *p)
3384 {
3385   gfc_alloc *q;
3386
3387   for (; p; p = q)
3388     {
3389       q = p->next;
3390       gfc_free_expr (p->expr);
3391       free (p);
3392     }
3393 }
3394
3395
3396 /* Match an ALLOCATE statement.  */
3397
3398 match
3399 gfc_match_allocate (void)
3400 {
3401   gfc_alloc *head, *tail;
3402   gfc_expr *stat, *errmsg, *tmp, *source, *mold;
3403   gfc_typespec ts;
3404   gfc_symbol *sym;
3405   match m;
3406   locus old_locus, deferred_locus;
3407   bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
3408   bool saw_unlimited = false;
3409
3410   head = tail = NULL;
3411   stat = errmsg = source = mold = tmp = NULL;
3412   saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
3413
3414   if (gfc_match_char ('(') != MATCH_YES)
3415     goto syntax;
3416
3417   /* Match an optional type-spec.  */
3418   old_locus = gfc_current_locus;
3419   m = gfc_match_type_spec (&ts);
3420   if (m == MATCH_ERROR)
3421     goto cleanup;
3422   else if (m == MATCH_NO)
3423     {
3424       char name[GFC_MAX_SYMBOL_LEN + 3];
3425
3426       if (gfc_match ("%n :: ", name) == MATCH_YES)
3427         {
3428           gfc_error ("Error in type-spec at %L", &old_locus);
3429           goto cleanup;
3430         }
3431
3432       ts.type = BT_UNKNOWN;
3433     }
3434   else
3435     {
3436       if (gfc_match (" :: ") == MATCH_YES)
3437         {
3438           if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
3439                                &old_locus))
3440             goto cleanup;
3441
3442           if (ts.deferred)
3443             {
3444               gfc_error ("Type-spec at %L cannot contain a deferred "
3445                          "type parameter", &old_locus);
3446               goto cleanup;
3447             }
3448
3449           if (ts.type == BT_CHARACTER)
3450             ts.u.cl->length_from_typespec = true;
3451         }
3452       else
3453         {
3454           ts.type = BT_UNKNOWN;
3455           gfc_current_locus = old_locus;
3456         }
3457     }
3458
3459   for (;;)
3460     {
3461       if (head == NULL)
3462         head = tail = gfc_get_alloc ();
3463       else
3464         {
3465           tail->next = gfc_get_alloc ();
3466           tail = tail->next;
3467         }
3468
3469       m = gfc_match_variable (&tail->expr, 0);
3470       if (m == MATCH_NO)
3471         goto syntax;
3472       if (m == MATCH_ERROR)
3473         goto cleanup;
3474
3475       if (gfc_check_do_variable (tail->expr->symtree))
3476         goto cleanup;
3477
3478       bool impure = gfc_impure_variable (tail->expr->symtree->n.sym);
3479       if (impure && gfc_pure (NULL))
3480         {
3481           gfc_error ("Bad allocate-object at %C for a PURE procedure");
3482           goto cleanup;
3483         }
3484
3485       if (impure)
3486         gfc_unset_implicit_pure (NULL);
3487
3488       if (tail->expr->ts.deferred)
3489         {
3490           saw_deferred = true;
3491           deferred_locus = tail->expr->where;
3492         }
3493
3494       if (gfc_find_state (COMP_DO_CONCURRENT)
3495           || gfc_find_state (COMP_CRITICAL))
3496         {
3497           gfc_ref *ref;
3498           bool coarray = tail->expr->symtree->n.sym->attr.codimension;
3499           for (ref = tail->expr->ref; ref; ref = ref->next)
3500             if (ref->type == REF_COMPONENT)
3501               coarray = ref->u.c.component->attr.codimension;
3502
3503           if (coarray && gfc_find_state (COMP_DO_CONCURRENT))
3504             {
3505               gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
3506               goto cleanup;
3507             }
3508           if (coarray && gfc_find_state (COMP_CRITICAL))
3509             {
3510               gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
3511               goto cleanup;
3512             }
3513         }
3514
3515       /* Check for F08:C628.  */
3516       sym = tail->expr->symtree->n.sym;
3517       b1 = !(tail->expr->ref
3518              && (tail->expr->ref->type == REF_COMPONENT
3519                  || tail->expr->ref->type == REF_ARRAY));
3520       if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
3521         b2 = !(CLASS_DATA (sym)->attr.allocatable
3522                || CLASS_DATA (sym)->attr.class_pointer);
3523       else
3524         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3525                       || sym->attr.proc_pointer);
3526       b3 = sym && sym->ns && sym->ns->proc_name
3527            && (sym->ns->proc_name->attr.allocatable
3528                || sym->ns->proc_name->attr.pointer
3529                || sym->ns->proc_name->attr.proc_pointer);
3530       if (b1 && b2 && !b3)
3531         {
3532           gfc_error ("Allocate-object at %L is neither a data pointer "
3533                      "nor an allocatable variable", &tail->expr->where);
3534           goto cleanup;
3535         }
3536
3537       /* The ALLOCATE statement had an optional typespec.  Check the
3538          constraints.  */
3539       if (ts.type != BT_UNKNOWN)
3540         {
3541           /* Enforce F03:C624.  */
3542           if (!gfc_type_compatible (&tail->expr->ts, &ts))
3543             {
3544               gfc_error ("Type of entity at %L is type incompatible with "
3545                          "typespec", &tail->expr->where);
3546               goto cleanup;
3547             }
3548
3549           /* Enforce F03:C627.  */
3550           if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr))
3551             {
3552               gfc_error ("Kind type parameter for entity at %L differs from "
3553                          "the kind type parameter of the typespec",
3554                          &tail->expr->where);
3555               goto cleanup;
3556             }
3557         }
3558
3559       if (tail->expr->ts.type == BT_DERIVED)
3560         tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
3561
3562       saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr);
3563
3564       if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
3565         {
3566           gfc_error ("Shape specification for allocatable scalar at %C");
3567           goto cleanup;
3568         }
3569
3570       if (gfc_match_char (',') != MATCH_YES)
3571         break;
3572
3573 alloc_opt_list:
3574
3575       m = gfc_match (" stat = %v", &tmp);
3576       if (m == MATCH_ERROR)
3577         goto cleanup;
3578       if (m == MATCH_YES)
3579         {
3580           /* Enforce C630.  */
3581           if (saw_stat)
3582             {
3583               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3584               goto cleanup;
3585             }
3586
3587           stat = tmp;
3588           tmp = NULL;
3589           saw_stat = true;
3590
3591           if (gfc_check_do_variable (stat->symtree))
3592             goto cleanup;
3593
3594           if (gfc_match_char (',') == MATCH_YES)
3595             goto alloc_opt_list;
3596         }
3597
3598       m = gfc_match (" errmsg = %v", &tmp);
3599       if (m == MATCH_ERROR)
3600         goto cleanup;
3601       if (m == MATCH_YES)
3602         {
3603           if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L", &tmp->where))
3604             goto cleanup;
3605
3606           /* Enforce C630.  */
3607           if (saw_errmsg)
3608             {
3609               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3610               goto cleanup;
3611             }
3612
3613           errmsg = tmp;
3614           tmp = NULL;
3615           saw_errmsg = true;
3616
3617           if (gfc_match_char (',') == MATCH_YES)
3618             goto alloc_opt_list;
3619         }
3620
3621       m = gfc_match (" source = %e", &tmp);
3622       if (m == MATCH_ERROR)
3623         goto cleanup;
3624       if (m == MATCH_YES)
3625         {
3626           if (!gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L", &tmp->where))
3627             goto cleanup;
3628
3629           /* Enforce C630.  */
3630           if (saw_source)
3631             {
3632               gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
3633               goto cleanup;
3634             }
3635
3636           /* The next 2 conditionals check C631.  */
3637           if (ts.type != BT_UNKNOWN)
3638             {
3639               gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3640                          &tmp->where, &old_locus);
3641               goto cleanup;
3642             }
3643
3644           if (head->next
3645               && !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
3646                                   " with more than a single allocate object",
3647                                   &tmp->where))
3648             goto cleanup;
3649
3650           source = tmp;
3651           tmp = NULL;
3652           saw_source = true;
3653
3654           if (gfc_match_char (',') == MATCH_YES)
3655             goto alloc_opt_list;
3656         }
3657
3658       m = gfc_match (" mold = %e", &tmp);
3659       if (m == MATCH_ERROR)
3660         goto cleanup;
3661       if (m == MATCH_YES)
3662         {
3663           if (!gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L", &tmp->where))
3664             goto cleanup;
3665
3666           /* Check F08:C636.  */
3667           if (saw_mold)
3668             {
3669               gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
3670               goto cleanup;
3671             }
3672
3673           /* Check F08:C637.  */
3674           if (ts.type != BT_UNKNOWN)
3675             {
3676               gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3677                          &tmp->where, &old_locus);
3678               goto cleanup;
3679             }
3680
3681           mold = tmp;
3682           tmp = NULL;
3683           saw_mold = true;
3684           mold->mold = 1;
3685
3686           if (gfc_match_char (',') == MATCH_YES)
3687             goto alloc_opt_list;
3688         }
3689
3690         gfc_gobble_whitespace ();
3691
3692         if (gfc_peek_char () == ')')
3693           break;
3694     }
3695
3696   if (gfc_match (" )%t") != MATCH_YES)
3697     goto syntax;
3698
3699   /* Check F08:C637.  */
3700   if (source && mold)
3701     {
3702       gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3703                   &mold->where, &source->where);
3704       goto cleanup;
3705     }
3706
3707   /* Check F03:C623,  */
3708   if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
3709     {
3710       gfc_error ("Allocate-object at %L with a deferred type parameter "
3711                  "requires either a type-spec or SOURCE tag or a MOLD tag",
3712                  &deferred_locus);
3713       goto cleanup;
3714     }
3715
3716   /* Check F03:C625,  */
3717   if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold)
3718     {
3719       for (tail = head; tail; tail = tail->next)
3720         {
3721           if (UNLIMITED_POLY (tail->expr))
3722             gfc_error ("Unlimited polymorphic allocate-object at %L "
3723                        "requires either a type-spec or SOURCE tag "
3724                        "or a MOLD tag", &tail->expr->where);
3725         }
3726       goto cleanup;
3727     }
3728
3729   new_st.op = EXEC_ALLOCATE;
3730   new_st.expr1 = stat;
3731   new_st.expr2 = errmsg;
3732   if (source)
3733     new_st.expr3 = source;
3734   else
3735     new_st.expr3 = mold;
3736   new_st.ext.alloc.list = head;
3737   new_st.ext.alloc.ts = ts;
3738
3739   return MATCH_YES;
3740
3741 syntax:
3742   gfc_syntax_error (ST_ALLOCATE);
3743
3744 cleanup:
3745   gfc_free_expr (errmsg);
3746   gfc_free_expr (source);
3747   gfc_free_expr (stat);
3748   gfc_free_expr (mold);
3749   if (tmp && tmp->expr_type) gfc_free_expr (tmp);
3750   gfc_free_alloc_list (head);
3751   return MATCH_ERROR;
3752 }
3753
3754
3755 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3756    a set of pointer assignments to intrinsic NULL().  */
3757
3758 match
3759 gfc_match_nullify (void)
3760 {
3761   gfc_code *tail;
3762   gfc_expr *e, *p;
3763   match m;
3764
3765   tail = NULL;
3766
3767   if (gfc_match_char ('(') != MATCH_YES)
3768     goto syntax;
3769
3770   for (;;)
3771     {
3772       m = gfc_match_variable (&p, 0);
3773       if (m == MATCH_ERROR)
3774         goto cleanup;
3775       if (m == MATCH_NO)
3776         goto syntax;
3777
3778       if (gfc_check_do_variable (p->symtree))
3779         goto cleanup;
3780
3781       /* F2008, C1242.  */
3782       if (gfc_is_coindexed (p))
3783         {
3784           gfc_error ("Pointer object at %C shall not be coindexed");
3785           goto cleanup;
3786         }
3787
3788       /* build ' => NULL() '.  */
3789       e = gfc_get_null_expr (&gfc_current_locus);
3790
3791       /* Chain to list.  */
3792       if (tail == NULL)
3793         {
3794           tail = &new_st;
3795           tail->op = EXEC_POINTER_ASSIGN;
3796         }
3797       else
3798         {
3799           tail->next = gfc_get_code (EXEC_POINTER_ASSIGN);
3800           tail = tail->next;
3801         }
3802
3803       tail->expr1 = p;
3804       tail->expr2 = e;
3805
3806       if (gfc_match (" )%t") == MATCH_YES)
3807         break;
3808       if (gfc_match_char (',') != MATCH_YES)
3809         goto syntax;
3810     }
3811
3812   return MATCH_YES;
3813
3814 syntax:
3815   gfc_syntax_error (ST_NULLIFY);
3816
3817 cleanup:
3818   gfc_free_statements (new_st.next);
3819   new_st.next = NULL;
3820   gfc_free_expr (new_st.expr1);
3821   new_st.expr1 = NULL;
3822   gfc_free_expr (new_st.expr2);
3823   new_st.expr2 = NULL;
3824   return MATCH_ERROR;
3825 }
3826
3827
3828 /* Match a DEALLOCATE statement.  */
3829
3830 match
3831 gfc_match_deallocate (void)
3832 {
3833   gfc_alloc *head, *tail;
3834   gfc_expr *stat, *errmsg, *tmp;
3835   gfc_symbol *sym;
3836   match m;
3837   bool saw_stat, saw_errmsg, b1, b2;
3838
3839   head = tail = NULL;
3840   stat = errmsg = tmp = NULL;
3841   saw_stat = saw_errmsg = false;
3842
3843   if (gfc_match_char ('(') != MATCH_YES)
3844     goto syntax;
3845
3846   for (;;)
3847     {
3848       if (head == NULL)
3849         head = tail = gfc_get_alloc ();
3850       else
3851         {
3852           tail->next = gfc_get_alloc ();
3853           tail = tail->next;
3854         }
3855
3856       m = gfc_match_variable (&tail->expr, 0);
3857       if (m == MATCH_ERROR)
3858         goto cleanup;
3859       if (m == MATCH_NO)
3860         goto syntax;
3861
3862       if (gfc_check_do_variable (tail->expr->symtree))
3863         goto cleanup;
3864
3865       sym = tail->expr->symtree->n.sym;
3866
3867       bool impure = gfc_impure_variable (sym);
3868       if (impure && gfc_pure (NULL))
3869         {
3870           gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3871           goto cleanup;
3872         }
3873
3874       if (impure)
3875         gfc_unset_implicit_pure (NULL);
3876
3877       if (gfc_is_coarray (tail->expr)
3878           && gfc_find_state (COMP_DO_CONCURRENT))
3879         {
3880           gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
3881           goto cleanup;
3882         }
3883
3884       if (gfc_is_coarray (tail->expr)
3885           && gfc_find_state (COMP_CRITICAL))
3886         {
3887           gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
3888           goto cleanup;
3889         }
3890
3891       /* FIXME: disable the checking on derived types.  */
3892       b1 = !(tail->expr->ref
3893            && (tail->expr->ref->type == REF_COMPONENT
3894                || tail->expr->ref->type == REF_ARRAY));
3895       if (sym && sym->ts.type == BT_CLASS)
3896         b2 = !(CLASS_DATA (sym)->attr.allocatable
3897                || CLASS_DATA (sym)->attr.class_pointer);
3898       else
3899         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3900                       || sym->attr.proc_pointer);
3901       if (b1 && b2)
3902         {
3903           gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3904                      "nor an allocatable variable");
3905           goto cleanup;
3906         }
3907
3908       if (gfc_match_char (',') != MATCH_YES)
3909         break;
3910
3911 dealloc_opt_list:
3912
3913       m = gfc_match (" stat = %v", &tmp);
3914       if (m == MATCH_ERROR)
3915         goto cleanup;
3916       if (m == MATCH_YES)
3917         {
3918           if (saw_stat)
3919             {
3920               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3921               gfc_free_expr (tmp);
3922               goto cleanup;
3923             }
3924
3925           stat = tmp;
3926           saw_stat = true;
3927
3928           if (gfc_check_do_variable (stat->symtree))
3929             goto cleanup;
3930
3931           if (gfc_match_char (',') == MATCH_YES)
3932             goto dealloc_opt_list;
3933         }
3934
3935       m = gfc_match (" errmsg = %v", &tmp);
3936       if (m == MATCH_ERROR)
3937         goto cleanup;
3938       if (m == MATCH_YES)
3939         {
3940           if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L", &tmp->where))
3941             goto cleanup;
3942
3943           if (saw_errmsg)
3944             {
3945               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3946               gfc_free_expr (tmp);
3947               goto cleanup;
3948             }
3949
3950           errmsg = tmp;
3951           saw_errmsg = true;
3952
3953           if (gfc_match_char (',') == MATCH_YES)
3954             goto dealloc_opt_list;
3955         }
3956
3957         gfc_gobble_whitespace ();
3958
3959         if (gfc_peek_char () == ')')
3960           break;
3961     }
3962
3963   if (gfc_match (" )%t") != MATCH_YES)
3964     goto syntax;
3965
3966   new_st.op = EXEC_DEALLOCATE;
3967   new_st.expr1 = stat;
3968   new_st.expr2 = errmsg;
3969   new_st.ext.alloc.list = head;
3970
3971   return MATCH_YES;
3972
3973 syntax:
3974   gfc_syntax_error (ST_DEALLOCATE);
3975
3976 cleanup:
3977   gfc_free_expr (errmsg);
3978   gfc_free_expr (stat);
3979   gfc_free_alloc_list (head);
3980   return MATCH_ERROR;
3981 }
3982
3983
3984 /* Match a RETURN statement.  */
3985
3986 match
3987 gfc_match_return (void)
3988 {
3989   gfc_expr *e;
3990   match m;
3991   gfc_compile_state s;
3992
3993   e = NULL;
3994
3995   if (gfc_find_state (COMP_CRITICAL))
3996     {
3997       gfc_error ("Image control statement RETURN at %C in CRITICAL block");
3998       return MATCH_ERROR;
3999     }
4000
4001   if (gfc_find_state (COMP_DO_CONCURRENT))
4002     {
4003       gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4004       return MATCH_ERROR;
4005     }
4006
4007   if (gfc_match_eos () == MATCH_YES)
4008     goto done;
4009
4010   if (!gfc_find_state (COMP_SUBROUTINE))
4011     {
4012       gfc_error ("Alternate RETURN statement at %C is only allowed within "
4013                  "a SUBROUTINE");
4014       goto cleanup;
4015     }
4016
4017   if (gfc_current_form == FORM_FREE)
4018     {
4019       /* The following are valid, so we can't require a blank after the
4020         RETURN keyword:
4021           return+1
4022           return(1)  */
4023       char c = gfc_peek_ascii_char ();
4024       if (ISALPHA (c) || ISDIGIT (c))
4025         return MATCH_NO;
4026     }
4027
4028   m = gfc_match (" %e%t", &e);
4029   if (m == MATCH_YES)
4030     goto done;
4031   if (m == MATCH_ERROR)
4032     goto cleanup;
4033
4034   gfc_syntax_error (ST_RETURN);
4035
4036 cleanup:
4037   gfc_free_expr (e);
4038   return MATCH_ERROR;
4039
4040 done:
4041   gfc_enclosing_unit (&s);
4042   if (s == COMP_PROGRAM
4043       && !gfc_notify_std (GFC_STD_GNU, "RETURN statement in "
4044                           "main program at %C"))
4045       return MATCH_ERROR;
4046
4047   new_st.op = EXEC_RETURN;
4048   new_st.expr1 = e;
4049
4050   return MATCH_YES;
4051 }
4052
4053
4054 /* Match the call of a type-bound procedure, if CALL%var has already been
4055    matched and var found to be a derived-type variable.  */
4056
4057 static match
4058 match_typebound_call (gfc_symtree* varst)
4059 {
4060   gfc_expr* base;
4061   match m;
4062
4063   base = gfc_get_expr ();
4064   base->expr_type = EXPR_VARIABLE;
4065   base->symtree = varst;
4066   base->where = gfc_current_locus;
4067   gfc_set_sym_referenced (varst->n.sym);
4068
4069   m = gfc_match_varspec (base, 0, true, true);
4070   if (m == MATCH_NO)
4071     gfc_error ("Expected component reference at %C");
4072   if (m != MATCH_YES)
4073     {
4074       gfc_free_expr (base);
4075       return MATCH_ERROR;
4076     }
4077
4078   if (gfc_match_eos () != MATCH_YES)
4079     {
4080       gfc_error ("Junk after CALL at %C");
4081       gfc_free_expr (base);
4082       return MATCH_ERROR;
4083     }
4084
4085   if (base->expr_type == EXPR_COMPCALL)
4086     new_st.op = EXEC_COMPCALL;
4087   else if (base->expr_type == EXPR_PPC)
4088     new_st.op = EXEC_CALL_PPC;
4089   else
4090     {
4091       gfc_error ("Expected type-bound procedure or procedure pointer component "
4092                  "at %C");
4093       gfc_free_expr (base);
4094       return MATCH_ERROR;
4095     }
4096   new_st.expr1 = base;
4097
4098   return MATCH_YES;
4099 }
4100
4101
4102 /* Match a CALL statement.  The tricky part here are possible
4103    alternate return specifiers.  We handle these by having all
4104    "subroutines" actually return an integer via a register that gives
4105    the return number.  If the call specifies alternate returns, we
4106    generate code for a SELECT statement whose case clauses contain
4107    GOTOs to the various labels.  */
4108
4109 match
4110 gfc_match_call (void)
4111 {
4112   char name[GFC_MAX_SYMBOL_LEN + 1];
4113   gfc_actual_arglist *a, *arglist;
4114   gfc_case *new_case;
4115   gfc_symbol *sym;
4116   gfc_symtree *st;
4117   gfc_code *c;
4118   match m;
4119   int i;
4120
4121   arglist = NULL;
4122
4123   m = gfc_match ("% %n", name);
4124   if (m == MATCH_NO)
4125     goto syntax;
4126   if (m != MATCH_YES)
4127     return m;
4128
4129   if (gfc_get_ha_sym_tree (name, &st))
4130     return MATCH_ERROR;
4131
4132   sym = st->n.sym;
4133
4134   /* If this is a variable of derived-type, it probably starts a type-bound
4135      procedure call.  */
4136   if ((sym->attr.flavor != FL_PROCEDURE
4137        || gfc_is_function_return_value (sym, gfc_current_ns))
4138       && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
4139     return match_typebound_call (st);
4140
4141   /* If it does not seem to be callable (include functions so that the
4142      right association is made.  They are thrown out in resolution.)
4143      ...  */
4144   if (!sym->attr.generic
4145         && !sym->attr.subroutine
4146         && !sym->attr.function)
4147     {
4148       if (!(sym->attr.external && !sym->attr.referenced))
4149         {
4150           /* ...create a symbol in this scope...  */
4151           if (sym->ns != gfc_current_ns
4152                 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
4153             return MATCH_ERROR;
4154
4155           if (sym != st->n.sym)
4156             sym = st->n.sym;
4157         }
4158
4159       /* ...and then to try to make the symbol into a subroutine.  */
4160       if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
4161         return MATCH_ERROR;
4162     }
4163
4164   gfc_set_sym_referenced (sym);
4165
4166   if (gfc_match_eos () != MATCH_YES)
4167     {
4168       m = gfc_match_actual_arglist (1, &arglist);
4169       if (m == MATCH_NO)
4170         goto syntax;
4171       if (m == MATCH_ERROR)
4172         goto cleanup;
4173
4174       if (gfc_match_eos () != MATCH_YES)
4175         goto syntax;
4176     }
4177
4178   /* If any alternate return labels were found, construct a SELECT
4179      statement that will jump to the right place.  */
4180
4181   i = 0;
4182   for (a = arglist; a; a = a->next)
4183     if (a->expr == NULL)
4184       {
4185         i = 1;
4186         break;
4187       }
4188
4189   if (i)
4190     {
4191       gfc_symtree *select_st;
4192       gfc_symbol *select_sym;
4193       char name[GFC_MAX_SYMBOL_LEN + 1];
4194
4195       new_st.next = c = gfc_get_code (EXEC_SELECT);
4196       sprintf (name, "_result_%s", sym->name);
4197       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
4198
4199       select_sym = select_st->n.sym;
4200       select_sym->ts.type = BT_INTEGER;
4201       select_sym->ts.kind = gfc_default_integer_kind;
4202       gfc_set_sym_referenced (select_sym);
4203       c->expr1 = gfc_get_expr ();
4204       c->expr1->expr_type = EXPR_VARIABLE;
4205       c->expr1->symtree = select_st;
4206       c->expr1->ts = select_sym->ts;
4207       c->expr1->where = gfc_current_locus;
4208
4209       i = 0;
4210       for (a = arglist; a; a = a->next)
4211         {
4212           if (a->expr != NULL)
4213             continue;
4214
4215           if (!gfc_reference_st_label (a->label, ST_LABEL_TARGET))
4216             continue;
4217
4218           i++;
4219
4220           c->block = gfc_get_code (EXEC_SELECT);
4221           c = c->block;
4222
4223           new_case = gfc_get_case ();
4224           new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
4225           new_case->low = new_case->high;
4226           c->ext.block.case_list = new_case;
4227
4228           c->next = gfc_get_code (EXEC_GOTO);
4229           c->next->label1 = a->label;
4230         }
4231     }
4232
4233   new_st.op = EXEC_CALL;
4234   new_st.symtree = st;
4235   new_st.ext.actual = arglist;
4236
4237   return MATCH_YES;
4238
4239 syntax:
4240   gfc_syntax_error (ST_CALL);
4241
4242 cleanup:
4243   gfc_free_actual_arglist (arglist);
4244   return MATCH_ERROR;
4245 }
4246
4247
4248 /* Given a name, return a pointer to the common head structure,
4249    creating it if it does not exist. If FROM_MODULE is nonzero, we
4250    mangle the name so that it doesn't interfere with commons defined
4251    in the using namespace.
4252    TODO: Add to global symbol tree.  */
4253
4254 gfc_common_head *
4255 gfc_get_common (const char *name, int from_module)
4256 {
4257   gfc_symtree *st;
4258   static int serial = 0;
4259   char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
4260
4261   if (from_module)
4262     {
4263       /* A use associated common block is only needed to correctly layout
4264          the variables it contains.  */
4265       snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
4266       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
4267     }
4268   else
4269     {
4270       st = gfc_find_symtree (gfc_current_ns->common_root, name);
4271
4272       if (st == NULL)
4273         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
4274     }
4275
4276   if (st->n.common == NULL)
4277     {
4278       st->n.common = gfc_get_common_head ();
4279       st->n.common->where = gfc_current_locus;
4280       strcpy (st->n.common->name, name);
4281     }
4282
4283   return st->n.common;
4284 }
4285
4286
4287 /* Match a common block name.  */
4288
4289 match match_common_name (char *name)
4290 {
4291   match m;
4292
4293   if (gfc_match_char ('/') == MATCH_NO)
4294     {
4295       name[0] = '\0';
4296       return MATCH_YES;
4297     }
4298
4299   if (gfc_match_char ('/') == MATCH_YES)
4300     {
4301       name[0] = '\0';
4302       return MATCH_YES;
4303     }
4304
4305   m = gfc_match_name (name);
4306
4307   if (m == MATCH_ERROR)
4308     return MATCH_ERROR;
4309   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
4310     return MATCH_YES;
4311
4312   gfc_error ("Syntax error in common block name at %C");
4313   return MATCH_ERROR;
4314 }
4315
4316
4317 /* Match a COMMON statement.  */
4318
4319 match
4320 gfc_match_common (void)
4321 {
4322   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
4323   char name[GFC_MAX_SYMBOL_LEN + 1];
4324   gfc_common_head *t;
4325   gfc_array_spec *as;
4326   gfc_equiv *e1, *e2;
4327   match m;
4328
4329   old_blank_common = gfc_current_ns->blank_common.head;
4330   if (old_blank_common)
4331     {
4332       while (old_blank_common->common_next)
4333         old_blank_common = old_blank_common->common_next;
4334     }
4335
4336   as = NULL;
4337
4338   for (;;)
4339     {
4340       m = match_common_name (name);
4341       if (m == MATCH_ERROR)
4342         goto cleanup;
4343
4344       if (name[0] == '\0')
4345         {
4346           t = &gfc_current_ns->blank_common;
4347           if (t->head == NULL)
4348             t->where = gfc_current_locus;
4349         }
4350       else
4351         {
4352           t = gfc_get_common (name, 0);
4353         }
4354       head = &t->head;
4355
4356       if (*head == NULL)
4357         tail = NULL;
4358       else
4359         {
4360           tail = *head;
4361           while (tail->common_next)
4362             tail = tail->common_next;
4363         }
4364
4365       /* Grab the list of symbols.  */
4366       for (;;)
4367         {
4368           m = gfc_match_symbol (&sym, 0);
4369           if (m == MATCH_ERROR)
4370             goto cleanup;
4371           if (m == MATCH_NO)
4372             goto syntax;
4373
4374           /* Store a ref to the common block for error checking.  */
4375           sym->common_block = t;
4376           sym->common_block->refs++;
4377
4378           /* See if we know the current common block is bind(c), and if
4379              so, then see if we can check if the symbol is (which it'll
4380              need to be).  This can happen if the bind(c) attr stmt was
4381              applied to the common block, and the variable(s) already
4382              defined, before declaring the common block.  */
4383           if (t->is_bind_c == 1)
4384             {
4385               if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
4386                 {
4387                   /* If we find an error, just print it and continue,
4388                      cause it's just semantic, and we can see if there
4389                      are more errors.  */
4390                   gfc_error_now ("Variable '%s' at %L in common block '%s' "
4391                                  "at %C must be declared with a C "
4392                                  "interoperable kind since common block "
4393                                  "'%s' is bind(c)",
4394                                  sym->name, &(sym->declared_at), t->name,
4395                                  t->name);
4396                 }
4397
4398               if (sym->attr.is_bind_c == 1)
4399                 gfc_error_now ("Variable '%s' in common block "
4400                                "'%s' at %C can not be bind(c) since "
4401                                "it is not global", sym->name, t->name);
4402             }
4403
4404           if (sym->attr.in_common)
4405             {
4406               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
4407                          sym->name);
4408               goto cleanup;
4409             }
4410
4411           if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
4412                || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
4413             {
4414               if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at "
4415                                    "%C can only be COMMON in BLOCK DATA",
4416                                    sym->name))
4417                 goto cleanup;
4418             }
4419
4420           if (!gfc_add_in_common (&sym->attr, sym->name, NULL))
4421             goto cleanup;
4422
4423           if (tail != NULL)
4424             tail->common_next = sym;
4425           else
4426             *head = sym;
4427
4428           tail = sym;
4429
4430           /* Deal with an optional array specification after the
4431              symbol name.  */
4432           m = gfc_match_array_spec (&as, true, true);
4433           if (m == MATCH_ERROR)
4434             goto cleanup;
4435
4436           if (m == MATCH_YES)
4437             {
4438               if (as->type != AS_EXPLICIT)
4439                 {
4440                   gfc_error ("Array specification for symbol '%s' in COMMON "
4441                              "at %C must be explicit", sym->name);
4442                   goto cleanup;
4443                 }
4444
4445               if (!gfc_add_dimension (&sym->attr, sym->name, NULL))
4446                 goto cleanup;
4447
4448               if (sym->attr.pointer)
4449                 {
4450                   gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
4451                              "POINTER array", sym->name);
4452                   goto cleanup;
4453                 }
4454
4455               sym->as = as;
4456               as = NULL;
4457
4458             }
4459
4460           sym->common_head = t;
4461
4462           /* Check to see if the symbol is already in an equivalence group.
4463              If it is, set the other members as being in common.  */
4464           if (sym->attr.in_equivalence)
4465             {
4466               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
4467                 {
4468                   for (e2 = e1; e2; e2 = e2->eq)
4469                     if (e2->expr->symtree->n.sym == sym)
4470                       goto equiv_found;
4471
4472                   continue;
4473
4474           equiv_found:
4475
4476                   for (e2 = e1; e2; e2 = e2->eq)
4477                     {
4478                       other = e2->expr->symtree->n.sym;
4479                       if (other->common_head
4480                           && other->common_head != sym->common_head)
4481                         {
4482                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
4483                                      "%C is being indirectly equivalenced to "
4484                                      "another COMMON block '%s'",
4485                                      sym->name, sym->common_head->name,
4486                                      other->common_head->name);
4487                             goto cleanup;
4488                         }
4489                       other->attr.in_common = 1;
4490                       other->common_head = t;
4491                     }
4492                 }
4493             }
4494
4495
4496           gfc_gobble_whitespace ();
4497           if (gfc_match_eos () == MATCH_YES)
4498             goto done;
4499           if (gfc_peek_ascii_char () == '/')
4500             break;
4501           if (gfc_match_char (',') != MATCH_YES)
4502             goto syntax;
4503           gfc_gobble_whitespace ();
4504           if (gfc_peek_ascii_char () == '/')
4505             break;
4506         }
4507     }
4508
4509 done:
4510   return MATCH_YES;
4511
4512 syntax:
4513   gfc_syntax_error (ST_COMMON);
4514
4515 cleanup:
4516   gfc_free_array_spec (as);
4517   return MATCH_ERROR;
4518 }
4519
4520
4521 /* Match a BLOCK DATA program unit.  */
4522
4523 match
4524 gfc_match_block_data (void)
4525 {
4526   char name[GFC_MAX_SYMBOL_LEN + 1];
4527   gfc_symbol *sym;
4528   match m;
4529
4530   if (gfc_match_eos () == MATCH_YES)
4531     {
4532       gfc_new_block = NULL;
4533       return MATCH_YES;
4534     }
4535
4536   m = gfc_match ("% %n%t", name);
4537   if (m != MATCH_YES)
4538     return MATCH_ERROR;
4539
4540   if (gfc_get_symbol (name, NULL, &sym))
4541     return MATCH_ERROR;
4542
4543   if (!gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL))
4544     return MATCH_ERROR;
4545
4546   gfc_new_block = sym;
4547
4548   return MATCH_YES;
4549 }
4550
4551
4552 /* Free a namelist structure.  */
4553
4554 void
4555 gfc_free_namelist (gfc_namelist *name)
4556 {
4557   gfc_namelist *n;
4558
4559   for (; name; name = n)
4560     {
4561       n = name->next;
4562       free (name);
4563     }
4564 }
4565
4566
4567 /* Match a NAMELIST statement.  */
4568
4569 match
4570 gfc_match_namelist (void)
4571 {
4572   gfc_symbol *group_name, *sym;
4573   gfc_namelist *nl;
4574   match m, m2;
4575
4576   m = gfc_match (" / %s /", &group_name);
4577   if (m == MATCH_NO)
4578     goto syntax;
4579   if (m == MATCH_ERROR)
4580     goto error;
4581
4582   for (;;)
4583     {
4584       if (group_name->ts.type != BT_UNKNOWN)
4585         {
4586           gfc_error ("Namelist group name '%s' at %C already has a basic "
4587                      "type of %s", group_name->name,
4588                      gfc_typename (&group_name->ts));
4589           return MATCH_ERROR;
4590         }
4591
4592       if (group_name->attr.flavor == FL_NAMELIST
4593           && group_name->attr.use_assoc
4594           && !gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
4595                               "at %C already is USE associated and can"
4596                               "not be respecified.", group_name->name))
4597         return MATCH_ERROR;
4598
4599       if (group_name->attr.flavor != FL_NAMELIST
4600           && !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
4601                               group_name->name, NULL))
4602         return MATCH_ERROR;
4603
4604       for (;;)
4605         {
4606           m = gfc_match_symbol (&sym, 1);
4607           if (m == MATCH_NO)
4608             goto syntax;
4609           if (m == MATCH_ERROR)
4610             goto error;
4611
4612           if (sym->attr.in_namelist == 0
4613               && !gfc_add_in_namelist (&sym->attr, sym->name, NULL))
4614             goto error;
4615
4616           /* Use gfc_error_check here, rather than goto error, so that
4617              these are the only errors for the next two lines.  */
4618           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
4619             {
4620               gfc_error ("Assumed size array '%s' in namelist '%s' at "
4621                          "%C is not allowed", sym->name, group_name->name);
4622               gfc_error_check ();
4623             }
4624
4625           nl = gfc_get_namelist ();
4626           nl->sym = sym;
4627           sym->refs++;
4628
4629           if (group_name->namelist == NULL)
4630             group_name->namelist = group_name->namelist_tail = nl;
4631           else
4632             {
4633               group_name->namelist_tail->next = nl;
4634               group_name->namelist_tail = nl;
4635             }
4636
4637           if (gfc_match_eos () == MATCH_YES)
4638             goto done;
4639
4640           m = gfc_match_char (',');
4641
4642           if (gfc_match_char ('/') == MATCH_YES)
4643             {
4644               m2 = gfc_match (" %s /", &group_name);
4645               if (m2 == MATCH_YES)
4646                 break;
4647               if (m2 == MATCH_ERROR)
4648                 goto error;
4649               goto syntax;
4650             }
4651
4652           if (m != MATCH_YES)
4653             goto syntax;
4654         }
4655     }
4656
4657 done:
4658   return MATCH_YES;
4659
4660 syntax:
4661   gfc_syntax_error (ST_NAMELIST);
4662
4663 error:
4664   return MATCH_ERROR;
4665 }
4666
4667
4668 /* Match a MODULE statement.  */
4669
4670 match
4671 gfc_match_module (void)
4672 {
4673   match m;
4674
4675   m = gfc_match (" %s%t", &gfc_new_block);
4676   if (m != MATCH_YES)
4677     return m;
4678
4679   if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
4680                        gfc_new_block->name, NULL))
4681     return MATCH_ERROR;
4682
4683   return MATCH_YES;
4684 }
4685
4686
4687 /* Free equivalence sets and lists.  Recursively is the easiest way to
4688    do this.  */
4689
4690 void
4691 gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
4692 {
4693   if (eq == stop)
4694     return;
4695
4696   gfc_free_equiv (eq->eq);
4697   gfc_free_equiv_until (eq->next, stop);
4698   gfc_free_expr (eq->expr);
4699   free (eq);
4700 }
4701
4702
4703 void
4704 gfc_free_equiv (gfc_equiv *eq)
4705 {
4706   gfc_free_equiv_until (eq, NULL);
4707 }
4708
4709
4710 /* Match an EQUIVALENCE statement.  */
4711
4712 match
4713 gfc_match_equivalence (void)
4714 {
4715   gfc_equiv *eq, *set, *tail;
4716   gfc_ref *ref;
4717   gfc_symbol *sym;
4718   match m;
4719   gfc_common_head *common_head = NULL;
4720   bool common_flag;
4721   int cnt;
4722
4723   tail = NULL;
4724
4725   for (;;)
4726     {
4727       eq = gfc_get_equiv ();
4728       if (tail == NULL)
4729         tail = eq;
4730
4731       eq->next = gfc_current_ns->equiv;
4732       gfc_current_ns->equiv = eq;
4733
4734       if (gfc_match_char ('(') != MATCH_YES)
4735         goto syntax;
4736
4737       set = eq;
4738       common_flag = FALSE;
4739       cnt = 0;
4740
4741       for (;;)
4742         {
4743           m = gfc_match_equiv_variable (&set->expr);
4744           if (m == MATCH_ERROR)
4745             goto cleanup;
4746           if (m == MATCH_NO)
4747             goto syntax;
4748
4749           /*  count the number of objects.  */
4750           cnt++;
4751
4752           if (gfc_match_char ('%') == MATCH_YES)
4753             {
4754               gfc_error ("Derived type component %C is not a "
4755                          "permitted EQUIVALENCE member");
4756               goto cleanup;
4757             }
4758
4759           for (ref = set->expr->ref; ref; ref = ref->next)
4760             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
4761               {
4762                 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4763                            "be an array section");
4764                 goto cleanup;
4765               }
4766
4767           sym = set->expr->symtree->n.sym;
4768
4769           if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL))
4770             goto cleanup;
4771
4772           if (sym->attr.in_common)
4773             {
4774               common_flag = TRUE;
4775               common_head = sym->common_head;
4776             }
4777
4778           if (gfc_match_char (')') == MATCH_YES)
4779             break;
4780
4781           if (gfc_match_char (',') != MATCH_YES)
4782             goto syntax;
4783
4784           set->eq = gfc_get_equiv ();
4785           set = set->eq;
4786         }
4787
4788       if (cnt < 2)
4789         {
4790           gfc_error ("EQUIVALENCE at %C requires two or more objects");
4791           goto cleanup;
4792         }
4793
4794       /* If one of the members of an equivalence is in common, then
4795          mark them all as being in common.  Before doing this, check
4796          that members of the equivalence group are not in different
4797          common blocks.  */
4798       if (common_flag)
4799         for (set = eq; set; set = set->eq)
4800           {
4801             sym = set->expr->symtree->n.sym;
4802             if (sym->common_head && sym->common_head != common_head)
4803               {
4804                 gfc_error ("Attempt to indirectly overlap COMMON "
4805                            "blocks %s and %s by EQUIVALENCE at %C",
4806                            sym->common_head->name, common_head->name);
4807                 goto cleanup;
4808               }
4809             sym->attr.in_common = 1;
4810             sym->common_head = common_head;
4811           }
4812
4813       if (gfc_match_eos () == MATCH_YES)
4814         break;
4815       if (gfc_match_char (',') != MATCH_YES)
4816         {
4817           gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4818           goto cleanup;
4819         }
4820     }
4821
4822   return MATCH_YES;
4823
4824 syntax:
4825   gfc_syntax_error (ST_EQUIVALENCE);
4826
4827 cleanup:
4828   eq = tail->next;
4829   tail->next = NULL;
4830
4831   gfc_free_equiv (gfc_current_ns->equiv);
4832   gfc_current_ns->equiv = eq;
4833
4834   return MATCH_ERROR;
4835 }
4836
4837
4838 /* Check that a statement function is not recursive. This is done by looking
4839    for the statement function symbol(sym) by looking recursively through its
4840    expression(e).  If a reference to sym is found, true is returned.
4841    12.5.4 requires that any variable of function that is implicitly typed
4842    shall have that type confirmed by any subsequent type declaration.  The
4843    implicit typing is conveniently done here.  */
4844 static bool
4845 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
4846
4847 static bool
4848 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
4849 {
4850
4851   if (e == NULL)
4852     return false;
4853
4854   switch (e->expr_type)
4855     {
4856     case EXPR_FUNCTION:
4857       if (e->symtree == NULL)
4858         return false;
4859
4860       /* Check the name before testing for nested recursion!  */
4861       if (sym->name == e->symtree->n.sym->name)
4862         return true;
4863
4864       /* Catch recursion via other statement functions.  */
4865       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
4866           && e->symtree->n.sym->value
4867           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
4868         return true;
4869
4870       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4871         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4872
4873       break;
4874
4875     case EXPR_VARIABLE:
4876       if (e->symtree && sym->name == e->symtree->n.sym->name)
4877         return true;
4878
4879       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4880         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4881       break;
4882
4883     default:
4884       break;
4885     }
4886
4887   return false;
4888 }
4889
4890
4891 static bool
4892 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
4893 {
4894   return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
4895 }
4896
4897
4898 /* Match a statement function declaration.  It is so easy to match
4899    non-statement function statements with a MATCH_ERROR as opposed to
4900    MATCH_NO that we suppress error message in most cases.  */
4901
4902 match
4903 gfc_match_st_function (void)
4904 {
4905   gfc_error_buf old_error;
4906   gfc_symbol *sym;
4907   gfc_expr *expr;
4908   match m;
4909
4910   m = gfc_match_symbol (&sym, 0);
4911   if (m != MATCH_YES)
4912     return m;
4913
4914   gfc_push_error (&old_error);
4915
4916   if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL))
4917     goto undo_error;
4918
4919   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
4920     goto undo_error;
4921
4922   m = gfc_match (" = %e%t", &expr);
4923   if (m == MATCH_NO)
4924     goto undo_error;
4925
4926   gfc_free_error (&old_error);
4927   if (m == MATCH_ERROR)
4928     return m;
4929
4930   if (recursive_stmt_fcn (expr, sym))
4931     {
4932       gfc_error ("Statement function at %L is recursive", &expr->where);
4933       return MATCH_ERROR;
4934     }
4935
4936   sym->value = expr;
4937
4938   if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C"))
4939     return MATCH_ERROR;
4940
4941   return MATCH_YES;
4942
4943 undo_error:
4944   gfc_pop_error (&old_error);
4945   return MATCH_NO;
4946 }
4947
4948
4949 /***************** SELECT CASE subroutines ******************/
4950
4951 /* Free a single case structure.  */
4952
4953 static void
4954 free_case (gfc_case *p)
4955 {
4956   if (p->low == p->high)
4957     p->high = NULL;
4958   gfc_free_expr (p->low);
4959   gfc_free_expr (p->high);
4960   free (p);
4961 }
4962
4963
4964 /* Free a list of case structures.  */
4965
4966 void
4967 gfc_free_case_list (gfc_case *p)
4968 {
4969   gfc_case *q;
4970
4971   for (; p; p = q)
4972     {
4973       q = p->next;
4974       free_case (p);
4975     }
4976 }
4977
4978
4979 /* Match a single case selector.  */
4980
4981 static match
4982 match_case_selector (gfc_case **cp)
4983 {
4984   gfc_case *c;
4985   match m;
4986
4987   c = gfc_get_case ();
4988   c->where = gfc_current_locus;
4989
4990   if (gfc_match_char (':') == MATCH_YES)
4991     {
4992       m = gfc_match_init_expr (&c->high);
4993       if (m == MATCH_NO)
4994         goto need_expr;
4995       if (m == MATCH_ERROR)
4996         goto cleanup;
4997     }
4998   else
4999     {
5000       m = gfc_match_init_expr (&c->low);
5001       if (m == MATCH_ERROR)
5002         goto cleanup;
5003       if (m == MATCH_NO)
5004         goto need_expr;
5005
5006       /* If we're not looking at a ':' now, make a range out of a single
5007          target.  Else get the upper bound for the case range.  */
5008       if (gfc_match_char (':') != MATCH_YES)
5009         c->high = c->low;
5010       else
5011         {
5012           m = gfc_match_init_expr (&c->high);
5013           if (m == MATCH_ERROR)
5014             goto cleanup;
5015           /* MATCH_NO is fine.  It's OK if nothing is there!  */
5016         }
5017     }
5018
5019   *cp = c;
5020   return MATCH_YES;
5021
5022 need_expr:
5023   gfc_error ("Expected initialization expression in CASE at %C");
5024
5025 cleanup:
5026   free_case (c);
5027   return MATCH_ERROR;
5028 }
5029
5030
5031 /* Match the end of a case statement.  */
5032
5033 static match
5034 match_case_eos (void)
5035 {
5036   char name[GFC_MAX_SYMBOL_LEN + 1];
5037   match m;
5038
5039   if (gfc_match_eos () == MATCH_YES)
5040     return MATCH_YES;
5041
5042   /* If the case construct doesn't have a case-construct-name, we
5043      should have matched the EOS.  */
5044   if (!gfc_current_block ())
5045     return MATCH_NO;
5046
5047   gfc_gobble_whitespace ();
5048
5049   m = gfc_match_name (name);
5050   if (m != MATCH_YES)
5051     return m;
5052
5053   if (strcmp (name, gfc_current_block ()->name) != 0)
5054     {
5055       gfc_error ("Expected block name '%s' of SELECT construct at %C",
5056                  gfc_current_block ()->name);
5057       return MATCH_ERROR;
5058     }
5059
5060   return gfc_match_eos ();
5061 }
5062
5063
5064 /* Match a SELECT statement.  */
5065
5066 match
5067 gfc_match_select (void)
5068 {
5069   gfc_expr *expr;
5070   match m;
5071
5072   m = gfc_match_label ();
5073   if (m == MATCH_ERROR)
5074     return m;
5075
5076   m = gfc_match (" select case ( %e )%t", &expr);
5077   if (m != MATCH_YES)
5078     return m;
5079
5080   new_st.op = EXEC_SELECT;
5081   new_st.expr1 = expr;
5082
5083   return MATCH_YES;
5084 }
5085
5086
5087 /* Transfer the selector typespec to the associate name.  */
5088
5089 static void
5090 copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
5091 {
5092   gfc_ref *ref;
5093   gfc_symbol *assoc_sym;
5094
5095   assoc_sym = associate->symtree->n.sym;
5096
5097   /* At this stage the expression rank and arrayspec dimensions have
5098      not been completely sorted out. We must get the expr2->rank
5099      right here, so that the correct class container is obtained.  */
5100   ref = selector->ref;
5101   while (ref && ref->next)
5102     ref = ref->next;
5103
5104   if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as
5105       && ref && ref->type == REF_ARRAY)
5106     {
5107       /* Ensure that the array reference type is set.  We cannot use
5108          gfc_resolve_expr at this point, so the usable parts of
5109          resolve.c(resolve_array_ref) are employed to do it.  */
5110       if (ref->u.ar.type == AR_UNKNOWN)
5111         {
5112           ref->u.ar.type = AR_ELEMENT;
5113           for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
5114             if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5115                 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR
5116                 || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
5117                     && ref->u.ar.start[i] && ref->u.ar.start[i]->rank))
5118               {
5119                 ref->u.ar.type = AR_SECTION;
5120                 break;
5121               }
5122         }
5123
5124       if (ref->u.ar.type == AR_FULL)
5125         selector->rank = CLASS_DATA (selector)->as->rank;
5126       else if (ref->u.ar.type == AR_SECTION)
5127         selector->rank = ref->u.ar.dimen;
5128       else
5129         selector->rank = 0;
5130     }
5131
5132   if (selector->rank)
5133     {
5134       assoc_sym->attr.dimension = 1;
5135       assoc_sym->as = gfc_get_array_spec ();
5136       assoc_sym->as->rank = selector->rank;
5137       assoc_sym->as->type = AS_DEFERRED;
5138     }
5139   else
5140     assoc_sym->as = NULL;
5141
5142   if (selector->ts.type == BT_CLASS)
5143     {
5144       /* The correct class container has to be available.  */
5145       assoc_sym->ts.type = BT_CLASS;
5146       assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
5147       assoc_sym->attr.pointer = 1;
5148       gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
5149     }
5150 }
5151
5152
5153 /* Push the current selector onto the SELECT TYPE stack.  */
5154
5155 static void
5156 select_type_push (gfc_symbol *sel)
5157 {
5158   gfc_select_type_stack *top = gfc_get_select_type_stack ();
5159   top->selector = sel;
5160   top->tmp = NULL;
5161   top->prev = select_type_stack;
5162
5163   select_type_stack = top;
5164 }
5165
5166
5167 /* Set the temporary for the current intrinsic SELECT TYPE selector.  */
5168
5169 static gfc_symtree *
5170 select_intrinsic_set_tmp (gfc_typespec *ts)
5171 {
5172   char name[GFC_MAX_SYMBOL_LEN];
5173   gfc_symtree *tmp;
5174   int charlen = 0;
5175
5176   if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
5177     return NULL;
5178
5179   if (select_type_stack->selector->ts.type == BT_CLASS
5180       && !select_type_stack->selector->attr.class_ok)
5181     return NULL;
5182
5183   if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
5184       && ts->u.cl->length->expr_type == EXPR_CONSTANT)
5185     charlen = mpz_get_si (ts->u.cl->length->value.integer);
5186
5187   if (ts->type != BT_CHARACTER)
5188     sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
5189              ts->kind);
5190   else
5191     sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (ts->type),
5192              charlen, ts->kind);
5193
5194   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
5195   gfc_add_type (tmp->n.sym, ts, NULL);
5196
5197   /* Copy across the array spec to the selector.  */
5198   if (select_type_stack->selector->ts.type == BT_CLASS
5199       && (CLASS_DATA (select_type_stack->selector)->attr.dimension
5200           || CLASS_DATA (select_type_stack->selector)->attr.codimension))
5201     {
5202       tmp->n.sym->attr.pointer = 1;
5203       tmp->n.sym->attr.dimension
5204                 = CLASS_DATA (select_type_stack->selector)->attr.dimension;
5205       tmp->n.sym->attr.codimension
5206                 = CLASS_DATA (select_type_stack->selector)->attr.codimension;
5207       tmp->n.sym->as
5208         = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
5209     }
5210
5211   gfc_set_sym_referenced (tmp->n.sym);
5212   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
5213   tmp->n.sym->attr.select_type_temporary = 1;
5214
5215   return tmp;
5216 }
5217
5218
5219 /* Set up a temporary for the current TYPE IS / CLASS IS branch .  */
5220
5221 static void
5222 select_type_set_tmp (gfc_typespec *ts)
5223 {
5224   char name[GFC_MAX_SYMBOL_LEN];
5225   gfc_symtree *tmp = NULL;
5226
5227   if (!ts)
5228     {
5229       select_type_stack->tmp = NULL;
5230       return;
5231     }
5232
5233   tmp = select_intrinsic_set_tmp (ts);
5234
5235   if (tmp == NULL)
5236     {
5237       if (!ts->u.derived)
5238         return;
5239
5240       if (ts->type == BT_CLASS)
5241         sprintf (name, "__tmp_class_%s", ts->u.derived->name);
5242       else
5243         sprintf (name, "__tmp_type_%s", ts->u.derived->name);
5244       gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
5245       gfc_add_type (tmp->n.sym, ts, NULL);
5246
5247       if (select_type_stack->selector->ts.type == BT_CLASS
5248         && select_type_stack->selector->attr.class_ok)
5249         {
5250           tmp->n.sym->attr.pointer
5251                 = CLASS_DATA (select_type_stack->selector)->attr.class_pointer;
5252
5253           /* Copy across the array spec to the selector.  */
5254           if (CLASS_DATA (select_type_stack->selector)->attr.dimension
5255               || CLASS_DATA (select_type_stack->selector)->attr.codimension)
5256             {
5257               tmp->n.sym->attr.dimension
5258                     = CLASS_DATA (select_type_stack->selector)->attr.dimension;
5259               tmp->n.sym->attr.codimension
5260                     = CLASS_DATA (select_type_stack->selector)->attr.codimension;
5261               tmp->n.sym->as
5262             = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
5263             }
5264     }
5265
5266   gfc_set_sym_referenced (tmp->n.sym);
5267   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
5268   tmp->n.sym->attr.select_type_temporary = 1;
5269
5270   if (ts->type == BT_CLASS)
5271     gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
5272                             &tmp->n.sym->as);
5273     }
5274
5275   /* Add an association for it, so the rest of the parser knows it is
5276      an associate-name.  The target will be set during resolution.  */
5277   tmp->n.sym->assoc = gfc_get_association_list ();
5278   tmp->n.sym->assoc->dangling = 1;
5279   tmp->n.sym->assoc->st = tmp;
5280
5281   select_type_stack->tmp = tmp;
5282 }
5283
5284
5285 /* Match a SELECT TYPE statement.  */
5286
5287 match
5288 gfc_match_select_type (void)
5289 {
5290   gfc_expr *expr1, *expr2 = NULL;
5291   match m;
5292   char name[GFC_MAX_SYMBOL_LEN];
5293   bool class_array;
5294   gfc_symbol *sym;
5295
5296   m = gfc_match_label ();
5297   if (m == MATCH_ERROR)
5298     return m;
5299
5300   m = gfc_match (" select type ( ");
5301   if (m != MATCH_YES)
5302     return m;
5303
5304   m = gfc_match (" %n => %e", name, &expr2);
5305   if (m == MATCH_YES)
5306     {
5307       expr1 = gfc_get_expr();
5308       expr1->expr_type = EXPR_VARIABLE;
5309       if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
5310         {
5311           m = MATCH_ERROR;
5312           goto cleanup;
5313         }
5314
5315       sym = expr1->symtree->n.sym;
5316       if (expr2->ts.type == BT_UNKNOWN)
5317         sym->attr.untyped = 1;
5318       else
5319         copy_ts_from_selector_to_associate (expr1, expr2);
5320
5321       sym->attr.flavor = FL_VARIABLE;
5322       sym->attr.referenced = 1;
5323       sym->attr.class_ok = 1;
5324     }
5325   else
5326     {
5327       m = gfc_match (" %e ", &expr1);
5328       if (m != MATCH_YES)
5329         return m;
5330     }
5331
5332   m = gfc_match (" )%t");
5333   if (m != MATCH_YES)
5334     {
5335       gfc_error ("parse error in SELECT TYPE statement at %C");
5336       goto cleanup;
5337     }
5338
5339   /* This ghastly expression seems to be needed to distinguish a CLASS
5340      array, which can have a reference, from other expressions that
5341      have references, such as derived type components, and are not
5342      allowed by the standard.
5343      TODO: see if it is sufficient to exclude component and substring
5344      references.  */
5345   class_array = expr1->expr_type == EXPR_VARIABLE
5346                   && expr1->ts.type == BT_CLASS
5347                   && CLASS_DATA (expr1)
5348                   && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
5349                   && (CLASS_DATA (expr1)->attr.dimension
5350                       || CLASS_DATA (expr1)->attr.codimension)
5351                   && expr1->ref
5352                   && expr1->ref->type == REF_ARRAY
5353                   && expr1->ref->next == NULL;
5354
5355   /* Check for F03:C811.  */
5356   if (!expr2 && (expr1->expr_type != EXPR_VARIABLE
5357                   || (!class_array && expr1->ref != NULL)))
5358     {
5359       gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
5360                  "use associate-name=>");
5361       m = MATCH_ERROR;
5362       goto cleanup;
5363     }
5364
5365   new_st.op = EXEC_SELECT_TYPE;
5366   new_st.expr1 = expr1;
5367   new_st.expr2 = expr2;
5368   new_st.ext.block.ns = gfc_current_ns;
5369
5370   select_type_push (expr1->symtree->n.sym);
5371
5372   return MATCH_YES;
5373
5374 cleanup:
5375   gfc_free_expr (expr1);
5376   gfc_free_expr (expr2);
5377   return m;
5378 }
5379
5380
5381 /* Match a CASE statement.  */
5382
5383 match
5384 gfc_match_case (void)
5385 {
5386   gfc_case *c, *head, *tail;
5387   match m;
5388
5389   head = tail = NULL;
5390
5391   if (gfc_current_state () != COMP_SELECT)
5392     {
5393       gfc_error ("Unexpected CASE statement at %C");
5394       return MATCH_ERROR;
5395     }
5396
5397   if (gfc_match ("% default") == MATCH_YES)
5398     {
5399       m = match_case_eos ();
5400       if (m == MATCH_NO)
5401         goto syntax;
5402       if (m == MATCH_ERROR)
5403         goto cleanup;
5404
5405       new_st.op = EXEC_SELECT;
5406       c = gfc_get_case ();
5407       c->where = gfc_current_locus;
5408       new_st.ext.block.case_list = c;
5409       return MATCH_YES;
5410     }
5411
5412   if (gfc_match_char ('(') != MATCH_YES)
5413     goto syntax;
5414
5415   for (;;)
5416     {
5417       if (match_case_selector (&c) == MATCH_ERROR)
5418         goto cleanup;
5419
5420       if (head == NULL)
5421         head = c;
5422       else
5423         tail->next = c;
5424
5425       tail = c;
5426
5427       if (gfc_match_char (')') == MATCH_YES)
5428         break;
5429       if (gfc_match_char (',') != MATCH_YES)
5430         goto syntax;
5431     }
5432
5433   m = match_case_eos ();
5434   if (m == MATCH_NO)
5435     goto syntax;
5436   if (m == MATCH_ERROR)
5437     goto cleanup;
5438
5439   new_st.op = EXEC_SELECT;
5440   new_st.ext.block.case_list = head;
5441
5442   return MATCH_YES;
5443
5444 syntax:
5445   gfc_error ("Syntax error in CASE specification at %C");
5446
5447 cleanup:
5448   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
5449   return MATCH_ERROR;
5450 }
5451
5452
5453 /* Match a TYPE IS statement.  */
5454
5455 match
5456 gfc_match_type_is (void)
5457 {
5458   gfc_case *c = NULL;
5459   match m;
5460
5461   if (gfc_current_state () != COMP_SELECT_TYPE)
5462     {
5463       gfc_error ("Unexpected TYPE IS statement at %C");
5464       return MATCH_ERROR;
5465     }
5466
5467   if (gfc_match_char ('(') != MATCH_YES)
5468     goto syntax;
5469
5470   c = gfc_get_case ();
5471   c->where = gfc_current_locus;
5472
5473   if (gfc_match_type_spec (&c->ts) == MATCH_ERROR)
5474     goto cleanup;
5475
5476   if (gfc_match_char (')') != MATCH_YES)
5477     goto syntax;
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_TYPE;
5486   new_st.ext.block.case_list = c;
5487
5488   if (c->ts.type == BT_DERIVED && c->ts.u.derived
5489       && (c->ts.u.derived->attr.sequence
5490           || c->ts.u.derived->attr.is_bind_c))
5491     {
5492       gfc_error ("The type-spec shall not specify a sequence derived "
5493                  "type or a type with the BIND attribute in SELECT "
5494                  "TYPE at %C [F2003:C815]");
5495       return MATCH_ERROR;
5496     }
5497
5498   /* Create temporary variable.  */
5499   select_type_set_tmp (&c->ts);
5500
5501   return MATCH_YES;
5502
5503 syntax:
5504   gfc_error ("Syntax error in TYPE IS specification at %C");
5505
5506 cleanup:
5507   if (c != NULL)
5508     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
5509   return MATCH_ERROR;
5510 }
5511
5512
5513 /* Match a CLASS IS or CLASS DEFAULT statement.  */
5514
5515 match
5516 gfc_match_class_is (void)
5517 {
5518   gfc_case *c = NULL;
5519   match m;
5520
5521   if (gfc_current_state () != COMP_SELECT_TYPE)
5522     return MATCH_NO;
5523
5524   if (gfc_match ("% default") == MATCH_YES)
5525     {
5526       m = match_case_eos ();
5527       if (m == MATCH_NO)
5528         goto syntax;
5529       if (m == MATCH_ERROR)
5530         goto cleanup;
5531
5532       new_st.op = EXEC_SELECT_TYPE;
5533       c = gfc_get_case ();
5534       c->where = gfc_current_locus;
5535       c->ts.type = BT_UNKNOWN;
5536       new_st.ext.block.case_list = c;
5537       select_type_set_tmp (NULL);
5538       return MATCH_YES;
5539     }
5540
5541   m = gfc_match ("% is");
5542   if (m == MATCH_NO)
5543     goto syntax;
5544   if (m == MATCH_ERROR)
5545     goto cleanup;
5546
5547   if (gfc_match_char ('(') != MATCH_YES)
5548     goto syntax;
5549
5550   c = gfc_get_case ();
5551   c->where = gfc_current_locus;
5552
5553   if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
5554     goto cleanup;
5555
5556   if (c->ts.type == BT_DERIVED)
5557     c->ts.type = BT_CLASS;
5558
5559   if (gfc_match_char (')') != MATCH_YES)
5560     goto syntax;
5561
5562   m = match_case_eos ();
5563   if (m == MATCH_NO)
5564     goto syntax;
5565   if (m == MATCH_ERROR)
5566     goto cleanup;
5567
5568   new_st.op = EXEC_SELECT_TYPE;
5569   new_st.ext.block.case_list = c;
5570
5571   /* Create temporary variable.  */
5572   select_type_set_tmp (&c->ts);
5573
5574   return MATCH_YES;
5575
5576 syntax:
5577   gfc_error ("Syntax error in CLASS IS specification at %C");
5578
5579 cleanup:
5580   if (c != NULL)
5581     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
5582   return MATCH_ERROR;
5583 }
5584
5585
5586 /********************* WHERE subroutines ********************/
5587
5588 /* Match the rest of a simple WHERE statement that follows an IF statement.
5589  */
5590
5591 static match
5592 match_simple_where (void)
5593 {
5594   gfc_expr *expr;
5595   gfc_code *c;
5596   match m;
5597
5598   m = gfc_match (" ( %e )", &expr);
5599   if (m != MATCH_YES)
5600     return m;
5601
5602   m = gfc_match_assignment ();
5603   if (m == MATCH_NO)
5604     goto syntax;
5605   if (m == MATCH_ERROR)
5606     goto cleanup;
5607
5608   if (gfc_match_eos () != MATCH_YES)
5609     goto syntax;
5610
5611   c = gfc_get_code (EXEC_WHERE);
5612   c->expr1 = expr;
5613
5614   c->next = XCNEW (gfc_code);
5615   *c->next = new_st;
5616   gfc_clear_new_st ();
5617
5618   new_st.op = EXEC_WHERE;
5619   new_st.block = c;
5620
5621   return MATCH_YES;
5622
5623 syntax:
5624   gfc_syntax_error (ST_WHERE);
5625
5626 cleanup:
5627   gfc_free_expr (expr);
5628   return MATCH_ERROR;
5629 }
5630
5631
5632 /* Match a WHERE statement.  */
5633
5634 match
5635 gfc_match_where (gfc_statement *st)
5636 {
5637   gfc_expr *expr;
5638   match m0, m;
5639   gfc_code *c;
5640
5641   m0 = gfc_match_label ();
5642   if (m0 == MATCH_ERROR)
5643     return m0;
5644
5645   m = gfc_match (" where ( %e )", &expr);
5646   if (m != MATCH_YES)
5647     return m;
5648
5649   if (gfc_match_eos () == MATCH_YES)
5650     {
5651       *st = ST_WHERE_BLOCK;
5652       new_st.op = EXEC_WHERE;
5653       new_st.expr1 = expr;
5654       return MATCH_YES;
5655     }
5656
5657   m = gfc_match_assignment ();
5658   if (m == MATCH_NO)
5659     gfc_syntax_error (ST_WHERE);
5660
5661   if (m != MATCH_YES)
5662     {
5663       gfc_free_expr (expr);
5664       return MATCH_ERROR;
5665     }
5666
5667   /* We've got a simple WHERE statement.  */
5668   *st = ST_WHERE;
5669   c = gfc_get_code (EXEC_WHERE);
5670   c->expr1 = expr;
5671
5672   c->next = XCNEW (gfc_code);
5673   *c->next = new_st;
5674   gfc_clear_new_st ();
5675
5676   new_st.op = EXEC_WHERE;
5677   new_st.block = c;
5678
5679   return MATCH_YES;
5680 }
5681
5682
5683 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
5684    new_st if successful.  */
5685
5686 match
5687 gfc_match_elsewhere (void)
5688 {
5689   char name[GFC_MAX_SYMBOL_LEN + 1];
5690   gfc_expr *expr;
5691   match m;
5692
5693   if (gfc_current_state () != COMP_WHERE)
5694     {
5695       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
5696       return MATCH_ERROR;
5697     }
5698
5699   expr = NULL;
5700
5701   if (gfc_match_char ('(') == MATCH_YES)
5702     {
5703       m = gfc_match_expr (&expr);
5704       if (m == MATCH_NO)
5705         goto syntax;
5706       if (m == MATCH_ERROR)
5707         return MATCH_ERROR;
5708
5709       if (gfc_match_char (')') != MATCH_YES)
5710         goto syntax;
5711     }
5712
5713   if (gfc_match_eos () != MATCH_YES)
5714     {
5715       /* Only makes sense if we have a where-construct-name.  */
5716       if (!gfc_current_block ())
5717         {
5718           m = MATCH_ERROR;
5719           goto cleanup;
5720         }
5721       /* Better be a name at this point.  */
5722       m = gfc_match_name (name);
5723       if (m == MATCH_NO)
5724         goto syntax;
5725       if (m == MATCH_ERROR)
5726         goto cleanup;
5727
5728       if (gfc_match_eos () != MATCH_YES)
5729         goto syntax;
5730
5731       if (strcmp (name, gfc_current_block ()->name) != 0)
5732         {
5733           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
5734                      name, gfc_current_block ()->name);
5735           goto cleanup;
5736         }
5737     }
5738
5739   new_st.op = EXEC_WHERE;
5740   new_st.expr1 = expr;
5741   return MATCH_YES;
5742
5743 syntax:
5744   gfc_syntax_error (ST_ELSEWHERE);
5745
5746 cleanup:
5747   gfc_free_expr (expr);
5748   return MATCH_ERROR;
5749 }