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     {
4540       gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
4541                               &tmp->n.sym->as, false);
4542       tmp->n.sym->attr.class_ok = 1;
4543     }
4544   tmp->n.sym->attr.select_type_temporary = 1;
4545
4546   /* Add an association for it, so the rest of the parser knows it is
4547      an associate-name.  The target will be set during resolution.  */
4548   tmp->n.sym->assoc = gfc_get_association_list ();
4549   tmp->n.sym->assoc->dangling = 1;
4550   tmp->n.sym->assoc->st = tmp;
4551
4552   select_type_stack->tmp = tmp;
4553 }
4554
4555
4556 /* Match a SELECT TYPE statement.  */
4557
4558 match
4559 gfc_match_select_type (void)
4560 {
4561   gfc_expr *expr1, *expr2 = NULL;
4562   match m;
4563   char name[GFC_MAX_SYMBOL_LEN];
4564
4565   m = gfc_match_label ();
4566   if (m == MATCH_ERROR)
4567     return m;
4568
4569   m = gfc_match (" select type ( ");
4570   if (m != MATCH_YES)
4571     return m;
4572
4573   gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
4574
4575   m = gfc_match (" %n => %e", name, &expr2);
4576   if (m == MATCH_YES)
4577     {
4578       expr1 = gfc_get_expr();
4579       expr1->expr_type = EXPR_VARIABLE;
4580       if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
4581         {
4582           m = MATCH_ERROR;
4583           goto cleanup;
4584         }
4585       if (expr2->ts.type == BT_UNKNOWN)
4586         expr1->symtree->n.sym->attr.untyped = 1;
4587       else
4588         expr1->symtree->n.sym->ts = expr2->ts;
4589       expr1->symtree->n.sym->attr.flavor = FL_VARIABLE;
4590       expr1->symtree->n.sym->attr.referenced = 1;
4591       expr1->symtree->n.sym->attr.class_ok = 1;
4592     }
4593   else
4594     {
4595       m = gfc_match (" %e ", &expr1);
4596       if (m != MATCH_YES)
4597         goto cleanup;
4598     }
4599
4600   m = gfc_match (" )%t");
4601   if (m != MATCH_YES)
4602     goto cleanup;
4603
4604   /* Check for F03:C811.  */
4605   if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
4606     {
4607       gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
4608                  "use associate-name=>");
4609       m = MATCH_ERROR;
4610       goto cleanup;
4611     }
4612
4613   new_st.op = EXEC_SELECT_TYPE;
4614   new_st.expr1 = expr1;
4615   new_st.expr2 = expr2;
4616   new_st.ext.block.ns = gfc_current_ns;
4617
4618   select_type_push (expr1->symtree->n.sym);
4619
4620   return MATCH_YES;
4621
4622 cleanup:
4623   gfc_current_ns = gfc_current_ns->parent;
4624   return m;
4625 }
4626
4627
4628 /* Match a CASE statement.  */
4629
4630 match
4631 gfc_match_case (void)
4632 {
4633   gfc_case *c, *head, *tail;
4634   match m;
4635
4636   head = tail = NULL;
4637
4638   if (gfc_current_state () != COMP_SELECT)
4639     {
4640       gfc_error ("Unexpected CASE statement at %C");
4641       return MATCH_ERROR;
4642     }
4643
4644   if (gfc_match ("% default") == MATCH_YES)
4645     {
4646       m = match_case_eos ();
4647       if (m == MATCH_NO)
4648         goto syntax;
4649       if (m == MATCH_ERROR)
4650         goto cleanup;
4651
4652       new_st.op = EXEC_SELECT;
4653       c = gfc_get_case ();
4654       c->where = gfc_current_locus;
4655       new_st.ext.block.case_list = c;
4656       return MATCH_YES;
4657     }
4658
4659   if (gfc_match_char ('(') != MATCH_YES)
4660     goto syntax;
4661
4662   for (;;)
4663     {
4664       if (match_case_selector (&c) == MATCH_ERROR)
4665         goto cleanup;
4666
4667       if (head == NULL)
4668         head = c;
4669       else
4670         tail->next = c;
4671
4672       tail = c;
4673
4674       if (gfc_match_char (')') == MATCH_YES)
4675         break;
4676       if (gfc_match_char (',') != MATCH_YES)
4677         goto syntax;
4678     }
4679
4680   m = match_case_eos ();
4681   if (m == MATCH_NO)
4682     goto syntax;
4683   if (m == MATCH_ERROR)
4684     goto cleanup;
4685
4686   new_st.op = EXEC_SELECT;
4687   new_st.ext.block.case_list = head;
4688
4689   return MATCH_YES;
4690
4691 syntax:
4692   gfc_error ("Syntax error in CASE specification at %C");
4693
4694 cleanup:
4695   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
4696   return MATCH_ERROR;
4697 }
4698
4699
4700 /* Match a TYPE IS statement.  */
4701
4702 match
4703 gfc_match_type_is (void)
4704 {
4705   gfc_case *c = NULL;
4706   match m;
4707
4708   if (gfc_current_state () != COMP_SELECT_TYPE)
4709     {
4710       gfc_error ("Unexpected TYPE IS statement at %C");
4711       return MATCH_ERROR;
4712     }
4713
4714   if (gfc_match_char ('(') != MATCH_YES)
4715     goto syntax;
4716
4717   c = gfc_get_case ();
4718   c->where = gfc_current_locus;
4719
4720   /* TODO: Once unlimited polymorphism is implemented, we will need to call
4721      match_type_spec here.  */
4722   if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
4723     goto cleanup;
4724
4725   if (gfc_match_char (')') != MATCH_YES)
4726     goto syntax;
4727
4728   m = match_case_eos ();
4729   if (m == MATCH_NO)
4730     goto syntax;
4731   if (m == MATCH_ERROR)
4732     goto cleanup;
4733
4734   new_st.op = EXEC_SELECT_TYPE;
4735   new_st.ext.block.case_list = c;
4736
4737   /* Create temporary variable.  */
4738   select_type_set_tmp (&c->ts);
4739
4740   return MATCH_YES;
4741
4742 syntax:
4743   gfc_error ("Syntax error in TYPE IS specification at %C");
4744
4745 cleanup:
4746   if (c != NULL)
4747     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
4748   return MATCH_ERROR;
4749 }
4750
4751
4752 /* Match a CLASS IS or CLASS DEFAULT statement.  */
4753
4754 match
4755 gfc_match_class_is (void)
4756 {
4757   gfc_case *c = NULL;
4758   match m;
4759
4760   if (gfc_current_state () != COMP_SELECT_TYPE)
4761     return MATCH_NO;
4762
4763   if (gfc_match ("% default") == MATCH_YES)
4764     {
4765       m = match_case_eos ();
4766       if (m == MATCH_NO)
4767         goto syntax;
4768       if (m == MATCH_ERROR)
4769         goto cleanup;
4770
4771       new_st.op = EXEC_SELECT_TYPE;
4772       c = gfc_get_case ();
4773       c->where = gfc_current_locus;
4774       c->ts.type = BT_UNKNOWN;
4775       new_st.ext.block.case_list = c;
4776       select_type_set_tmp (NULL);
4777       return MATCH_YES;
4778     }
4779
4780   m = gfc_match ("% is");
4781   if (m == MATCH_NO)
4782     goto syntax;
4783   if (m == MATCH_ERROR)
4784     goto cleanup;
4785
4786   if (gfc_match_char ('(') != MATCH_YES)
4787     goto syntax;
4788
4789   c = gfc_get_case ();
4790   c->where = gfc_current_locus;
4791
4792   if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
4793     goto cleanup;
4794
4795   if (c->ts.type == BT_DERIVED)
4796     c->ts.type = BT_CLASS;
4797
4798   if (gfc_match_char (')') != MATCH_YES)
4799     goto syntax;
4800
4801   m = match_case_eos ();
4802   if (m == MATCH_NO)
4803     goto syntax;
4804   if (m == MATCH_ERROR)
4805     goto cleanup;
4806
4807   new_st.op = EXEC_SELECT_TYPE;
4808   new_st.ext.block.case_list = c;
4809
4810   /* Create temporary variable.  */
4811   select_type_set_tmp (&c->ts);
4812
4813   return MATCH_YES;
4814
4815 syntax:
4816   gfc_error ("Syntax error in CLASS IS specification at %C");
4817
4818 cleanup:
4819   if (c != NULL)
4820     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
4821   return MATCH_ERROR;
4822 }
4823
4824
4825 /********************* WHERE subroutines ********************/
4826
4827 /* Match the rest of a simple WHERE statement that follows an IF statement.
4828  */
4829
4830 static match
4831 match_simple_where (void)
4832 {
4833   gfc_expr *expr;
4834   gfc_code *c;
4835   match m;
4836
4837   m = gfc_match (" ( %e )", &expr);
4838   if (m != MATCH_YES)
4839     return m;
4840
4841   m = gfc_match_assignment ();
4842   if (m == MATCH_NO)
4843     goto syntax;
4844   if (m == MATCH_ERROR)
4845     goto cleanup;
4846
4847   if (gfc_match_eos () != MATCH_YES)
4848     goto syntax;
4849
4850   c = gfc_get_code ();
4851
4852   c->op = EXEC_WHERE;
4853   c->expr1 = expr;
4854   c->next = gfc_get_code ();
4855
4856   *c->next = new_st;
4857   gfc_clear_new_st ();
4858
4859   new_st.op = EXEC_WHERE;
4860   new_st.block = c;
4861
4862   return MATCH_YES;
4863
4864 syntax:
4865   gfc_syntax_error (ST_WHERE);
4866
4867 cleanup:
4868   gfc_free_expr (expr);
4869   return MATCH_ERROR;
4870 }
4871
4872
4873 /* Match a WHERE statement.  */
4874
4875 match
4876 gfc_match_where (gfc_statement *st)
4877 {
4878   gfc_expr *expr;
4879   match m0, m;
4880   gfc_code *c;
4881
4882   m0 = gfc_match_label ();
4883   if (m0 == MATCH_ERROR)
4884     return m0;
4885
4886   m = gfc_match (" where ( %e )", &expr);
4887   if (m != MATCH_YES)
4888     return m;
4889
4890   if (gfc_match_eos () == MATCH_YES)
4891     {
4892       *st = ST_WHERE_BLOCK;
4893       new_st.op = EXEC_WHERE;
4894       new_st.expr1 = expr;
4895       return MATCH_YES;
4896     }
4897
4898   m = gfc_match_assignment ();
4899   if (m == MATCH_NO)
4900     gfc_syntax_error (ST_WHERE);
4901
4902   if (m != MATCH_YES)
4903     {
4904       gfc_free_expr (expr);
4905       return MATCH_ERROR;
4906     }
4907
4908   /* We've got a simple WHERE statement.  */
4909   *st = ST_WHERE;
4910   c = gfc_get_code ();
4911
4912   c->op = EXEC_WHERE;
4913   c->expr1 = expr;
4914   c->next = gfc_get_code ();
4915
4916   *c->next = new_st;
4917   gfc_clear_new_st ();
4918
4919   new_st.op = EXEC_WHERE;
4920   new_st.block = c;
4921
4922   return MATCH_YES;
4923 }
4924
4925
4926 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
4927    new_st if successful.  */
4928
4929 match
4930 gfc_match_elsewhere (void)
4931 {
4932   char name[GFC_MAX_SYMBOL_LEN + 1];
4933   gfc_expr *expr;
4934   match m;
4935
4936   if (gfc_current_state () != COMP_WHERE)
4937     {
4938       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
4939       return MATCH_ERROR;
4940     }
4941
4942   expr = NULL;
4943
4944   if (gfc_match_char ('(') == MATCH_YES)
4945     {
4946       m = gfc_match_expr (&expr);
4947       if (m == MATCH_NO)
4948         goto syntax;
4949       if (m == MATCH_ERROR)
4950         return MATCH_ERROR;
4951
4952       if (gfc_match_char (')') != MATCH_YES)
4953         goto syntax;
4954     }
4955
4956   if (gfc_match_eos () != MATCH_YES)
4957     {
4958       /* Only makes sense if we have a where-construct-name.  */
4959       if (!gfc_current_block ())
4960         {
4961           m = MATCH_ERROR;
4962           goto cleanup;
4963         }
4964       /* Better be a name at this point.  */
4965       m = gfc_match_name (name);
4966       if (m == MATCH_NO)
4967         goto syntax;
4968       if (m == MATCH_ERROR)
4969         goto cleanup;
4970
4971       if (gfc_match_eos () != MATCH_YES)
4972         goto syntax;
4973
4974       if (strcmp (name, gfc_current_block ()->name) != 0)
4975         {
4976           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
4977                      name, gfc_current_block ()->name);
4978           goto cleanup;
4979         }
4980     }
4981
4982   new_st.op = EXEC_WHERE;
4983   new_st.expr1 = expr;
4984   return MATCH_YES;
4985
4986 syntax:
4987   gfc_syntax_error (ST_ELSEWHERE);
4988
4989 cleanup:
4990   gfc_free_expr (expr);
4991   return MATCH_ERROR;
4992 }
4993
4994
4995 /******************** FORALL subroutines ********************/
4996
4997 /* Free a list of FORALL iterators.  */
4998
4999 void
5000 gfc_free_forall_iterator (gfc_forall_iterator *iter)
5001 {
5002   gfc_forall_iterator *next;
5003
5004   while (iter)
5005     {
5006       next = iter->next;
5007       gfc_free_expr (iter->var);
5008       gfc_free_expr (iter->start);
5009       gfc_free_expr (iter->end);
5010       gfc_free_expr (iter->stride);
5011       gfc_free (iter);
5012       iter = next;
5013     }
5014 }
5015
5016
5017 /* Match an iterator as part of a FORALL statement.  The format is:
5018
5019      <var> = <start>:<end>[:<stride>]
5020
5021    On MATCH_NO, the caller tests for the possibility that there is a
5022    scalar mask expression.  */
5023
5024 static match
5025 match_forall_iterator (gfc_forall_iterator **result)
5026 {
5027   gfc_forall_iterator *iter;
5028   locus where;
5029   match m;
5030
5031   where = gfc_current_locus;
5032   iter = XCNEW (gfc_forall_iterator);
5033
5034   m = gfc_match_expr (&iter->var);
5035   if (m != MATCH_YES)
5036     goto cleanup;
5037
5038   if (gfc_match_char ('=') != MATCH_YES
5039       || iter->var->expr_type != EXPR_VARIABLE)
5040     {
5041       m = MATCH_NO;
5042       goto cleanup;
5043     }
5044
5045   m = gfc_match_expr (&iter->start);
5046   if (m != MATCH_YES)
5047     goto cleanup;
5048
5049   if (gfc_match_char (':') != MATCH_YES)
5050     goto syntax;
5051
5052   m = gfc_match_expr (&iter->end);
5053   if (m == MATCH_NO)
5054     goto syntax;
5055   if (m == MATCH_ERROR)
5056     goto cleanup;
5057
5058   if (gfc_match_char (':') == MATCH_NO)
5059     iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
5060   else
5061     {
5062       m = gfc_match_expr (&iter->stride);
5063       if (m == MATCH_NO)
5064         goto syntax;
5065       if (m == MATCH_ERROR)
5066         goto cleanup;
5067     }
5068
5069   /* Mark the iteration variable's symbol as used as a FORALL index.  */
5070   iter->var->symtree->n.sym->forall_index = true;
5071
5072   *result = iter;
5073   return MATCH_YES;
5074
5075 syntax:
5076   gfc_error ("Syntax error in FORALL iterator at %C");
5077   m = MATCH_ERROR;
5078
5079 cleanup:
5080
5081   gfc_current_locus = where;
5082   gfc_free_forall_iterator (iter);
5083   return m;
5084 }
5085
5086
5087 /* Match the header of a FORALL statement.  */
5088
5089 static match
5090 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
5091 {
5092   gfc_forall_iterator *head, *tail, *new_iter;
5093   gfc_expr *msk;
5094   match m;
5095
5096   gfc_gobble_whitespace ();
5097
5098   head = tail = NULL;
5099   msk = NULL;
5100
5101   if (gfc_match_char ('(') != MATCH_YES)
5102     return MATCH_NO;
5103
5104   m = match_forall_iterator (&new_iter);
5105   if (m == MATCH_ERROR)
5106     goto cleanup;
5107   if (m == MATCH_NO)
5108     goto syntax;
5109
5110   head = tail = new_iter;
5111
5112   for (;;)
5113     {
5114       if (gfc_match_char (',') != MATCH_YES)
5115         break;
5116
5117       m = match_forall_iterator (&new_iter);
5118       if (m == MATCH_ERROR)
5119         goto cleanup;
5120
5121       if (m == MATCH_YES)
5122         {
5123           tail->next = new_iter;
5124           tail = new_iter;
5125           continue;
5126         }
5127
5128       /* Have to have a mask expression.  */
5129
5130       m = gfc_match_expr (&msk);
5131       if (m == MATCH_NO)
5132         goto syntax;
5133       if (m == MATCH_ERROR)
5134         goto cleanup;
5135
5136       break;
5137     }
5138
5139   if (gfc_match_char (')') == MATCH_NO)
5140     goto syntax;
5141
5142   *phead = head;
5143   *mask = msk;
5144   return MATCH_YES;
5145
5146 syntax:
5147   gfc_syntax_error (ST_FORALL);
5148
5149 cleanup:
5150   gfc_free_expr (msk);
5151   gfc_free_forall_iterator (head);
5152
5153   return MATCH_ERROR;
5154 }
5155
5156 /* Match the rest of a simple FORALL statement that follows an
5157    IF statement.  */
5158
5159 static match
5160 match_simple_forall (void)
5161 {
5162   gfc_forall_iterator *head;
5163   gfc_expr *mask;
5164   gfc_code *c;
5165   match m;
5166
5167   mask = NULL;
5168   head = NULL;
5169   c = NULL;
5170
5171   m = match_forall_header (&head, &mask);
5172
5173   if (m == MATCH_NO)
5174     goto syntax;
5175   if (m != MATCH_YES)
5176     goto cleanup;
5177
5178   m = gfc_match_assignment ();
5179
5180   if (m == MATCH_ERROR)
5181     goto cleanup;
5182   if (m == MATCH_NO)
5183     {
5184       m = gfc_match_pointer_assignment ();
5185       if (m == MATCH_ERROR)
5186         goto cleanup;
5187       if (m == MATCH_NO)
5188         goto syntax;
5189     }
5190
5191   c = gfc_get_code ();
5192   *c = new_st;
5193   c->loc = gfc_current_locus;
5194
5195   if (gfc_match_eos () != MATCH_YES)
5196     goto syntax;
5197
5198   gfc_clear_new_st ();
5199   new_st.op = EXEC_FORALL;
5200   new_st.expr1 = mask;
5201   new_st.ext.forall_iterator = head;
5202   new_st.block = gfc_get_code ();
5203
5204   new_st.block->op = EXEC_FORALL;
5205   new_st.block->next = c;
5206
5207   return MATCH_YES;
5208
5209 syntax:
5210   gfc_syntax_error (ST_FORALL);
5211
5212 cleanup:
5213   gfc_free_forall_iterator (head);
5214   gfc_free_expr (mask);
5215
5216   return MATCH_ERROR;
5217 }
5218
5219
5220 /* Match a FORALL statement.  */
5221
5222 match
5223 gfc_match_forall (gfc_statement *st)
5224 {
5225   gfc_forall_iterator *head;
5226   gfc_expr *mask;
5227   gfc_code *c;
5228   match m0, m;
5229
5230   head = NULL;
5231   mask = NULL;
5232   c = NULL;
5233
5234   m0 = gfc_match_label ();
5235   if (m0 == MATCH_ERROR)
5236     return MATCH_ERROR;
5237
5238   m = gfc_match (" forall");
5239   if (m != MATCH_YES)
5240     return m;
5241
5242   m = match_forall_header (&head, &mask);
5243   if (m == MATCH_ERROR)
5244     goto cleanup;
5245   if (m == MATCH_NO)
5246     goto syntax;
5247
5248   if (gfc_match_eos () == MATCH_YES)
5249     {
5250       *st = ST_FORALL_BLOCK;
5251       new_st.op = EXEC_FORALL;
5252       new_st.expr1 = mask;
5253       new_st.ext.forall_iterator = head;
5254       return MATCH_YES;
5255     }
5256
5257   m = gfc_match_assignment ();
5258   if (m == MATCH_ERROR)
5259     goto cleanup;
5260   if (m == MATCH_NO)
5261     {
5262       m = gfc_match_pointer_assignment ();
5263       if (m == MATCH_ERROR)
5264         goto cleanup;
5265       if (m == MATCH_NO)
5266         goto syntax;
5267     }
5268
5269   c = gfc_get_code ();
5270   *c = new_st;
5271   c->loc = gfc_current_locus;
5272
5273   gfc_clear_new_st ();
5274   new_st.op = EXEC_FORALL;
5275   new_st.expr1 = mask;
5276   new_st.ext.forall_iterator = head;
5277   new_st.block = gfc_get_code ();
5278   new_st.block->op = EXEC_FORALL;
5279   new_st.block->next = c;
5280
5281   *st = ST_FORALL;
5282   return MATCH_YES;
5283
5284 syntax:
5285   gfc_syntax_error (ST_FORALL);
5286
5287 cleanup:
5288   gfc_free_forall_iterator (head);
5289   gfc_free_expr (mask);
5290   gfc_free_statements (c);
5291   return MATCH_NO;
5292 }