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