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