gcc/fortran/match.c

   1 /* Matching subroutines in all sizes, shapes and colors.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
   3    2009, 2010, 2011, 2012
   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 #include "tree.h"
  30
  31 int gfc_matching_ptr_assignment = 0;
  32 int gfc_matching_procptr_assignment = 0;
  33 bool gfc_matching_prefix = false;
  34
  35 /* Stack of SELECT TYPE statements.  */
  36 gfc_select_type_stack *select_type_stack = NULL;
  37
  38 /* For debugging and diagnostic purposes.  Return the textual representation
  39    of the intrinsic operator OP.  */
  40 const char *
  41 gfc_op2string (gfc_intrinsic_op op)
  42 {
  43   switch (op)
  44     {
  45     case INTRINSIC_UPLUS:
  46     case INTRINSIC_PLUS:
  47       return "+";
  48
  49     case INTRINSIC_UMINUS:
  50     case INTRINSIC_MINUS:
  51       return "-";
  52
  53     case INTRINSIC_POWER:
  54       return "**";
  55     case INTRINSIC_CONCAT:
  56       return "//";
  57     case INTRINSIC_TIMES:
  58       return "*";
  59     case INTRINSIC_DIVIDE:
  60       return "/";
  61
  62     case INTRINSIC_AND:
  63       return ".and.";
  64     case INTRINSIC_OR:
  65       return ".or.";
  66     case INTRINSIC_EQV:
  67       return ".eqv.";
  68     case INTRINSIC_NEQV:
  69       return ".neqv.";
  70
  71     case INTRINSIC_EQ_OS:
  72       return ".eq.";
  73     case INTRINSIC_EQ:
  74       return "==";
  75     case INTRINSIC_NE_OS:
  76       return ".ne.";
  77     case INTRINSIC_NE:
  78       return "/=";
  79     case INTRINSIC_GE_OS:
  80       return ".ge.";
  81     case INTRINSIC_GE:
  82       return ">=";
  83     case INTRINSIC_LE_OS:
  84       return ".le.";
  85     case INTRINSIC_LE:
  86       return "<=";
  87     case INTRINSIC_LT_OS:
  88       return ".lt.";
  89     case INTRINSIC_LT:
  90       return "<";
  91     case INTRINSIC_GT_OS:
  92       return ".gt.";
  93     case INTRINSIC_GT:
  94       return ">";
  95     case INTRINSIC_NOT:
  96       return ".not.";
  97
  98     case INTRINSIC_ASSIGN:
  99       return "=";
 100
 101     case INTRINSIC_PARENTHESES:
 102       return "parens";
 103
 104     default:
 105       break;
 106     }
 107
 108   gfc_internal_error ("gfc_op2string(): Bad code");
 109   /* Not reached.  */
 110 }
 111
 112
 113 /******************** Generic matching subroutines ************************/
 114
 115 /* This function scans the current statement counting the opened and closed
 116    parenthesis to make sure they are balanced.  */
 117
 118 match
 119 gfc_match_parens (void)
 120 {
 121   locus old_loc, where;
 122   int count;
 123   gfc_instring instring;
 124   gfc_char_t c, quote;
 125
 126   old_loc = gfc_current_locus;
 127   count = 0;
 128   instring = NONSTRING;
 129   quote = ' ';
 130
 131   for (;;)
 132     {
 133       c = gfc_next_char_literal (instring);
 134       if (c == '\n')
 135         break;
 136       if (quote == ' ' && ((c == '\'') || (c == '"')))
 137         {
 138           quote = c;
 139           instring = INSTRING_WARN;
 140           continue;
 141         }
 142       if (quote != ' ' && c == quote)
 143         {
 144           quote = ' ';
 145           instring = NONSTRING;
 146           continue;
 147         }
 148
 149       if (c == '(' && quote == ' ')
 150         {
 151           count++;
 152           where = gfc_current_locus;
 153         }
 154       if (c == ')' && quote == ' ')
 155         {
 156           count--;
 157           where = gfc_current_locus;
 158         }
 159     }
 160
 161   gfc_current_locus = old_loc;
 162
 163   if (count > 0)
 164     {
 165       gfc_error ("Missing ')' in statement at or before %L", &where);
 166       return MATCH_ERROR;
 167     }
 168   if (count < 0)
 169     {
 170       gfc_error ("Missing '(' in statement at or before %L", &where);
 171       return MATCH_ERROR;
 172     }
 173
 174   return MATCH_YES;
 175 }
 176
 177
 178 /* See if the next character is a special character that has
 179    escaped by a \ via the -fbackslash option.  */
 180
 181 match
 182 gfc_match_special_char (gfc_char_t *res)
 183 {
 184   int len, i;
 185   gfc_char_t c, n;
 186   match m;
 187
 188   m = MATCH_YES;
 189
 190   switch ((c = gfc_next_char_literal (INSTRING_WARN)))
 191     {
 192     case 'a':
 193       *res = '\a';
 194       break;
 195     case 'b':
 196       *res = '\b';
 197       break;
 198     case 't':
 199       *res = '\t';
 200       break;
 201     case 'f':
 202       *res = '\f';
 203       break;
 204     case 'n':
 205       *res = '\n';
 206       break;
 207     case 'r':
 208       *res = '\r';
 209       break;
 210     case 'v':
 211       *res = '\v';
 212       break;
 213     case '\\':
 214       *res = '\\';
 215       break;
 216     case '0':
 217       *res = '\0';
 218       break;
 219
 220     case 'x':
 221     case 'u':
 222     case 'U':
 223       /* Hexadecimal form of wide characters.  */
 224       len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
 225       n = 0;
 226       for (i = 0; i < len; i++)
 227         {
 228           char buf[2] = { '\0', '\0' };
 229
 230           c = gfc_next_char_literal (INSTRING_WARN);
 231           if (!gfc_wide_fits_in_byte (c)
 232               || !gfc_check_digit ((unsigned char) c, 16))
 233             return MATCH_NO;
 234
 235           buf[0] = (unsigned char) c;
 236           n = n << 4;
 237           n += strtol (buf, NULL, 16);
 238         }
 239       *res = n;
 240       break;
 241
 242     default:
 243       /* Unknown backslash codes are simply not expanded.  */
 244       m = MATCH_NO;
 245       break;
 246     }
 247
 248   return m;
 249 }
 250
 251
 252 /* In free form, match at least one space.  Always matches in fixed
 253    form.  */
 254
 255 match
 256 gfc_match_space (void)
 257 {
 258   locus old_loc;
 259   char c;
 260
 261   if (gfc_current_form == FORM_FIXED)
 262     return MATCH_YES;
 263
 264   old_loc = gfc_current_locus;
 265
 266   c = gfc_next_ascii_char ();
 267   if (!gfc_is_whitespace (c))
 268     {
 269       gfc_current_locus = old_loc;
 270       return MATCH_NO;
 271     }
 272
 273   gfc_gobble_whitespace ();
 274
 275   return MATCH_YES;
 276 }
 277
 278
 279 /* Match an end of statement.  End of statement is optional
 280    whitespace, followed by a ';' or '\n' or comment '!'.  If a
 281    semicolon is found, we continue to eat whitespace and semicolons.  */
 282
 283 match
 284 gfc_match_eos (void)
 285 {
 286   locus old_loc;
 287   int flag;
 288   char c;
 289
 290   flag = 0;
 291
 292   for (;;)
 293     {
 294       old_loc = gfc_current_locus;
 295       gfc_gobble_whitespace ();
 296
 297       c = gfc_next_ascii_char ();
 298       switch (c)
 299         {
 300         case '!':
 301           do
 302             {
 303               c = gfc_next_ascii_char ();
 304             }
 305           while (c != '\n');
 306
 307           /* Fall through.  */
 308
 309         case '\n':
 310           return MATCH_YES;
 311
 312         case ';':
 313           flag = 1;
 314           continue;
 315         }
 316
 317       break;
 318     }
 319
 320   gfc_current_locus = old_loc;
 321   return (flag) ? MATCH_YES : MATCH_NO;
 322 }
 323
 324
 325 /* Match a literal integer on the input, setting the value on
 326    MATCH_YES.  Literal ints occur in kind-parameters as well as
 327    old-style character length specifications.  If cnt is non-NULL it
 328    will be set to the number of digits.  */
 329
 330 match
 331 gfc_match_small_literal_int (int *value, int *cnt)
 332 {
 333   locus old_loc;
 334   char c;
 335   int i, j;
 336
 337   old_loc = gfc_current_locus;
 338
 339   *value = -1;
 340   gfc_gobble_whitespace ();
 341   c = gfc_next_ascii_char ();
 342   if (cnt)
 343     *cnt = 0;
 344
 345   if (!ISDIGIT (c))
 346     {
 347       gfc_current_locus = old_loc;
 348       return MATCH_NO;
 349     }
 350
 351   i = c - '0';
 352   j = 1;
 353
 354   for (;;)
 355     {
 356       old_loc = gfc_current_locus;
 357       c = gfc_next_ascii_char ();
 358
 359       if (!ISDIGIT (c))
 360         break;
 361
 362       i = 10 * i + c - '0';
 363       j++;
 364
 365       if (i > 99999999)
 366         {
 367           gfc_error ("Integer too large at %C");
 368           return MATCH_ERROR;
 369         }
 370     }
 371
 372   gfc_current_locus = old_loc;
 373
 374   *value = i;
 375   if (cnt)
 376     *cnt = j;
 377   return MATCH_YES;
 378 }
 379
 380
 381 /* Match a small, constant integer expression, like in a kind
 382    statement.  On MATCH_YES, 'value' is set.  */
 383
 384 match
 385 gfc_match_small_int (int *value)
 386 {
 387   gfc_expr *expr;
 388   const char *p;
 389   match m;
 390   int i;
 391
 392   m = gfc_match_expr (&expr);
 393   if (m != MATCH_YES)
 394     return m;
 395
 396   p = gfc_extract_int (expr, &i);
 397   gfc_free_expr (expr);
 398
 399   if (p != NULL)
 400     {
 401       gfc_error (p);
 402       m = MATCH_ERROR;
 403     }
 404
 405   *value = i;
 406   return m;
 407 }
 408
 409
 410 /* This function is the same as the gfc_match_small_int, except that
 411    we're keeping the pointer to the expr.  This function could just be
 412    removed and the previously mentioned one modified, though all calls
 413    to it would have to be modified then (and there were a number of
 414    them).  Return MATCH_ERROR if fail to extract the int; otherwise,
 415    return the result of gfc_match_expr().  The expr (if any) that was
 416    matched is returned in the parameter expr.  */
 417
 418 match
 419 gfc_match_small_int_expr (int *value, gfc_expr **expr)
 420 {
 421   const char *p;
 422   match m;
 423   int i;
 424
 425   m = gfc_match_expr (expr);
 426   if (m != MATCH_YES)
 427     return m;
 428
 429   p = gfc_extract_int (*expr, &i);
 430
 431   if (p != NULL)
 432     {
 433       gfc_error (p);
 434       m = MATCH_ERROR;
 435     }
 436
 437   *value = i;
 438   return m;
 439 }
 440
 441
 442 /* Matches a statement label.  Uses gfc_match_small_literal_int() to
 443    do most of the work.  */
 444
 445 match
 446 gfc_match_st_label (gfc_st_label **label)
 447 {
 448   locus old_loc;
 449   match m;
 450   int i, cnt;
 451
 452   old_loc = gfc_current_locus;
 453
 454   m = gfc_match_small_literal_int (&i, &cnt);
 455   if (m != MATCH_YES)
 456     return m;
 457
 458   if (cnt > 5)
 459     {
 460       gfc_error ("Too many digits in statement label at %C");
 461       goto cleanup;
 462     }
 463
 464   if (i == 0)
 465     {
 466       gfc_error ("Statement label at %C is zero");
 467       goto cleanup;
 468     }
 469
 470   *label = gfc_get_st_label (i);
 471   return MATCH_YES;
 472
 473 cleanup:
 474
 475   gfc_current_locus = old_loc;
 476   return MATCH_ERROR;
 477 }
 478
 479
 480 /* Match and validate a label associated with a named IF, DO or SELECT
 481    statement.  If the symbol does not have the label attribute, we add
 482    it.  We also make sure the symbol does not refer to another
 483    (active) block.  A matched label is pointed to by gfc_new_block.  */
 484
 485 match
 486 gfc_match_label (void)
 487 {
 488   char name[GFC_MAX_SYMBOL_LEN + 1];
 489   match m;
 490
 491   gfc_new_block = NULL;
 492
 493   m = gfc_match (" %n :", name);
 494   if (m != MATCH_YES)
 495     return m;
 496
 497   if (gfc_get_symbol (name, NULL, &gfc_new_block))
 498     {
 499       gfc_error ("Label name '%s' at %C is ambiguous", name);
 500       return MATCH_ERROR;
 501     }
 502
 503   if (gfc_new_block->attr.flavor == FL_LABEL)
 504     {
 505       gfc_error ("Duplicate construct label '%s' at %C", name);
 506       return MATCH_ERROR;
 507     }
 508
 509   if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
 510                       gfc_new_block->name, NULL) == FAILURE)
 511     return MATCH_ERROR;
 512
 513   return MATCH_YES;
 514 }
 515
 516
 517 /* See if the current input looks like a name of some sort.  Modifies
 518    the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
 519    Note that options.c restricts max_identifier_length to not more
 520    than GFC_MAX_SYMBOL_LEN.  */
 521
 522 match
 523 gfc_match_name (char *buffer)
 524 {
 525   locus old_loc;
 526   int i;
 527   char c;
 528
 529   old_loc = gfc_current_locus;
 530   gfc_gobble_whitespace ();
 531
 532   c = gfc_next_ascii_char ();
 533   if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
 534     {
 535       if (gfc_error_flag_test() == 0 && c != '(')
 536         gfc_error ("Invalid character in name at %C");
 537       gfc_current_locus = old_loc;
 538       return MATCH_NO;
 539     }
 540
 541   i = 0;
 542
 543   do
 544     {
 545       buffer[i++] = c;
 546
 547       if (i > gfc_option.max_identifier_length)
 548         {
 549           gfc_error ("Name at %C is too long");
 550           return MATCH_ERROR;
 551         }
 552
 553       old_loc = gfc_current_locus;
 554       c = gfc_next_ascii_char ();
 555     }
 556   while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
 557
 558   if (c == '$' && !gfc_option.flag_dollar_ok)
 559     {
 560       gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it "
 561                  "as an extension");
 562       return MATCH_ERROR;
 563     }
 564
 565   buffer[i] = '\0';
 566   gfc_current_locus = old_loc;
 567
 568   return MATCH_YES;
 569 }
 570
 571
 572 /* Match a valid name for C, which is almost the same as for Fortran,
 573    except that you can start with an underscore, etc..  It could have
 574    been done by modifying the gfc_match_name, but this way other
 575    things C allows can be done, such as no limits on the length.
 576    Also, by rewriting it, we use the gfc_next_char_C() to prevent the
 577    input characters from being automatically lower cased, since C is
 578    case sensitive.  The parameter, buffer, is used to return the name
 579    that is matched.  Return MATCH_ERROR if the name is not a valid C
 580    name, MATCH_NO if what we're seeing isn't a name, and MATCH_YES if
 581    we successfully match a C name.  */
 582
 583 match
 584 gfc_match_name_C (const char **buffer)
 585 {
 586   locus old_loc;
 587   size_t i = 0;
 588   gfc_char_t c;
 589   char* buf;
 590   size_t cursz = 16;
 591
 592   old_loc = gfc_current_locus;
 593   gfc_gobble_whitespace ();
 594
 595   /* Get the next char (first possible char of name) and see if
 596      it's valid for C (either a letter or an underscore).  */
 597   c = gfc_next_char_literal (INSTRING_WARN);
 598
 599   /* If the user put nothing expect spaces between the quotes, it is valid
 600      and simply means there is no name= specifier and the name is the fortran
 601      symbol name, all lowercase.  */
 602   if (c == '"' || c == '\'')
 603     {
 604       gfc_current_locus = old_loc;
 605       return MATCH_YES;
 606     }
 607
 608   if (!ISALPHA (c) && c != '_')
 609     {
 610       gfc_error ("Invalid C name in NAME= specifier at %C");
 611       return MATCH_ERROR;
 612     }
 613
 614   buf = XNEWVEC (char, cursz);
 615   /* Continue to read valid variable name characters.  */
 616   do
 617     {
 618       gcc_assert (gfc_wide_fits_in_byte (c));
 619
 620       buf[i++] = (unsigned char) c;
 621
 622       if (i >= cursz)
 623         {
 624           cursz *= 2;
 625           buf = XRESIZEVEC (char, buf, cursz);
 626         }
 627
 628       old_loc = gfc_current_locus;
 629
 630       /* Get next char; param means we're in a string.  */
 631       c = gfc_next_char_literal (INSTRING_WARN);
 632     } while (ISALNUM (c) || c == '_');
 633
 634   /* The binding label will be needed later anyway, so just insert it
 635      into the symbol table.  */
 636   buf[i] = '\0';
 637   *buffer = IDENTIFIER_POINTER (get_identifier (buf));
 638   XDELETEVEC (buf);
 639   gfc_current_locus = old_loc;
 640
 641   /* See if we stopped because of whitespace.  */
 642   if (c == ' ')
 643     {
 644       gfc_gobble_whitespace ();
 645       c = gfc_peek_ascii_char ();
 646       if (c != '"' && c != '\'')
 647         {
 648           gfc_error ("Embedded space in NAME= specifier at %C");
 649           return MATCH_ERROR;
 650         }
 651     }
 652
 653   /* If we stopped because we had an invalid character for a C name, report
 654      that to the user by returning MATCH_NO.  */
 655   if (c != '"' && c != '\'')
 656     {
 657       gfc_error ("Invalid C name in NAME= specifier at %C");
 658       return MATCH_ERROR;
 659     }
 660
 661   return MATCH_YES;
 662 }
 663
 664
 665 /* Match a symbol on the input.  Modifies the pointer to the symbol
 666    pointer if successful.  */
 667
 668 match
 669 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
 670 {
 671   char buffer[GFC_MAX_SYMBOL_LEN + 1];
 672   match m;
 673
 674   m = gfc_match_name (buffer);
 675   if (m != MATCH_YES)
 676     return m;
 677
 678   if (host_assoc)
 679     return (gfc_get_ha_sym_tree (buffer, matched_symbol))
 680             ? MATCH_ERROR : MATCH_YES;
 681
 682   if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false))
 683     return MATCH_ERROR;
 684
 685   return MATCH_YES;
 686 }
 687
 688
 689 match
 690 gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
 691 {
 692   gfc_symtree *st;
 693   match m;
 694
 695   m = gfc_match_sym_tree (&st, host_assoc);
 696
 697   if (m == MATCH_YES)
 698     {
 699       if (st)
 700         *matched_symbol = st->n.sym;
 701       else
 702         *matched_symbol = NULL;
 703     }
 704   else
 705     *matched_symbol = NULL;
 706   return m;
 707 }
 708
 709
 710 /* Match an intrinsic operator.  Returns an INTRINSIC enum. While matching,
 711    we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
 712    in matchexp.c.  */
 713
 714 match
 715 gfc_match_intrinsic_op (gfc_intrinsic_op *result)
 716 {
 717   locus orig_loc = gfc_current_locus;
 718   char ch;
 719
 720   gfc_gobble_whitespace ();
 721   ch = gfc_next_ascii_char ();
 722   switch (ch)
 723     {
 724     case '+':
 725       /* Matched "+".  */
 726       *result = INTRINSIC_PLUS;
 727       return MATCH_YES;
 728
 729     case '-':
 730       /* Matched "-".  */
 731       *result = INTRINSIC_MINUS;
 732       return MATCH_YES;
 733
 734     case '=':
 735       if (gfc_next_ascii_char () == '=')
 736         {
 737           /* Matched "==".  */
 738           *result = INTRINSIC_EQ;
 739           return MATCH_YES;
 740         }
 741       break;
 742
 743     case '<':
 744       if (gfc_peek_ascii_char () == '=')
 745         {
 746           /* Matched "<=".  */
 747           gfc_next_ascii_char ();
 748           *result = INTRINSIC_LE;
 749           return MATCH_YES;
 750         }
 751       /* Matched "<".  */
 752       *result = INTRINSIC_LT;
 753       return MATCH_YES;
 754
 755     case '>':
 756       if (gfc_peek_ascii_char () == '=')
 757         {
 758           /* Matched ">=".  */
 759           gfc_next_ascii_char ();
 760           *result = INTRINSIC_GE;
 761           return MATCH_YES;
 762         }
 763       /* Matched ">".  */
 764       *result = INTRINSIC_GT;
 765       return MATCH_YES;
 766
 767     case '*':
 768       if (gfc_peek_ascii_char () == '*')
 769         {
 770           /* Matched "**".  */
 771           gfc_next_ascii_char ();
 772           *result = INTRINSIC_POWER;
 773           return MATCH_YES;
 774         }
 775       /* Matched "*".  */
 776       *result = INTRINSIC_TIMES;
 777       return MATCH_YES;
 778
 779     case '/':
 780       ch = gfc_peek_ascii_char ();
 781       if (ch == '=')
 782         {
 783           /* Matched "/=".  */
 784           gfc_next_ascii_char ();
 785           *result = INTRINSIC_NE;
 786           return MATCH_YES;
 787         }
 788       else if (ch == '/')
 789         {
 790           /* Matched "//".  */
 791           gfc_next_ascii_char ();
 792           *result = INTRINSIC_CONCAT;
 793           return MATCH_YES;
 794         }
 795       /* Matched "/".  */
 796       *result = INTRINSIC_DIVIDE;
 797       return MATCH_YES;
 798
 799     case '.':
 800       ch = gfc_next_ascii_char ();
 801       switch (ch)
 802         {
 803         case 'a':
 804           if (gfc_next_ascii_char () == 'n'
 805               && gfc_next_ascii_char () == 'd'
 806               && gfc_next_ascii_char () == '.')
 807             {
 808               /* Matched ".and.".  */
 809               *result = INTRINSIC_AND;
 810               return MATCH_YES;
 811             }
 812           break;
 813
 814         case 'e':
 815           if (gfc_next_ascii_char () == 'q')
 816             {
 817               ch = gfc_next_ascii_char ();
 818               if (ch == '.')
 819                 {
 820                   /* Matched ".eq.".  */
 821                   *result = INTRINSIC_EQ_OS;
 822                   return MATCH_YES;
 823                 }
 824               else if (ch == 'v')
 825                 {
 826                   if (gfc_next_ascii_char () == '.')
 827                     {
 828                       /* Matched ".eqv.".  */
 829                       *result = INTRINSIC_EQV;
 830                       return MATCH_YES;
 831                     }
 832                 }
 833             }
 834           break;
 835
 836         case 'g':
 837           ch = gfc_next_ascii_char ();
 838           if (ch == 'e')
 839             {
 840               if (gfc_next_ascii_char () == '.')
 841                 {
 842                   /* Matched ".ge.".  */
 843                   *result = INTRINSIC_GE_OS;
 844                   return MATCH_YES;
 845                 }
 846             }
 847           else if (ch == 't')
 848             {
 849               if (gfc_next_ascii_char () == '.')
 850                 {
 851                   /* Matched ".gt.".  */
 852                   *result = INTRINSIC_GT_OS;
 853                   return MATCH_YES;
 854                 }
 855             }
 856           break;
 857
 858         case 'l':
 859           ch = gfc_next_ascii_char ();
 860           if (ch == 'e')
 861             {
 862               if (gfc_next_ascii_char () == '.')
 863                 {
 864                   /* Matched ".le.".  */
 865                   *result = INTRINSIC_LE_OS;
 866                   return MATCH_YES;
 867                 }
 868             }
 869           else if (ch == 't')
 870             {
 871               if (gfc_next_ascii_char () == '.')
 872                 {
 873                   /* Matched ".lt.".  */
 874                   *result = INTRINSIC_LT_OS;
 875                   return MATCH_YES;
 876                 }
 877             }
 878           break;
 879
 880         case 'n':
 881           ch = gfc_next_ascii_char ();
 882           if (ch == 'e')
 883             {
 884               ch = gfc_next_ascii_char ();
 885               if (ch == '.')
 886                 {
 887                   /* Matched ".ne.".  */
 888                   *result = INTRINSIC_NE_OS;
 889                   return MATCH_YES;
 890                 }
 891               else if (ch == 'q')
 892                 {
 893                   if (gfc_next_ascii_char () == 'v'
 894                       && gfc_next_ascii_char () == '.')
 895                     {
 896                       /* Matched ".neqv.".  */
 897                       *result = INTRINSIC_NEQV;
 898                       return MATCH_YES;
 899                     }
 900                 }
 901             }
 902           else if (ch == 'o')
 903             {
 904               if (gfc_next_ascii_char () == 't'
 905                   && gfc_next_ascii_char () == '.')
 906                 {
 907                   /* Matched ".not.".  */
 908                   *result = INTRINSIC_NOT;
 909                   return MATCH_YES;
 910                 }
 911             }
 912           break;
 913
 914         case 'o':
 915           if (gfc_next_ascii_char () == 'r'
 916               && gfc_next_ascii_char () == '.')
 917             {
 918               /* Matched ".or.".  */
 919               *result = INTRINSIC_OR;
 920               return MATCH_YES;
 921             }
 922           break;
 923
 924         default:
 925           break;
 926         }
 927       break;
 928
 929     default:
 930       break;
 931     }
 932
 933   gfc_current_locus = orig_loc;
 934   return MATCH_NO;
 935 }
 936
 937
 938 /* Match a loop control phrase:
 939
 940     <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
 941
 942    If the final integer expression is not present, a constant unity
 943    expression is returned.  We don't return MATCH_ERROR until after
 944    the equals sign is seen.  */
 945
 946 match
 947 gfc_match_iterator (gfc_iterator *iter, int init_flag)
 948 {
 949   char name[GFC_MAX_SYMBOL_LEN + 1];
 950   gfc_expr *var, *e1, *e2, *e3;
 951   locus start;
 952   match m;
 953
 954   e1 = e2 = e3 = NULL;
 955
 956   /* Match the start of an iterator without affecting the symbol table.  */
 957
 958   start = gfc_current_locus;
 959   m = gfc_match (" %n =", name);
 960   gfc_current_locus = start;
 961
 962   if (m != MATCH_YES)
 963     return MATCH_NO;
 964
 965   m = gfc_match_variable (&var, 0);
 966   if (m != MATCH_YES)
 967     return MATCH_NO;
 968
 969   /* F2008, C617 & C565.  */
 970   if (var->symtree->n.sym->attr.codimension)
 971     {
 972       gfc_error ("Loop variable at %C cannot be a coarray");
 973       goto cleanup;
 974     }
 975
 976   if (var->ref != NULL)
 977     {
 978       gfc_error ("Loop variable at %C cannot be a sub-component");
 979       goto cleanup;
 980     }
 981
 982   gfc_match_char ('=');
 983
 984   var->symtree->n.sym->attr.implied_index = 1;
 985
 986   m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
 987   if (m == MATCH_NO)
 988     goto syntax;
 989   if (m == MATCH_ERROR)
 990     goto cleanup;
 991
 992   if (gfc_match_char (',') != MATCH_YES)
 993     goto syntax;
 994
 995   m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
 996   if (m == MATCH_NO)
 997     goto syntax;
 998   if (m == MATCH_ERROR)
 999     goto cleanup;
1000
1001   if (gfc_match_char (',') != MATCH_YES)
1002     {
1003       e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
1004       goto done;
1005     }
1006
1007   m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
1008   if (m == MATCH_ERROR)
1009     goto cleanup;
1010   if (m == MATCH_NO)
1011     {
1012       gfc_error ("Expected a step value in iterator at %C");
1013       goto cleanup;
1014     }
1015
1016 done:
1017   iter->var = var;
1018   iter->start = e1;
1019   iter->end = e2;
1020   iter->step = e3;
1021   return MATCH_YES;
1022
1023 syntax:
1024   gfc_error ("Syntax error in iterator at %C");
1025
1026 cleanup:
1027   gfc_free_expr (e1);
1028   gfc_free_expr (e2);
1029   gfc_free_expr (e3);
1030
1031   return MATCH_ERROR;
1032 }
1033
1034
1035 /* Tries to match the next non-whitespace character on the input.
1036    This subroutine does not return MATCH_ERROR.  */
1037
1038 match
1039 gfc_match_char (char c)
1040 {
1041   locus where;
1042
1043   where = gfc_current_locus;
1044   gfc_gobble_whitespace ();
1045
1046   if (gfc_next_ascii_char () == c)
1047     return MATCH_YES;
1048
1049   gfc_current_locus = where;
1050   return MATCH_NO;
1051 }
1052
1053
1054 /* General purpose matching subroutine.  The target string is a
1055    scanf-like format string in which spaces correspond to arbitrary
1056    whitespace (including no whitespace), characters correspond to
1057    themselves.  The %-codes are:
1058
1059    %%  Literal percent sign
1060    %e  Expression, pointer to a pointer is set
1061    %s  Symbol, pointer to the symbol is set
1062    %n  Name, character buffer is set to name
1063    %t  Matches end of statement.
1064    %o  Matches an intrinsic operator, returned as an INTRINSIC enum.
1065    %l  Matches a statement label
1066    %v  Matches a variable expression (an lvalue)
1067    %   Matches a required space (in free form) and optional spaces.  */
1068
1069 match
1070 gfc_match (const char *target, ...)
1071 {
1072   gfc_st_label **label;
1073   int matches, *ip;
1074   locus old_loc;
1075   va_list argp;
1076   char c, *np;
1077   match m, n;
1078   void **vp;
1079   const char *p;
1080
1081   old_loc = gfc_current_locus;
1082   va_start (argp, target);
1083   m = MATCH_NO;
1084   matches = 0;
1085   p = target;
1086
1087 loop:
1088   c = *p++;
1089   switch (c)
1090     {
1091     case ' ':
1092       gfc_gobble_whitespace ();
1093       goto loop;
1094     case '\0':
1095       m = MATCH_YES;
1096       break;
1097
1098     case '%':
1099       c = *p++;
1100       switch (c)
1101         {
1102         case 'e':
1103           vp = va_arg (argp, void **);
1104           n = gfc_match_expr ((gfc_expr **) vp);
1105           if (n != MATCH_YES)
1106             {
1107               m = n;
1108               goto not_yes;
1109             }
1110
1111           matches++;
1112           goto loop;
1113
1114         case 'v':
1115           vp = va_arg (argp, void **);
1116           n = gfc_match_variable ((gfc_expr **) vp, 0);
1117           if (n != MATCH_YES)
1118             {
1119               m = n;
1120               goto not_yes;
1121             }
1122
1123           matches++;
1124           goto loop;
1125
1126         case 's':
1127           vp = va_arg (argp, void **);
1128           n = gfc_match_symbol ((gfc_symbol **) vp, 0);
1129           if (n != MATCH_YES)
1130             {
1131               m = n;
1132               goto not_yes;
1133             }
1134
1135           matches++;
1136           goto loop;
1137
1138         case 'n':
1139           np = va_arg (argp, char *);
1140           n = gfc_match_name (np);
1141           if (n != MATCH_YES)
1142             {
1143               m = n;
1144               goto not_yes;
1145             }
1146
1147           matches++;
1148           goto loop;
1149
1150         case 'l':
1151           label = va_arg (argp, gfc_st_label **);
1152           n = gfc_match_st_label (label);
1153           if (n != MATCH_YES)
1154             {
1155               m = n;
1156               goto not_yes;
1157             }
1158
1159           matches++;
1160           goto loop;
1161
1162         case 'o':
1163           ip = va_arg (argp, int *);
1164           n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
1165           if (n != MATCH_YES)
1166             {
1167               m = n;
1168               goto not_yes;
1169             }
1170
1171           matches++;
1172           goto loop;
1173
1174         case 't':
1175           if (gfc_match_eos () != MATCH_YES)
1176             {
1177               m = MATCH_NO;
1178               goto not_yes;
1179             }
1180           goto loop;
1181
1182         case ' ':
1183           if (gfc_match_space () == MATCH_YES)
1184             goto loop;
1185           m = MATCH_NO;
1186           goto not_yes;
1187
1188         case '%':
1189           break;        /* Fall through to character matcher.  */
1190
1191         default:
1192           gfc_internal_error ("gfc_match(): Bad match code %c", c);
1193         }
1194
1195     default:
1196
1197       /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1198          expect an upper case character here!  */
1199       gcc_assert (TOLOWER (c) == c);
1200
1201       if (c == gfc_next_ascii_char ())
1202         goto loop;
1203       break;
1204     }
1205
1206 not_yes:
1207   va_end (argp);
1208
1209   if (m != MATCH_YES)
1210     {
1211       /* Clean up after a failed match.  */
1212       gfc_current_locus = old_loc;
1213       va_start (argp, target);
1214
1215       p = target;
1216       for (; matches > 0; matches--)
1217         {
1218           while (*p++ != '%');
1219
1220           switch (*p++)
1221             {
1222             case '%':
1223               matches++;
1224               break;            /* Skip.  */
1225
1226             /* Matches that don't have to be undone */
1227             case 'o':
1228             case 'l':
1229             case 'n':
1230             case 's':
1231               (void) va_arg (argp, void **);
1232               break;
1233
1234             case 'e':
1235             case 'v':
1236               vp = va_arg (argp, void **);
1237               gfc_free_expr ((struct gfc_expr *)*vp);
1238               *vp = NULL;
1239               break;
1240             }
1241         }
1242
1243       va_end (argp);
1244     }
1245
1246   return m;
1247 }
1248
1249
1250 /*********************** Statement level matching **********************/
1251
1252 /* Matches the start of a program unit, which is the program keyword
1253    followed by an obligatory symbol.  */
1254
1255 match
1256 gfc_match_program (void)
1257 {
1258   gfc_symbol *sym;
1259   match m;
1260
1261   m = gfc_match ("% %s%t", &sym);
1262
1263   if (m == MATCH_NO)
1264     {
1265       gfc_error ("Invalid form of PROGRAM statement at %C");
1266       m = MATCH_ERROR;
1267     }
1268
1269   if (m == MATCH_ERROR)
1270     return m;
1271
1272   if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
1273     return MATCH_ERROR;
1274
1275   gfc_new_block = sym;
1276
1277   return MATCH_YES;
1278 }
1279
1280
1281 /* Match a simple assignment statement.  */
1282
1283 match
1284 gfc_match_assignment (void)
1285 {
1286   gfc_expr *lvalue, *rvalue;
1287   locus old_loc;
1288   match m;
1289
1290   old_loc = gfc_current_locus;
1291
1292   lvalue = NULL;
1293   m = gfc_match (" %v =", &lvalue);
1294   if (m != MATCH_YES)
1295     {
1296       gfc_current_locus = old_loc;
1297       gfc_free_expr (lvalue);
1298       return MATCH_NO;
1299     }
1300
1301   rvalue = NULL;
1302   m = gfc_match (" %e%t", &rvalue);
1303   if (m != MATCH_YES)
1304     {
1305       gfc_current_locus = old_loc;
1306       gfc_free_expr (lvalue);
1307       gfc_free_expr (rvalue);
1308       return m;
1309     }
1310
1311   gfc_set_sym_referenced (lvalue->symtree->n.sym);
1312
1313   new_st.op = EXEC_ASSIGN;
1314   new_st.expr1 = lvalue;
1315   new_st.expr2 = rvalue;
1316
1317   gfc_check_do_variable (lvalue->symtree);
1318
1319   return MATCH_YES;
1320 }
1321
1322
1323 /* Match a pointer assignment statement.  */
1324
1325 match
1326 gfc_match_pointer_assignment (void)
1327 {
1328   gfc_expr *lvalue, *rvalue;
1329   locus old_loc;
1330   match m;
1331
1332   old_loc = gfc_current_locus;
1333
1334   lvalue = rvalue = NULL;
1335   gfc_matching_ptr_assignment = 0;
1336   gfc_matching_procptr_assignment = 0;
1337
1338   m = gfc_match (" %v =>", &lvalue);
1339   if (m != MATCH_YES)
1340     {
1341       m = MATCH_NO;
1342       goto cleanup;
1343     }
1344
1345   if (lvalue->symtree->n.sym->attr.proc_pointer
1346       || gfc_is_proc_ptr_comp (lvalue, NULL))
1347     gfc_matching_procptr_assignment = 1;
1348   else
1349     gfc_matching_ptr_assignment = 1;
1350
1351   m = gfc_match (" %e%t", &rvalue);
1352   gfc_matching_ptr_assignment = 0;
1353   gfc_matching_procptr_assignment = 0;
1354   if (m != MATCH_YES)
1355     goto cleanup;
1356
1357   new_st.op = EXEC_POINTER_ASSIGN;
1358   new_st.expr1 = lvalue;
1359   new_st.expr2 = rvalue;
1360
1361   return MATCH_YES;
1362
1363 cleanup:
1364   gfc_current_locus = old_loc;
1365   gfc_free_expr (lvalue);
1366   gfc_free_expr (rvalue);
1367   return m;
1368 }
1369
1370
1371 /* We try to match an easy arithmetic IF statement. This only happens
1372    when just after having encountered a simple IF statement. This code
1373    is really duplicate with parts of the gfc_match_if code, but this is
1374    *much* easier.  */
1375
1376 static match
1377 match_arithmetic_if (void)
1378 {
1379   gfc_st_label *l1, *l2, *l3;
1380   gfc_expr *expr;
1381   match m;
1382
1383   m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
1384   if (m != MATCH_YES)
1385     return m;
1386
1387   if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1388       || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1389       || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1390     {
1391       gfc_free_expr (expr);
1392       return MATCH_ERROR;
1393     }
1394
1395   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
1396                       "statement at %C") == FAILURE)
1397     return MATCH_ERROR;
1398
1399   new_st.op = EXEC_ARITHMETIC_IF;
1400   new_st.expr1 = expr;
1401   new_st.label1 = l1;
1402   new_st.label2 = l2;
1403   new_st.label3 = l3;
1404
1405   return MATCH_YES;
1406 }
1407
1408
1409 /* The IF statement is a bit of a pain.  First of all, there are three
1410    forms of it, the simple IF, the IF that starts a block and the
1411    arithmetic IF.
1412
1413    There is a problem with the simple IF and that is the fact that we
1414    only have a single level of undo information on symbols.  What this
1415    means is for a simple IF, we must re-match the whole IF statement
1416    multiple times in order to guarantee that the symbol table ends up
1417    in the proper state.  */
1418
1419 static match match_simple_forall (void);
1420 static match match_simple_where (void);
1421
1422 match
1423 gfc_match_if (gfc_statement *if_type)
1424 {
1425   gfc_expr *expr;
1426   gfc_st_label *l1, *l2, *l3;
1427   locus old_loc, old_loc2;
1428   gfc_code *p;
1429   match m, n;
1430
1431   n = gfc_match_label ();
1432   if (n == MATCH_ERROR)
1433     return n;
1434
1435   old_loc = gfc_current_locus;
1436
1437   m = gfc_match (" if ( %e", &expr);
1438   if (m != MATCH_YES)
1439     return m;
1440
1441   old_loc2 = gfc_current_locus;
1442   gfc_current_locus = old_loc;
1443
1444   if (gfc_match_parens () == MATCH_ERROR)
1445     return MATCH_ERROR;
1446
1447   gfc_current_locus = old_loc2;
1448
1449   if (gfc_match_char (')') != MATCH_YES)
1450     {
1451       gfc_error ("Syntax error in IF-expression at %C");
1452       gfc_free_expr (expr);
1453       return MATCH_ERROR;
1454     }
1455
1456   m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1457
1458   if (m == MATCH_YES)
1459     {
1460       if (n == MATCH_YES)
1461         {
1462           gfc_error ("Block label not appropriate for arithmetic IF "
1463                      "statement at %C");
1464           gfc_free_expr (expr);
1465           return MATCH_ERROR;
1466         }
1467
1468       if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1469           || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1470           || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1471         {
1472           gfc_free_expr (expr);
1473           return MATCH_ERROR;
1474         }
1475
1476       if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
1477                           "statement at %C") == FAILURE)
1478         return MATCH_ERROR;
1479
1480       new_st.op = EXEC_ARITHMETIC_IF;
1481       new_st.expr1 = expr;
1482       new_st.label1 = l1;
1483       new_st.label2 = l2;
1484       new_st.label3 = l3;
1485
1486       *if_type = ST_ARITHMETIC_IF;
1487       return MATCH_YES;
1488     }
1489
1490   if (gfc_match (" then%t") == MATCH_YES)
1491     {
1492       new_st.op = EXEC_IF;
1493       new_st.expr1 = expr;
1494       *if_type = ST_IF_BLOCK;
1495       return MATCH_YES;
1496     }
1497
1498   if (n == MATCH_YES)
1499     {
1500       gfc_error ("Block label is not appropriate for IF statement at %C");
1501       gfc_free_expr (expr);
1502       return MATCH_ERROR;
1503     }
1504
1505   /* At this point the only thing left is a simple IF statement.  At
1506      this point, n has to be MATCH_NO, so we don't have to worry about
1507      re-matching a block label.  From what we've got so far, try
1508      matching an assignment.  */
1509
1510   *if_type = ST_SIMPLE_IF;
1511
1512   m = gfc_match_assignment ();
1513   if (m == MATCH_YES)
1514     goto got_match;
1515
1516   gfc_free_expr (expr);
1517   gfc_undo_symbols ();
1518   gfc_current_locus = old_loc;
1519
1520   /* m can be MATCH_NO or MATCH_ERROR, here.  For MATCH_ERROR, a mangled
1521      assignment was found.  For MATCH_NO, continue to call the various
1522      matchers.  */
1523   if (m == MATCH_ERROR)
1524     return MATCH_ERROR;
1525
1526   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */
1527
1528   m = gfc_match_pointer_assignment ();
1529   if (m == MATCH_YES)
1530     goto got_match;
1531
1532   gfc_free_expr (expr);
1533   gfc_undo_symbols ();
1534   gfc_current_locus = old_loc;
1535
1536   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */
1537
1538   /* Look at the next keyword to see which matcher to call.  Matching
1539      the keyword doesn't affect the symbol table, so we don't have to
1540      restore between tries.  */
1541
1542 #define match(string, subr, statement) \
1543   if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1544
1545   gfc_clear_error ();
1546
1547   match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1548   match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1549   match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1550   match ("call", gfc_match_call, ST_CALL)
1551   match ("close", gfc_match_close, ST_CLOSE)
1552   match ("continue", gfc_match_continue, ST_CONTINUE)
1553   match ("cycle", gfc_match_cycle, ST_CYCLE)
1554   match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1555   match ("end file", gfc_match_endfile, ST_END_FILE)
1556   match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
1557   match ("exit", gfc_match_exit, ST_EXIT)
1558   match ("flush", gfc_match_flush, ST_FLUSH)
1559   match ("forall", match_simple_forall, ST_FORALL)
1560   match ("go to", gfc_match_goto, ST_GOTO)
1561   match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1562   match ("inquire", gfc_match_inquire, ST_INQUIRE)
1563   match ("lock", gfc_match_lock, ST_LOCK)
1564   match ("nullify", gfc_match_nullify, ST_NULLIFY)
1565   match ("open", gfc_match_open, ST_OPEN)
1566   match ("pause", gfc_match_pause, ST_NONE)
1567   match ("print", gfc_match_print, ST_WRITE)
1568   match ("read", gfc_match_read, ST_READ)
1569   match ("return", gfc_match_return, ST_RETURN)
1570   match ("rewind", gfc_match_rewind, ST_REWIND)
1571   match ("stop", gfc_match_stop, ST_STOP)
1572   match ("wait", gfc_match_wait, ST_WAIT)
1573   match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
1574   match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
1575   match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
1576   match ("unlock", gfc_match_unlock, ST_UNLOCK)
1577   match ("where", match_simple_where, ST_WHERE)
1578   match ("write", gfc_match_write, ST_WRITE)
1579
1580   /* The gfc_match_assignment() above may have returned a MATCH_NO
1581      where the assignment was to a named constant.  Check that
1582      special case here.  */
1583   m = gfc_match_assignment ();
1584   if (m == MATCH_NO)
1585    {
1586       gfc_error ("Cannot assign to a named constant at %C");
1587       gfc_free_expr (expr);
1588       gfc_undo_symbols ();
1589       gfc_current_locus = old_loc;
1590       return MATCH_ERROR;
1591    }
1592
1593   /* All else has failed, so give up.  See if any of the matchers has
1594      stored an error message of some sort.  */
1595   if (gfc_error_check () == 0)
1596     gfc_error ("Unclassifiable statement in IF-clause at %C");
1597
1598   gfc_free_expr (expr);
1599   return MATCH_ERROR;
1600
1601 got_match:
1602   if (m == MATCH_NO)
1603     gfc_error ("Syntax error in IF-clause at %C");
1604   if (m != MATCH_YES)
1605     {
1606       gfc_free_expr (expr);
1607       return MATCH_ERROR;
1608     }
1609
1610   /* At this point, we've matched the single IF and the action clause
1611      is in new_st.  Rearrange things so that the IF statement appears
1612      in new_st.  */
1613
1614   p = gfc_get_code ();
1615   p->next = gfc_get_code ();
1616   *p->next = new_st;
1617   p->next->loc = gfc_current_locus;
1618
1619   p->expr1 = expr;
1620   p->op = EXEC_IF;
1621
1622   gfc_clear_new_st ();
1623
1624   new_st.op = EXEC_IF;
1625   new_st.block = p;
1626
1627   return MATCH_YES;
1628 }
1629
1630 #undef match
1631
1632
1633 /* Match an ELSE statement.  */
1634
1635 match
1636 gfc_match_else (void)
1637 {
1638   char name[GFC_MAX_SYMBOL_LEN + 1];
1639
1640   if (gfc_match_eos () == MATCH_YES)
1641     return MATCH_YES;
1642
1643   if (gfc_match_name (name) != MATCH_YES
1644       || gfc_current_block () == NULL
1645       || gfc_match_eos () != MATCH_YES)
1646     {
1647       gfc_error ("Unexpected junk after ELSE statement at %C");
1648       return MATCH_ERROR;
1649     }
1650
1651   if (strcmp (name, gfc_current_block ()->name) != 0)
1652     {
1653       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1654                  name, gfc_current_block ()->name);
1655       return MATCH_ERROR;
1656     }
1657
1658   return MATCH_YES;
1659 }
1660
1661
1662 /* Match an ELSE IF statement.  */
1663
1664 match
1665 gfc_match_elseif (void)
1666 {
1667   char name[GFC_MAX_SYMBOL_LEN + 1];
1668   gfc_expr *expr;
1669   match m;
1670
1671   m = gfc_match (" ( %e ) then", &expr);
1672   if (m != MATCH_YES)
1673     return m;
1674
1675   if (gfc_match_eos () == MATCH_YES)
1676     goto done;
1677
1678   if (gfc_match_name (name) != MATCH_YES
1679       || gfc_current_block () == NULL
1680       || gfc_match_eos () != MATCH_YES)
1681     {
1682       gfc_error ("Unexpected junk after ELSE IF statement at %C");
1683       goto cleanup;
1684     }
1685
1686   if (strcmp (name, gfc_current_block ()->name) != 0)
1687     {
1688       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1689                  name, gfc_current_block ()->name);
1690       goto cleanup;
1691     }
1692
1693 done:
1694   new_st.op = EXEC_IF;
1695   new_st.expr1 = expr;
1696   return MATCH_YES;
1697
1698 cleanup:
1699   gfc_free_expr (expr);
1700   return MATCH_ERROR;
1701 }
1702
1703
1704 /* Free a gfc_iterator structure.  */
1705
1706 void
1707 gfc_free_iterator (gfc_iterator *iter, int flag)
1708 {
1709
1710   if (iter == NULL)
1711     return;
1712
1713   gfc_free_expr (iter->var);
1714   gfc_free_expr (iter->start);
1715   gfc_free_expr (iter->end);
1716   gfc_free_expr (iter->step);
1717
1718   if (flag)
1719     free (iter);
1720 }
1721
1722
1723 /* Match a CRITICAL statement.  */
1724 match
1725 gfc_match_critical (void)
1726 {
1727   gfc_st_label *label = NULL;
1728
1729   if (gfc_match_label () == MATCH_ERROR)
1730     return MATCH_ERROR;
1731
1732   if (gfc_match (" critical") != MATCH_YES)
1733     return MATCH_NO;
1734
1735   if (gfc_match_st_label (&label) == MATCH_ERROR)
1736     return MATCH_ERROR;
1737
1738   if (gfc_match_eos () != MATCH_YES)
1739     {
1740       gfc_syntax_error (ST_CRITICAL);
1741       return MATCH_ERROR;
1742     }
1743
1744   if (gfc_pure (NULL))
1745     {
1746       gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1747       return MATCH_ERROR;
1748     }
1749
1750   if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
1751     {
1752       gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1753                  "block");
1754       return MATCH_ERROR;
1755     }
1756
1757   gfc_unset_implicit_pure (NULL);
1758
1759   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C")
1760       == FAILURE)
1761     return MATCH_ERROR;
1762
1763   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
1764     {
1765        gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
1766        return MATCH_ERROR;
1767     }
1768
1769   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
1770     {
1771       gfc_error ("Nested CRITICAL block at %C");
1772       return MATCH_ERROR;
1773     }
1774
1775   new_st.op = EXEC_CRITICAL;
1776
1777   if (label != NULL
1778       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1779     return MATCH_ERROR;
1780
1781   return MATCH_YES;
1782 }
1783
1784
1785 /* Match a BLOCK statement.  */
1786
1787 match
1788 gfc_match_block (void)
1789 {
1790   match m;
1791
1792   if (gfc_match_label () == MATCH_ERROR)
1793     return MATCH_ERROR;
1794
1795   if (gfc_match (" block") != MATCH_YES)
1796     return MATCH_NO;
1797
1798   /* For this to be a correct BLOCK statement, the line must end now.  */
1799   m = gfc_match_eos ();
1800   if (m == MATCH_ERROR)
1801     return MATCH_ERROR;
1802   if (m == MATCH_NO)
1803     return MATCH_NO;
1804
1805   return MATCH_YES;
1806 }
1807
1808
1809 /* Match an ASSOCIATE statement.  */
1810
1811 match
1812 gfc_match_associate (void)
1813 {
1814   if (gfc_match_label () == MATCH_ERROR)
1815     return MATCH_ERROR;
1816
1817   if (gfc_match (" associate") != MATCH_YES)
1818     return MATCH_NO;
1819
1820   /* Match the association list.  */
1821   if (gfc_match_char ('(') != MATCH_YES)
1822     {
1823       gfc_error ("Expected association list at %C");
1824       return MATCH_ERROR;
1825     }
1826   new_st.ext.block.assoc = NULL;
1827   while (true)
1828     {
1829       gfc_association_list* newAssoc = gfc_get_association_list ();
1830       gfc_association_list* a;
1831
1832       /* Match the next association.  */
1833       if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
1834             != MATCH_YES)
1835         {
1836           gfc_error ("Expected association at %C");
1837           goto assocListError;
1838         }
1839       newAssoc->where = gfc_current_locus;
1840
1841       /* Check that the current name is not yet in the list.  */
1842       for (a = new_st.ext.block.assoc; a; a = a->next)
1843         if (!strcmp (a->name, newAssoc->name))
1844           {
1845             gfc_error ("Duplicate name '%s' in association at %C",
1846                        newAssoc->name);
1847             goto assocListError;
1848           }
1849
1850       /* The target expression must not be coindexed.  */
1851       if (gfc_is_coindexed (newAssoc->target))
1852         {
1853           gfc_error ("Association target at %C must not be coindexed");
1854           goto assocListError;
1855         }
1856
1857       /* The `variable' field is left blank for now; because the target is not
1858          yet resolved, we can't use gfc_has_vector_subscript to determine it
1859          for now.  This is set during resolution.  */
1860
1861       /* Put it into the list.  */
1862       newAssoc->next = new_st.ext.block.assoc;
1863       new_st.ext.block.assoc = newAssoc;
1864
1865       /* Try next one or end if closing parenthesis is found.  */
1866       gfc_gobble_whitespace ();
1867       if (gfc_peek_char () == ')')
1868         break;
1869       if (gfc_match_char (',') != MATCH_YES)
1870         {
1871           gfc_error ("Expected ')' or ',' at %C");
1872           return MATCH_ERROR;
1873         }
1874
1875       continue;
1876
1877 assocListError:
1878       free (newAssoc);
1879       goto error;
1880     }
1881   if (gfc_match_char (')') != MATCH_YES)
1882     {
1883       /* This should never happen as we peek above.  */
1884       gcc_unreachable ();
1885     }
1886
1887   if (gfc_match_eos () != MATCH_YES)
1888     {
1889       gfc_error ("Junk after ASSOCIATE statement at %C");
1890       goto error;
1891     }
1892
1893   return MATCH_YES;
1894
1895 error:
1896   gfc_free_association_list (new_st.ext.block.assoc);
1897   return MATCH_ERROR;
1898 }
1899
1900
1901 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1902    an accessible derived type.  */
1903
1904 static match
1905 match_derived_type_spec (gfc_typespec *ts)
1906 {
1907   char name[GFC_MAX_SYMBOL_LEN + 1];
1908   locus old_locus;
1909   gfc_symbol *derived;
1910
1911   old_locus = gfc_current_locus;
1912
1913   if (gfc_match ("%n", name) != MATCH_YES)
1914     {
1915        gfc_current_locus = old_locus;
1916        return MATCH_NO;
1917     }
1918
1919   gfc_find_symbol (name, NULL, 1, &derived);
1920
1921   if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
1922     derived = gfc_find_dt_in_generic (derived);
1923
1924   if (derived && derived->attr.flavor == FL_DERIVED)
1925     {
1926       ts->type = BT_DERIVED;
1927       ts->u.derived = derived;
1928       return MATCH_YES;
1929     }
1930
1931   gfc_current_locus = old_locus;
1932   return MATCH_NO;
1933 }
1934
1935
1936 /* Match a Fortran 2003 type-spec (F03:R401).  This is similar to
1937    gfc_match_decl_type_spec() from decl.c, with the following exceptions:
1938    It only includes the intrinsic types from the Fortran 2003 standard
1939    (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
1940    the implicit_flag is not needed, so it was removed. Derived types are
1941    identified by their name alone.  */
1942
1943 static match
1944 match_type_spec (gfc_typespec *ts)
1945 {
1946   match m;
1947   locus old_locus;
1948
1949   gfc_clear_ts (ts);
1950   gfc_gobble_whitespace ();
1951   old_locus = gfc_current_locus;
1952
1953   if (match_derived_type_spec (ts) == MATCH_YES)
1954     {
1955       /* Enforce F03:C401.  */
1956       if (ts->u.derived->attr.abstract)
1957         {
1958           gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
1959                      ts->u.derived->name, &old_locus);
1960           return MATCH_ERROR;
1961         }
1962       return MATCH_YES;
1963     }
1964
1965   if (gfc_match ("integer") == MATCH_YES)
1966     {
1967       ts->type = BT_INTEGER;
1968       ts->kind = gfc_default_integer_kind;
1969       goto kind_selector;
1970     }
1971
1972   if (gfc_match ("real") == MATCH_YES)
1973     {
1974       ts->type = BT_REAL;
1975       ts->kind = gfc_default_real_kind;
1976       goto kind_selector;
1977     }
1978
1979   if (gfc_match ("double precision") == MATCH_YES)
1980     {
1981       ts->type = BT_REAL;
1982       ts->kind = gfc_default_double_kind;
1983       return MATCH_YES;
1984     }
1985
1986   if (gfc_match ("complex") == MATCH_YES)
1987     {
1988       ts->type = BT_COMPLEX;
1989       ts->kind = gfc_default_complex_kind;
1990       goto kind_selector;
1991     }
1992
1993   if (gfc_match ("character") == MATCH_YES)
1994     {
1995       ts->type = BT_CHARACTER;
1996
1997       m = gfc_match_char_spec (ts);
1998
1999       if (m == MATCH_NO)
2000         m = MATCH_YES;
2001
2002       return m;
2003     }
2004
2005   if (gfc_match ("logical") == MATCH_YES)
2006     {
2007       ts->type = BT_LOGICAL;
2008       ts->kind = gfc_default_logical_kind;
2009       goto kind_selector;
2010     }
2011
2012   /* If a type is not matched, simply return MATCH_NO.  */
2013   gfc_current_locus = old_locus;
2014   return MATCH_NO;
2015
2016 kind_selector:
2017
2018   gfc_gobble_whitespace ();
2019   if (gfc_peek_ascii_char () == '*')
2020     {
2021       gfc_error ("Invalid type-spec at %C");
2022       return MATCH_ERROR;
2023     }
2024
2025   m = gfc_match_kind_spec (ts, false);
2026
2027   if (m == MATCH_NO)
2028     m = MATCH_YES;              /* No kind specifier found.  */
2029
2030   return m;
2031 }
2032
2033
2034 /******************** FORALL subroutines ********************/
2035
2036 /* Free a list of FORALL iterators.  */
2037
2038 void
2039 gfc_free_forall_iterator (gfc_forall_iterator *iter)
2040 {
2041   gfc_forall_iterator *next;
2042
2043   while (iter)
2044     {
2045       next = iter->next;
2046       gfc_free_expr (iter->var);
2047       gfc_free_expr (iter->start);
2048       gfc_free_expr (iter->end);
2049       gfc_free_expr (iter->stride);
2050       free (iter);
2051       iter = next;
2052     }
2053 }
2054
2055
2056 /* Match an iterator as part of a FORALL statement.  The format is:
2057
2058      <var> = <start>:<end>[:<stride>]
2059
2060    On MATCH_NO, the caller tests for the possibility that there is a
2061    scalar mask expression.  */
2062
2063 static match
2064 match_forall_iterator (gfc_forall_iterator **result)
2065 {
2066   gfc_forall_iterator *iter;
2067   locus where;
2068   match m;
2069
2070   where = gfc_current_locus;
2071   iter = XCNEW (gfc_forall_iterator);
2072
2073   m = gfc_match_expr (&iter->var);
2074   if (m != MATCH_YES)
2075     goto cleanup;
2076
2077   if (gfc_match_char ('=') != MATCH_YES
2078       || iter->var->expr_type != EXPR_VARIABLE)
2079     {
2080       m = MATCH_NO;
2081       goto cleanup;
2082     }
2083
2084   m = gfc_match_expr (&iter->start);
2085   if (m != MATCH_YES)
2086     goto cleanup;
2087
2088   if (gfc_match_char (':') != MATCH_YES)
2089     goto syntax;
2090
2091   m = gfc_match_expr (&iter->end);
2092   if (m == MATCH_NO)
2093     goto syntax;
2094   if (m == MATCH_ERROR)
2095     goto cleanup;
2096
2097   if (gfc_match_char (':') == MATCH_NO)
2098     iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
2099   else
2100     {
2101       m = gfc_match_expr (&iter->stride);
2102       if (m == MATCH_NO)
2103         goto syntax;
2104       if (m == MATCH_ERROR)
2105         goto cleanup;
2106     }
2107
2108   /* Mark the iteration variable's symbol as used as a FORALL index.  */
2109   iter->var->symtree->n.sym->forall_index = true;
2110
2111   *result = iter;
2112   return MATCH_YES;
2113
2114 syntax:
2115   gfc_error ("Syntax error in FORALL iterator at %C");
2116   m = MATCH_ERROR;
2117
2118 cleanup:
2119
2120   gfc_current_locus = where;
2121   gfc_free_forall_iterator (iter);
2122   return m;
2123 }
2124
2125
2126 /* Match the header of a FORALL statement.  */
2127
2128 static match
2129 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
2130 {
2131   gfc_forall_iterator *head, *tail, *new_iter;
2132   gfc_expr *msk;
2133   match m;
2134
2135   gfc_gobble_whitespace ();
2136
2137   head = tail = NULL;
2138   msk = NULL;
2139
2140   if (gfc_match_char ('(') != MATCH_YES)
2141     return MATCH_NO;
2142
2143   m = match_forall_iterator (&new_iter);
2144   if (m == MATCH_ERROR)
2145     goto cleanup;
2146   if (m == MATCH_NO)
2147     goto syntax;
2148
2149   head = tail = new_iter;
2150
2151   for (;;)
2152     {
2153       if (gfc_match_char (',') != MATCH_YES)
2154         break;
2155
2156       m = match_forall_iterator (&new_iter);
2157       if (m == MATCH_ERROR)
2158         goto cleanup;
2159
2160       if (m == MATCH_YES)
2161         {
2162           tail->next = new_iter;
2163           tail = new_iter;
2164           continue;
2165         }
2166
2167       /* Have to have a mask expression.  */
2168
2169       m = gfc_match_expr (&msk);
2170       if (m == MATCH_NO)
2171         goto syntax;
2172       if (m == MATCH_ERROR)
2173         goto cleanup;
2174
2175       break;
2176     }
2177
2178   if (gfc_match_char (')') == MATCH_NO)
2179     goto syntax;
2180
2181   *phead = head;
2182   *mask = msk;
2183   return MATCH_YES;
2184
2185 syntax:
2186   gfc_syntax_error (ST_FORALL);
2187
2188 cleanup:
2189   gfc_free_expr (msk);
2190   gfc_free_forall_iterator (head);
2191
2192   return MATCH_ERROR;
2193 }
2194
2195 /* Match the rest of a simple FORALL statement that follows an
2196    IF statement.  */
2197
2198 static match
2199 match_simple_forall (void)
2200 {
2201   gfc_forall_iterator *head;
2202   gfc_expr *mask;
2203   gfc_code *c;
2204   match m;
2205
2206   mask = NULL;
2207   head = NULL;
2208   c = NULL;
2209
2210   m = match_forall_header (&head, &mask);
2211
2212   if (m == MATCH_NO)
2213     goto syntax;
2214   if (m != MATCH_YES)
2215     goto cleanup;
2216
2217   m = gfc_match_assignment ();
2218
2219   if (m == MATCH_ERROR)
2220     goto cleanup;
2221   if (m == MATCH_NO)
2222     {
2223       m = gfc_match_pointer_assignment ();
2224       if (m == MATCH_ERROR)
2225         goto cleanup;
2226       if (m == MATCH_NO)
2227         goto syntax;
2228     }
2229
2230   c = gfc_get_code ();
2231   *c = new_st;
2232   c->loc = gfc_current_locus;
2233
2234   if (gfc_match_eos () != MATCH_YES)
2235     goto syntax;
2236
2237   gfc_clear_new_st ();
2238   new_st.op = EXEC_FORALL;
2239   new_st.expr1 = mask;
2240   new_st.ext.forall_iterator = head;
2241   new_st.block = gfc_get_code ();
2242
2243   new_st.block->op = EXEC_FORALL;
2244   new_st.block->next = c;
2245
2246   return MATCH_YES;
2247
2248 syntax:
2249   gfc_syntax_error (ST_FORALL);
2250
2251 cleanup:
2252   gfc_free_forall_iterator (head);
2253   gfc_free_expr (mask);
2254
2255   return MATCH_ERROR;
2256 }
2257
2258
2259 /* Match a FORALL statement.  */
2260
2261 match
2262 gfc_match_forall (gfc_statement *st)
2263 {
2264   gfc_forall_iterator *head;
2265   gfc_expr *mask;
2266   gfc_code *c;
2267   match m0, m;
2268
2269   head = NULL;
2270   mask = NULL;
2271   c = NULL;
2272
2273   m0 = gfc_match_label ();
2274   if (m0 == MATCH_ERROR)
2275     return MATCH_ERROR;
2276
2277   m = gfc_match (" forall");
2278   if (m != MATCH_YES)
2279     return m;
2280
2281   m = match_forall_header (&head, &mask);
2282   if (m == MATCH_ERROR)
2283     goto cleanup;
2284   if (m == MATCH_NO)
2285     goto syntax;
2286
2287   if (gfc_match_eos () == MATCH_YES)
2288     {
2289       *st = ST_FORALL_BLOCK;
2290       new_st.op = EXEC_FORALL;
2291       new_st.expr1 = mask;
2292       new_st.ext.forall_iterator = head;
2293       return MATCH_YES;
2294     }
2295
2296   m = gfc_match_assignment ();
2297   if (m == MATCH_ERROR)
2298     goto cleanup;
2299   if (m == MATCH_NO)
2300     {
2301       m = gfc_match_pointer_assignment ();
2302       if (m == MATCH_ERROR)
2303         goto cleanup;
2304       if (m == MATCH_NO)
2305         goto syntax;
2306     }
2307
2308   c = gfc_get_code ();
2309   *c = new_st;
2310   c->loc = gfc_current_locus;
2311
2312   gfc_clear_new_st ();
2313   new_st.op = EXEC_FORALL;
2314   new_st.expr1 = mask;
2315   new_st.ext.forall_iterator = head;
2316   new_st.block = gfc_get_code ();
2317   new_st.block->op = EXEC_FORALL;
2318   new_st.block->next = c;
2319
2320   *st = ST_FORALL;
2321   return MATCH_YES;
2322
2323 syntax:
2324   gfc_syntax_error (ST_FORALL);
2325
2326 cleanup:
2327   gfc_free_forall_iterator (head);
2328   gfc_free_expr (mask);
2329   gfc_free_statements (c);
2330   return MATCH_NO;
2331 }
2332
2333
2334 /* Match a DO statement.  */
2335
2336 match
2337 gfc_match_do (void)
2338 {
2339   gfc_iterator iter, *ip;
2340   locus old_loc;
2341   gfc_st_label *label;
2342   match m;
2343
2344   old_loc = gfc_current_locus;
2345
2346   label = NULL;
2347   iter.var = iter.start = iter.end = iter.step = NULL;
2348
2349   m = gfc_match_label ();
2350   if (m == MATCH_ERROR)
2351     return m;
2352
2353   if (gfc_match (" do") != MATCH_YES)
2354     return MATCH_NO;
2355
2356   m = gfc_match_st_label (&label);
2357   if (m == MATCH_ERROR)
2358     goto cleanup;
2359
2360   /* Match an infinite DO, make it like a DO WHILE(.TRUE.).  */
2361
2362   if (gfc_match_eos () == MATCH_YES)
2363     {
2364       iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
2365       new_st.op = EXEC_DO_WHILE;
2366       goto done;
2367     }
2368
2369   /* Match an optional comma, if no comma is found, a space is obligatory.  */
2370   if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
2371     return MATCH_NO;
2372
2373   /* Check for balanced parens.  */
2374
2375   if (gfc_match_parens () == MATCH_ERROR)
2376     return MATCH_ERROR;
2377
2378   if (gfc_match (" concurrent") == MATCH_YES)
2379     {
2380       gfc_forall_iterator *head;
2381       gfc_expr *mask;
2382
2383       if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: DO CONCURRENT "
2384                            "construct at %C") == FAILURE)
2385         return MATCH_ERROR;
2386
2387
2388       mask = NULL;
2389       head = NULL;
2390       m = match_forall_header (&head, &mask);
2391
2392       if (m == MATCH_NO)
2393         return m;
2394       if (m == MATCH_ERROR)
2395         goto concurr_cleanup;
2396
2397       if (gfc_match_eos () != MATCH_YES)
2398         goto concurr_cleanup;
2399
2400       if (label != NULL
2401            && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2402         goto concurr_cleanup;
2403
2404       new_st.label1 = label;
2405       new_st.op = EXEC_DO_CONCURRENT;
2406       new_st.expr1 = mask;
2407       new_st.ext.forall_iterator = head;
2408
2409       return MATCH_YES;
2410
2411 concurr_cleanup:
2412       gfc_syntax_error (ST_DO);
2413       gfc_free_expr (mask);
2414       gfc_free_forall_iterator (head);
2415       return MATCH_ERROR;
2416     }
2417
2418   /* See if we have a DO WHILE.  */
2419   if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
2420     {
2421       new_st.op = EXEC_DO_WHILE;
2422       goto done;
2423     }
2424
2425   /* The abortive DO WHILE may have done something to the symbol
2426      table, so we start over.  */
2427   gfc_undo_symbols ();
2428   gfc_current_locus = old_loc;
2429
2430   gfc_match_label ();           /* This won't error.  */
2431   gfc_match (" do ");           /* This will work.  */
2432
2433   gfc_match_st_label (&label);  /* Can't error out.  */
2434   gfc_match_char (',');         /* Optional comma.  */
2435
2436   m = gfc_match_iterator (&iter, 0);
2437   if (m == MATCH_NO)
2438     return MATCH_NO;
2439   if (m == MATCH_ERROR)
2440     goto cleanup;
2441
2442   iter.var->symtree->n.sym->attr.implied_index = 0;
2443   gfc_check_do_variable (iter.var->symtree);
2444
2445   if (gfc_match_eos () != MATCH_YES)
2446     {
2447       gfc_syntax_error (ST_DO);
2448       goto cleanup;
2449     }
2450
2451   new_st.op = EXEC_DO;
2452
2453 done:
2454   if (label != NULL
2455       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2456     goto cleanup;
2457
2458   new_st.label1 = label;
2459
2460   if (new_st.op == EXEC_DO_WHILE)
2461     new_st.expr1 = iter.end;
2462   else
2463     {
2464       new_st.ext.iterator = ip = gfc_get_iterator ();
2465       *ip = iter;
2466     }
2467
2468   return MATCH_YES;
2469
2470 cleanup:
2471   gfc_free_iterator (&iter, 0);
2472
2473   return MATCH_ERROR;
2474 }
2475
2476
2477 /* Match an EXIT or CYCLE statement.  */
2478
2479 static match
2480 match_exit_cycle (gfc_statement st, gfc_exec_op op)
2481 {
2482   gfc_state_data *p, *o;
2483   gfc_symbol *sym;
2484   match m;
2485   int cnt;
2486
2487   if (gfc_match_eos () == MATCH_YES)
2488     sym = NULL;
2489   else
2490     {
2491       char name[GFC_MAX_SYMBOL_LEN + 1];
2492       gfc_symtree* stree;
2493
2494       m = gfc_match ("% %n%t", name);
2495       if (m == MATCH_ERROR)
2496         return MATCH_ERROR;
2497       if (m == MATCH_NO)
2498         {
2499           gfc_syntax_error (st);
2500           return MATCH_ERROR;
2501         }
2502
2503       /* Find the corresponding symbol.  If there's a BLOCK statement
2504          between here and the label, it is not in gfc_current_ns but a parent
2505          namespace!  */
2506       stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
2507       if (!stree)
2508         {
2509           gfc_error ("Name '%s' in %s statement at %C is unknown",
2510                      name, gfc_ascii_statement (st));
2511           return MATCH_ERROR;
2512         }
2513
2514       sym = stree->n.sym;
2515       if (sym->attr.flavor != FL_LABEL)
2516         {
2517           gfc_error ("Name '%s' in %s statement at %C is not a construct name",
2518                      name, gfc_ascii_statement (st));
2519           return MATCH_ERROR;
2520         }
2521     }
2522
2523   /* Find the loop specified by the label (or lack of a label).  */
2524   for (o = NULL, p = gfc_state_stack; p; p = p->previous)
2525     if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
2526       o = p;
2527     else if (p->state == COMP_CRITICAL)
2528       {
2529         gfc_error("%s statement at %C leaves CRITICAL construct",
2530                   gfc_ascii_statement (st));
2531         return MATCH_ERROR;
2532       }
2533     else if (p->state == COMP_DO_CONCURRENT
2534              && (op == EXEC_EXIT || (sym && sym != p->sym)))
2535       {
2536         /* F2008, C821 & C845.  */
2537         gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2538                   gfc_ascii_statement (st));
2539         return MATCH_ERROR;
2540       }
2541     else if ((sym && sym == p->sym)
2542              || (!sym && (p->state == COMP_DO
2543                           || p->state == COMP_DO_CONCURRENT)))
2544       break;
2545
2546   if (p == NULL)
2547     {
2548       if (sym == NULL)
2549         gfc_error ("%s statement at %C is not within a construct",
2550                    gfc_ascii_statement (st));
2551       else
2552         gfc_error ("%s statement at %C is not within construct '%s'",
2553                    gfc_ascii_statement (st), sym->name);
2554
2555       return MATCH_ERROR;
2556     }
2557
2558   /* Special checks for EXIT from non-loop constructs.  */
2559   switch (p->state)
2560     {
2561     case COMP_DO:
2562     case COMP_DO_CONCURRENT:
2563       break;
2564
2565     case COMP_CRITICAL:
2566       /* This is already handled above.  */
2567       gcc_unreachable ();
2568
2569     case COMP_ASSOCIATE:
2570     case COMP_BLOCK:
2571     case COMP_IF:
2572     case COMP_SELECT:
2573     case COMP_SELECT_TYPE:
2574       gcc_assert (sym);
2575       if (op == EXEC_CYCLE)
2576         {
2577           gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2578                      " construct '%s'", sym->name);
2579           return MATCH_ERROR;
2580         }
2581       gcc_assert (op == EXEC_EXIT);
2582       if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: EXIT statement with no"
2583                           " do-construct-name at %C") == FAILURE)
2584         return MATCH_ERROR;
2585       break;
2586
2587     default:
2588       gfc_error ("%s statement at %C is not applicable to construct '%s'",
2589                  gfc_ascii_statement (st), sym->name);
2590       return MATCH_ERROR;
2591     }
2592
2593   if (o != NULL)
2594     {
2595       gfc_error ("%s statement at %C leaving OpenMP structured block",
2596                  gfc_ascii_statement (st));
2597       return MATCH_ERROR;
2598     }
2599
2600   for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
2601     o = o->previous;
2602   if (cnt > 0
2603       && o != NULL
2604       && o->state == COMP_OMP_STRUCTURED_BLOCK
2605       && (o->head->op == EXEC_OMP_DO
2606           || o->head->op == EXEC_OMP_PARALLEL_DO))
2607     {
2608       int collapse = 1;
2609       gcc_assert (o->head->next != NULL
2610                   && (o->head->next->op == EXEC_DO
2611                       || o->head->next->op == EXEC_DO_WHILE)
2612                   && o->previous != NULL
2613                   && o->previous->tail->op == o->head->op);
2614       if (o->previous->tail->ext.omp_clauses != NULL
2615           && o->previous->tail->ext.omp_clauses->collapse > 1)
2616         collapse = o->previous->tail->ext.omp_clauses->collapse;
2617       if (st == ST_EXIT && cnt <= collapse)
2618         {
2619           gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2620           return MATCH_ERROR;
2621         }
2622       if (st == ST_CYCLE && cnt < collapse)
2623         {
2624           gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2625                      " !$OMP DO loop");
2626           return MATCH_ERROR;
2627         }
2628     }
2629
2630   /* Save the first statement in the construct - needed by the backend.  */
2631   new_st.ext.which_construct = p->construct;
2632
2633   new_st.op = op;
2634
2635   return MATCH_YES;
2636 }
2637
2638
2639 /* Match the EXIT statement.  */
2640
2641 match
2642 gfc_match_exit (void)
2643 {
2644   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
2645 }
2646
2647
2648 /* Match the CYCLE statement.  */
2649
2650 match
2651 gfc_match_cycle (void)
2652 {
2653   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
2654 }
2655
2656
2657 /* Match a number or character constant after an (ALL) STOP or PAUSE statement.  */
2658
2659 static match
2660 gfc_match_stopcode (gfc_statement st)
2661 {
2662   gfc_expr *e;
2663   match m;
2664
2665   e = NULL;
2666
2667   if (gfc_match_eos () != MATCH_YES)
2668     {
2669       m = gfc_match_init_expr (&e);
2670       if (m == MATCH_ERROR)
2671         goto cleanup;
2672       if (m == MATCH_NO)
2673         goto syntax;
2674
2675       if (gfc_match_eos () != MATCH_YES)
2676         goto syntax;
2677     }
2678
2679   if (gfc_pure (NULL))
2680     {
2681       gfc_error ("%s statement not allowed in PURE procedure at %C",
2682                  gfc_ascii_statement (st));
2683       goto cleanup;
2684     }
2685
2686   gfc_unset_implicit_pure (NULL);
2687
2688   if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
2689     {
2690       gfc_error ("Image control statement STOP at %C in CRITICAL block");
2691       goto cleanup;
2692     }
2693   if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
2694     {
2695       gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2696       goto cleanup;
2697     }
2698
2699   if (e != NULL)
2700     {
2701       if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
2702         {
2703           gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2704                      &e->where);
2705           goto cleanup;
2706         }
2707
2708       if (e->rank != 0)
2709         {
2710           gfc_error ("STOP code at %L must be scalar",
2711                      &e->where);
2712           goto cleanup;
2713         }
2714
2715       if (e->ts.type == BT_CHARACTER
2716           && e->ts.kind != gfc_default_character_kind)
2717         {
2718           gfc_error ("STOP code at %L must be default character KIND=%d",
2719                      &e->where, (int) gfc_default_character_kind);
2720           goto cleanup;
2721         }
2722
2723       if (e->ts.type == BT_INTEGER
2724           && e->ts.kind != gfc_default_integer_kind)
2725         {
2726           gfc_error ("STOP code at %L must be default integer KIND=%d",
2727                      &e->where, (int) gfc_default_integer_kind);
2728           goto cleanup;
2729         }
2730     }
2731
2732   switch (st)
2733     {
2734     case ST_STOP:
2735       new_st.op = EXEC_STOP;
2736       break;
2737     case ST_ERROR_STOP:
2738       new_st.op = EXEC_ERROR_STOP;
2739       break;
2740     case ST_PAUSE:
2741       new_st.op = EXEC_PAUSE;
2742       break;
2743     default:
2744       gcc_unreachable ();
2745     }
2746
2747   new_st.expr1 = e;
2748   new_st.ext.stop_code = -1;
2749
2750   return MATCH_YES;
2751
2752 syntax:
2753   gfc_syntax_error (st);
2754
2755 cleanup:
2756
2757   gfc_free_expr (e);
2758   return MATCH_ERROR;
2759 }
2760
2761
2762 /* Match the (deprecated) PAUSE statement.  */
2763
2764 match
2765 gfc_match_pause (void)
2766 {
2767   match m;
2768
2769   m = gfc_match_stopcode (ST_PAUSE);
2770   if (m == MATCH_YES)
2771     {
2772       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
2773           " at %C")
2774           == FAILURE)
2775         m = MATCH_ERROR;
2776     }
2777   return m;
2778 }
2779
2780
2781 /* Match the STOP statement.  */
2782
2783 match
2784 gfc_match_stop (void)
2785 {
2786   return gfc_match_stopcode (ST_STOP);
2787 }
2788
2789
2790 /* Match the ERROR STOP statement.  */
2791
2792 match
2793 gfc_match_error_stop (void)
2794 {
2795   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C")
2796       == FAILURE)
2797     return MATCH_ERROR;
2798
2799   return gfc_match_stopcode (ST_ERROR_STOP);
2800 }
2801
2802
2803 /* Match LOCK/UNLOCK statement. Syntax:
2804      LOCK ( lock-variable [ , lock-stat-list ] )
2805      UNLOCK ( lock-variable [ , sync-stat-list ] )
2806    where lock-stat is ACQUIRED_LOCK or sync-stat
2807    and sync-stat is STAT= or ERRMSG=.  */
2808
2809 static match
2810 lock_unlock_statement (gfc_statement st)
2811 {
2812   match m;
2813   gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg;
2814   bool saw_acq_lock, saw_stat, saw_errmsg;
2815
2816   tmp = lockvar = acq_lock = stat = errmsg = NULL;
2817   saw_acq_lock = saw_stat = saw_errmsg = false;
2818
2819   if (gfc_pure (NULL))
2820     {
2821       gfc_error ("Image control statement %s at %C in PURE procedure",
2822                  st == ST_LOCK ? "LOCK" : "UNLOCK");
2823       return MATCH_ERROR;
2824     }
2825
2826   gfc_unset_implicit_pure (NULL);
2827
2828   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
2829     {
2830        gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2831        return MATCH_ERROR;
2832     }
2833
2834   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
2835     {
2836       gfc_error ("Image control statement %s at %C in CRITICAL block",
2837                  st == ST_LOCK ? "LOCK" : "UNLOCK");
2838       return MATCH_ERROR;
2839     }
2840
2841   if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
2842     {
2843       gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
2844                  st == ST_LOCK ? "LOCK" : "UNLOCK");
2845       return MATCH_ERROR;
2846     }
2847
2848   if (gfc_match_char ('(') != MATCH_YES)
2849     goto syntax;
2850
2851   if (gfc_match ("%e", &lockvar) != MATCH_YES)
2852     goto syntax;
2853   m = gfc_match_char (',');
2854   if (m == MATCH_ERROR)
2855     goto syntax;
2856   if (m == MATCH_NO)
2857     {
2858       m = gfc_match_char (')');
2859       if (m == MATCH_YES)
2860         goto done;
2861       goto syntax;
2862     }
2863
2864   for (;;)
2865     {
2866       m = gfc_match (" stat = %v", &tmp);
2867       if (m == MATCH_ERROR)
2868         goto syntax;
2869       if (m == MATCH_YES)
2870         {
2871           if (saw_stat)
2872             {
2873               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2874               goto cleanup;
2875             }
2876           stat = tmp;
2877           saw_stat = true;
2878
2879           m = gfc_match_char (',');
2880           if (m == MATCH_YES)
2881             continue;
2882
2883           tmp = NULL;
2884           break;
2885         }
2886
2887       m = gfc_match (" errmsg = %v", &tmp);
2888       if (m == MATCH_ERROR)
2889         goto syntax;
2890       if (m == MATCH_YES)
2891         {
2892           if (saw_errmsg)
2893             {
2894               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2895               goto cleanup;
2896             }
2897           errmsg = tmp;
2898           saw_errmsg = true;
2899
2900           m = gfc_match_char (',');
2901           if (m == MATCH_YES)
2902             continue;
2903
2904           tmp = NULL;
2905           break;
2906         }
2907
2908       m = gfc_match (" acquired_lock = %v", &tmp);
2909       if (m == MATCH_ERROR || st == ST_UNLOCK)
2910         goto syntax;
2911       if (m == MATCH_YES)
2912         {
2913           if (saw_acq_lock)
2914             {
2915               gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
2916                          &tmp->where);
2917               goto cleanup;
2918             }
2919           acq_lock = tmp;
2920           saw_acq_lock = true;
2921
2922           m = gfc_match_char (',');
2923           if (m == MATCH_YES)
2924             continue;
2925
2926           tmp = NULL;
2927           break;
2928         }
2929
2930       break;
2931     }
2932
2933   if (m == MATCH_ERROR)
2934     goto syntax;
2935
2936   if (gfc_match (" )%t") != MATCH_YES)
2937     goto syntax;
2938
2939 done:
2940   switch (st)
2941     {
2942     case ST_LOCK:
2943       new_st.op = EXEC_LOCK;
2944       break;
2945     case ST_UNLOCK:
2946       new_st.op = EXEC_UNLOCK;
2947       break;
2948     default:
2949       gcc_unreachable ();
2950     }
2951
2952   new_st.expr1 = lockvar;
2953   new_st.expr2 = stat;
2954   new_st.expr3 = errmsg;
2955   new_st.expr4 = acq_lock;
2956
2957   return MATCH_YES;
2958
2959 syntax:
2960   gfc_syntax_error (st);
2961
2962 cleanup:
2963   gfc_free_expr (tmp);
2964   gfc_free_expr (lockvar);
2965   gfc_free_expr (acq_lock);
2966   gfc_free_expr (stat);
2967   gfc_free_expr (errmsg);
2968
2969   return MATCH_ERROR;
2970 }
2971
2972
2973 match
2974 gfc_match_lock (void)
2975 {
2976   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: LOCK statement at %C")
2977       == FAILURE)
2978     return MATCH_ERROR;
2979
2980   return lock_unlock_statement (ST_LOCK);
2981 }
2982
2983
2984 match
2985 gfc_match_unlock (void)
2986 {
2987   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: UNLOCK statement at %C")
2988       == FAILURE)
2989     return MATCH_ERROR;
2990
2991   return lock_unlock_statement (ST_UNLOCK);
2992 }
2993
2994
2995 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2996      SYNC ALL [(sync-stat-list)]
2997      SYNC MEMORY [(sync-stat-list)]
2998      SYNC IMAGES (image-set [, sync-stat-list] )
2999    with sync-stat is int-expr or *.  */
3000
3001 static match
3002 sync_statement (gfc_statement st)
3003 {
3004   match m;
3005   gfc_expr *tmp, *imageset, *stat, *errmsg;
3006   bool saw_stat, saw_errmsg;
3007
3008   tmp = imageset = stat = errmsg = NULL;
3009   saw_stat = saw_errmsg = false;
3010
3011   if (gfc_pure (NULL))
3012     {
3013       gfc_error ("Image control statement SYNC at %C in PURE procedure");
3014       return MATCH_ERROR;
3015     }
3016
3017   gfc_unset_implicit_pure (NULL);
3018
3019   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C")
3020       == FAILURE)
3021     return MATCH_ERROR;
3022
3023   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3024     {
3025        gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3026        return MATCH_ERROR;
3027     }
3028
3029   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
3030     {
3031       gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3032       return MATCH_ERROR;
3033     }
3034
3035   if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
3036     {
3037       gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3038       return MATCH_ERROR;
3039     }
3040
3041   if (gfc_match_eos () == MATCH_YES)
3042     {
3043       if (st == ST_SYNC_IMAGES)
3044         goto syntax;
3045       goto done;
3046     }
3047
3048   if (gfc_match_char ('(') != MATCH_YES)
3049     goto syntax;
3050
3051   if (st == ST_SYNC_IMAGES)
3052     {
3053       /* Denote '*' as imageset == NULL.  */
3054       m = gfc_match_char ('*');
3055       if (m == MATCH_ERROR)
3056         goto syntax;
3057       if (m == MATCH_NO)
3058         {
3059           if (gfc_match ("%e", &imageset) != MATCH_YES)
3060             goto syntax;
3061         }
3062       m = gfc_match_char (',');
3063       if (m == MATCH_ERROR)
3064         goto syntax;
3065       if (m == MATCH_NO)
3066         {
3067           m = gfc_match_char (')');
3068           if (m == MATCH_YES)
3069             goto done;
3070           goto syntax;
3071         }
3072     }
3073
3074   for (;;)
3075     {
3076       m = gfc_match (" stat = %v", &tmp);
3077       if (m == MATCH_ERROR)
3078         goto syntax;
3079       if (m == MATCH_YES)
3080         {
3081           if (saw_stat)
3082             {
3083               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3084               goto cleanup;
3085             }
3086           stat = tmp;
3087           saw_stat = true;
3088
3089           if (gfc_match_char (',') == MATCH_YES)
3090             continue;
3091
3092           tmp = NULL;
3093           break;
3094         }
3095
3096       m = gfc_match (" errmsg = %v", &tmp);
3097       if (m == MATCH_ERROR)
3098         goto syntax;
3099       if (m == MATCH_YES)
3100         {
3101           if (saw_errmsg)
3102             {
3103               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3104               goto cleanup;
3105             }
3106           errmsg = tmp;
3107           saw_errmsg = true;
3108
3109           if (gfc_match_char (',') == MATCH_YES)
3110             continue;
3111
3112           tmp = NULL;
3113           break;
3114         }
3115
3116         break;
3117     }
3118
3119   if (m == MATCH_ERROR)
3120     goto syntax;
3121
3122   if (gfc_match (" )%t") != MATCH_YES)
3123     goto syntax;
3124
3125 done:
3126   switch (st)
3127     {
3128     case ST_SYNC_ALL:
3129       new_st.op = EXEC_SYNC_ALL;
3130       break;
3131     case ST_SYNC_IMAGES:
3132       new_st.op = EXEC_SYNC_IMAGES;
3133       break;
3134     case ST_SYNC_MEMORY:
3135       new_st.op = EXEC_SYNC_MEMORY;
3136       break;
3137     default:
3138       gcc_unreachable ();
3139     }
3140
3141   new_st.expr1 = imageset;
3142   new_st.expr2 = stat;
3143   new_st.expr3 = errmsg;
3144
3145   return MATCH_YES;
3146
3147 syntax:
3148   gfc_syntax_error (st);
3149
3150 cleanup:
3151   gfc_free_expr (tmp);
3152   gfc_free_expr (imageset);
3153   gfc_free_expr (stat);
3154   gfc_free_expr (errmsg);
3155
3156   return MATCH_ERROR;
3157 }
3158
3159
3160 /* Match SYNC ALL statement.  */
3161
3162 match
3163 gfc_match_sync_all (void)
3164 {
3165   return sync_statement (ST_SYNC_ALL);
3166 }
3167
3168
3169 /* Match SYNC IMAGES statement.  */
3170
3171 match
3172 gfc_match_sync_images (void)
3173 {
3174   return sync_statement (ST_SYNC_IMAGES);
3175 }
3176
3177
3178 /* Match SYNC MEMORY statement.  */
3179
3180 match
3181 gfc_match_sync_memory (void)
3182 {
3183   return sync_statement (ST_SYNC_MEMORY);
3184 }
3185
3186
3187 /* Match a CONTINUE statement.  */
3188
3189 match
3190 gfc_match_continue (void)
3191 {
3192   if (gfc_match_eos () != MATCH_YES)
3193     {
3194       gfc_syntax_error (ST_CONTINUE);
3195       return MATCH_ERROR;
3196     }
3197
3198   new_st.op = EXEC_CONTINUE;
3199   return MATCH_YES;
3200 }
3201
3202
3203 /* Match the (deprecated) ASSIGN statement.  */
3204
3205 match
3206 gfc_match_assign (void)
3207 {
3208   gfc_expr *expr;
3209   gfc_st_label *label;
3210
3211   if (gfc_match (" %l", &label) == MATCH_YES)
3212     {
3213       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
3214         return MATCH_ERROR;
3215       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
3216         {
3217           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
3218                               "statement at %C")
3219               == FAILURE)
3220             return MATCH_ERROR;
3221
3222           expr->symtree->n.sym->attr.assign = 1;
3223
3224           new_st.op = EXEC_LABEL_ASSIGN;
3225           new_st.label1 = label;
3226           new_st.expr1 = expr;
3227           return MATCH_YES;
3228         }
3229     }
3230   return MATCH_NO;
3231 }
3232
3233
3234 /* Match the GO TO statement.  As a computed GOTO statement is
3235    matched, it is transformed into an equivalent SELECT block.  No
3236    tree is necessary, and the resulting jumps-to-jumps are
3237    specifically optimized away by the back end.  */
3238
3239 match
3240 gfc_match_goto (void)
3241 {
3242   gfc_code *head, *tail;
3243   gfc_expr *expr;
3244   gfc_case *cp;
3245   gfc_st_label *label;
3246   int i;
3247   match m;
3248
3249   if (gfc_match (" %l%t", &label) == MATCH_YES)
3250     {
3251       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
3252         return MATCH_ERROR;
3253
3254       new_st.op = EXEC_GOTO;
3255       new_st.label1 = label;
3256       return MATCH_YES;
3257     }
3258
3259   /* The assigned GO TO statement.  */
3260
3261   if (gfc_match_variable (&expr, 0) == MATCH_YES)
3262     {
3263       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
3264                           "statement at %C")
3265           == FAILURE)
3266         return MATCH_ERROR;
3267
3268       new_st.op = EXEC_GOTO;
3269       new_st.expr1 = expr;
3270
3271       if (gfc_match_eos () == MATCH_YES)
3272         return MATCH_YES;
3273
3274       /* Match label list.  */
3275       gfc_match_char (',');
3276       if (gfc_match_char ('(') != MATCH_YES)
3277         {
3278           gfc_syntax_error (ST_GOTO);
3279           return MATCH_ERROR;
3280         }
3281       head = tail = NULL;
3282
3283       do
3284         {
3285           m = gfc_match_st_label (&label);
3286           if (m != MATCH_YES)
3287             goto syntax;
3288
3289           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
3290             goto cleanup;
3291
3292           if (head == NULL)
3293             head = tail = gfc_get_code ();
3294           else
3295             {
3296               tail->block = gfc_get_code ();
3297               tail = tail->block;
3298             }
3299
3300           tail->label1 = label;
3301           tail->op = EXEC_GOTO;
3302         }
3303       while (gfc_match_char (',') == MATCH_YES);
3304
3305       if (gfc_match (")%t") != MATCH_YES)
3306         goto syntax;
3307
3308       if (head == NULL)
3309         {
3310            gfc_error ("Statement label list in GOTO at %C cannot be empty");
3311            goto syntax;
3312         }
3313       new_st.block = head;
3314
3315       return MATCH_YES;
3316     }
3317
3318   /* Last chance is a computed GO TO statement.  */
3319   if (gfc_match_char ('(') != MATCH_YES)
3320     {
3321       gfc_syntax_error (ST_GOTO);
3322       return MATCH_ERROR;
3323     }
3324
3325   head = tail = NULL;
3326   i = 1;
3327
3328   do
3329     {
3330       m = gfc_match_st_label (&label);
3331       if (m != MATCH_YES)
3332         goto syntax;
3333
3334       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
3335         goto cleanup;
3336
3337       if (head == NULL)
3338         head = tail = gfc_get_code ();
3339       else
3340         {
3341           tail->block = gfc_get_code ();
3342           tail = tail->block;
3343         }
3344
3345       cp = gfc_get_case ();
3346       cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
3347                                              NULL, i++);
3348
3349       tail->op = EXEC_SELECT;
3350       tail->ext.block.case_list = cp;
3351
3352       tail->next = gfc_get_code ();
3353       tail->next->op = EXEC_GOTO;
3354       tail->next->label1 = label;
3355     }
3356   while (gfc_match_char (',') == MATCH_YES);
3357
3358   if (gfc_match_char (')') != MATCH_YES)
3359     goto syntax;
3360
3361   if (head == NULL)
3362     {
3363       gfc_error ("Statement label list in GOTO at %C cannot be empty");
3364       goto syntax;
3365     }
3366
3367   /* Get the rest of the statement.  */
3368   gfc_match_char (',');
3369
3370   if (gfc_match (" %e%t", &expr) != MATCH_YES)
3371     goto syntax;
3372
3373   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO "
3374                       "at %C") == FAILURE)
3375     return MATCH_ERROR;
3376
3377   /* At this point, a computed GOTO has been fully matched and an
3378      equivalent SELECT statement constructed.  */
3379
3380   new_st.op = EXEC_SELECT;
3381   new_st.expr1 = NULL;
3382
3383   /* Hack: For a "real" SELECT, the expression is in expr. We put
3384      it in expr2 so we can distinguish then and produce the correct
3385      diagnostics.  */
3386   new_st.expr2 = expr;
3387   new_st.block = head;
3388   return MATCH_YES;
3389
3390 syntax:
3391   gfc_syntax_error (ST_GOTO);
3392 cleanup:
3393   gfc_free_statements (head);
3394   return MATCH_ERROR;
3395 }
3396
3397
3398 /* Frees a list of gfc_alloc structures.  */
3399
3400 void
3401 gfc_free_alloc_list (gfc_alloc *p)
3402 {
3403   gfc_alloc *q;
3404
3405   for (; p; p = q)
3406     {
3407       q = p->next;
3408       gfc_free_expr (p->expr);
3409       free (p);
3410     }
3411 }
3412
3413
3414 /* Match an ALLOCATE statement.  */
3415
3416 match
3417 gfc_match_allocate (void)
3418 {
3419   gfc_alloc *head, *tail;
3420   gfc_expr *stat, *errmsg, *tmp, *source, *mold;
3421   gfc_typespec ts;
3422   gfc_symbol *sym;
3423   match m;
3424   locus old_locus, deferred_locus;
3425   bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
3426
3427   head = tail = NULL;
3428   stat = errmsg = source = mold = tmp = NULL;
3429   saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
3430
3431   if (gfc_match_char ('(') != MATCH_YES)
3432     goto syntax;
3433
3434   /* Match an optional type-spec.  */
3435   old_locus = gfc_current_locus;
3436   m = match_type_spec (&ts);
3437   if (m == MATCH_ERROR)
3438     goto cleanup;
3439   else if (m == MATCH_NO)
3440     {
3441       char name[GFC_MAX_SYMBOL_LEN + 3];
3442
3443       if (gfc_match ("%n :: ", name) == MATCH_YES)
3444         {
3445           gfc_error ("Error in type-spec at %L", &old_locus);
3446           goto cleanup;
3447         }
3448
3449       ts.type = BT_UNKNOWN;
3450     }
3451   else
3452     {
3453       if (gfc_match (" :: ") == MATCH_YES)
3454         {
3455           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
3456                               "ALLOCATE at %L", &old_locus) == FAILURE)
3457             goto cleanup;
3458
3459           if (ts.deferred)
3460             {
3461               gfc_error ("Type-spec at %L cannot contain a deferred "
3462                          "type parameter", &old_locus);
3463               goto cleanup;
3464             }
3465         }
3466       else
3467         {
3468           ts.type = BT_UNKNOWN;
3469           gfc_current_locus = old_locus;
3470         }
3471     }
3472
3473   for (;;)
3474     {
3475       if (head == NULL)
3476         head = tail = gfc_get_alloc ();
3477       else
3478         {
3479           tail->next = gfc_get_alloc ();
3480           tail = tail->next;
3481         }
3482
3483       m = gfc_match_variable (&tail->expr, 0);
3484       if (m == MATCH_NO)
3485         goto syntax;
3486       if (m == MATCH_ERROR)
3487         goto cleanup;
3488
3489       if (gfc_check_do_variable (tail->expr->symtree))
3490         goto cleanup;
3491
3492       bool impure = gfc_impure_variable (tail->expr->symtree->n.sym);
3493       if (impure && gfc_pure (NULL))
3494         {
3495           gfc_error ("Bad allocate-object at %C for a PURE procedure");
3496           goto cleanup;
3497         }
3498
3499       if (impure)
3500         gfc_unset_implicit_pure (NULL);
3501
3502       if (tail->expr->ts.deferred)
3503         {
3504           saw_deferred = true;
3505           deferred_locus = tail->expr->where;
3506         }
3507
3508       if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS
3509           || gfc_find_state (COMP_CRITICAL) == SUCCESS)
3510         {
3511           gfc_ref *ref;
3512           bool coarray = tail->expr->symtree->n.sym->attr.codimension;
3513           for (ref = tail->expr->ref; ref; ref = ref->next)
3514             if (ref->type == REF_COMPONENT)
3515               coarray = ref->u.c.component->attr.codimension;
3516
3517           if (coarray && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
3518             {
3519               gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
3520               goto cleanup;
3521             }
3522           if (coarray && gfc_find_state (COMP_CRITICAL) == SUCCESS)
3523             {
3524               gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
3525               goto cleanup;
3526             }
3527         }
3528
3529       /* The ALLOCATE statement had an optional typespec.  Check the
3530          constraints.  */
3531       if (ts.type != BT_UNKNOWN)
3532         {
3533           /* Enforce F03:C624.  */
3534           if (!gfc_type_compatible (&tail->expr->ts, &ts))
3535             {
3536               gfc_error ("Type of entity at %L is type incompatible with "
3537                          "typespec", &tail->expr->where);
3538               goto cleanup;
3539             }
3540
3541           /* Enforce F03:C627.  */
3542           if (ts.kind != tail->expr->ts.kind)
3543             {
3544               gfc_error ("Kind type parameter for entity at %L differs from "
3545                          "the kind type parameter of the typespec",
3546                          &tail->expr->where);
3547               goto cleanup;
3548             }
3549         }
3550
3551       if (tail->expr->ts.type == BT_DERIVED)
3552         tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
3553
3554       /* FIXME: disable the checking on derived types and arrays.  */
3555       sym = tail->expr->symtree->n.sym;
3556       b1 = !(tail->expr->ref
3557            && (tail->expr->ref->type == REF_COMPONENT
3558                 || tail->expr->ref->type == REF_ARRAY));
3559       if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
3560         b2 = !(CLASS_DATA (sym)->attr.allocatable
3561                || CLASS_DATA (sym)->attr.class_pointer);
3562       else
3563         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3564                       || sym->attr.proc_pointer);
3565       b3 = sym && sym->ns && sym->ns->proc_name
3566            && (sym->ns->proc_name->attr.allocatable
3567                 || sym->ns->proc_name->attr.pointer
3568                 || sym->ns->proc_name->attr.proc_pointer);
3569       if (b1 && b2 && !b3)
3570         {
3571           gfc_error ("Allocate-object at %L is not a nonprocedure pointer "
3572                      "or an allocatable variable", &tail->expr->where);
3573           goto cleanup;
3574         }
3575
3576       if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
3577         {
3578           gfc_error ("Shape specification for allocatable scalar at %C");
3579           goto cleanup;
3580         }
3581
3582       if (gfc_match_char (',') != MATCH_YES)
3583         break;
3584
3585 alloc_opt_list:
3586
3587       m = gfc_match (" stat = %v", &tmp);
3588       if (m == MATCH_ERROR)
3589         goto cleanup;
3590       if (m == MATCH_YES)
3591         {
3592           /* Enforce C630.  */
3593           if (saw_stat)
3594             {
3595               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3596               goto cleanup;
3597             }
3598
3599           stat = tmp;
3600           tmp = NULL;
3601           saw_stat = true;
3602
3603           if (gfc_check_do_variable (stat->symtree))
3604             goto cleanup;
3605
3606           if (gfc_match_char (',') == MATCH_YES)
3607             goto alloc_opt_list;
3608         }
3609
3610       m = gfc_match (" errmsg = %v", &tmp);
3611       if (m == MATCH_ERROR)
3612         goto cleanup;
3613       if (m == MATCH_YES)
3614         {
3615           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
3616                               &tmp->where) == FAILURE)
3617             goto cleanup;
3618
3619           /* Enforce C630.  */
3620           if (saw_errmsg)
3621             {
3622               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3623               goto cleanup;
3624             }
3625
3626           errmsg = tmp;
3627           tmp = NULL;
3628           saw_errmsg = true;
3629
3630           if (gfc_match_char (',') == MATCH_YES)
3631             goto alloc_opt_list;
3632         }
3633
3634       m = gfc_match (" source = %e", &tmp);
3635       if (m == MATCH_ERROR)
3636         goto cleanup;
3637       if (m == MATCH_YES)
3638         {
3639           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
3640                               &tmp->where) == FAILURE)
3641             goto cleanup;
3642
3643           /* Enforce C630.  */
3644           if (saw_source)
3645             {
3646               gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
3647               goto cleanup;
3648             }
3649
3650           /* The next 2 conditionals check C631.  */
3651           if (ts.type != BT_UNKNOWN)
3652             {
3653               gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3654                          &tmp->where, &old_locus);
3655               goto cleanup;
3656             }
3657
3658           if (head->next
3659               && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SOURCE tag at %L"
3660                                  " with more than a single allocate object",
3661                                  &tmp->where) == FAILURE)
3662             goto cleanup;
3663
3664           source = tmp;
3665           tmp = NULL;
3666           saw_source = true;
3667
3668           if (gfc_match_char (',') == MATCH_YES)
3669             goto alloc_opt_list;
3670         }
3671
3672       m = gfc_match (" mold = %e", &tmp);
3673       if (m == MATCH_ERROR)
3674         goto cleanup;
3675       if (m == MATCH_YES)
3676         {
3677           if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L",
3678                               &tmp->where) == FAILURE)
3679             goto cleanup;
3680
3681           /* Check F08:C636.  */
3682           if (saw_mold)
3683             {
3684               gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
3685               goto cleanup;
3686             }
3687
3688           /* Check F08:C637.  */
3689           if (ts.type != BT_UNKNOWN)
3690             {
3691               gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3692                          &tmp->where, &old_locus);
3693               goto cleanup;
3694             }
3695
3696           mold = tmp;
3697           tmp = NULL;
3698           saw_mold = true;
3699           mold->mold = 1;
3700
3701           if (gfc_match_char (',') == MATCH_YES)
3702             goto alloc_opt_list;
3703         }
3704
3705         gfc_gobble_whitespace ();
3706
3707         if (gfc_peek_char () == ')')
3708           break;
3709     }
3710
3711   if (gfc_match (" )%t") != MATCH_YES)
3712     goto syntax;
3713
3714   /* Check F08:C637.  */
3715   if (source && mold)
3716     {
3717       gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3718                   &mold->where, &source->where);
3719       goto cleanup;
3720     }
3721
3722   /* Check F03:C623,  */
3723   if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
3724     {
3725       gfc_error ("Allocate-object at %L with a deferred type parameter "
3726                  "requires either a type-spec or SOURCE tag or a MOLD tag",
3727                  &deferred_locus);
3728<