gcc/fortran/match.c

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