gcc/fortran/match.c

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