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           tmp = NULL;
2959           saw_stat = true;
2960
2961           if (gfc_check_do_variable (stat->symtree))
2962             goto cleanup;
2963
2964           if (gfc_match_char (',') == MATCH_YES)
2965             goto alloc_opt_list;
2966         }
2967
2968       m = gfc_match (" errmsg = %v", &tmp);
2969       if (m == MATCH_ERROR)
2970         goto cleanup;
2971       if (m == MATCH_YES)
2972         {
2973           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
2974                               &tmp->where) == FAILURE)
2975             goto cleanup;
2976
2977           /* Enforce C630.  */
2978           if (saw_errmsg)
2979             {
2980               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2981               goto cleanup;
2982             }
2983
2984           errmsg = tmp;
2985           tmp = NULL;
2986           saw_errmsg = true;
2987
2988           if (gfc_match_char (',') == MATCH_YES)
2989             goto alloc_opt_list;
2990         }
2991
2992       m = gfc_match (" source = %e", &tmp);
2993       if (m == MATCH_ERROR)
2994         goto cleanup;
2995       if (m == MATCH_YES)
2996         {
2997           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
2998                               &tmp->where) == FAILURE)
2999             goto cleanup;
3000
3001           /* Enforce C630.  */
3002           if (saw_source)
3003             {
3004               gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
3005               goto cleanup;
3006             }
3007
3008           /* The next 2 conditionals check C631.  */
3009           if (ts.type != BT_UNKNOWN)
3010             {
3011               gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3012                          &tmp->where, &old_locus);
3013               goto cleanup;
3014             }
3015
3016           if (head->next)
3017             {
3018               gfc_error ("SOURCE tag at %L requires only a single entity in "
3019                          "the allocation-list", &tmp->where);
3020               goto cleanup;
3021             }
3022
3023           source = tmp;
3024           tmp = NULL;
3025           saw_source = true;
3026
3027           if (gfc_match_char (',') == MATCH_YES)
3028             goto alloc_opt_list;
3029         }
3030
3031       m = gfc_match (" mold = %e", &tmp);
3032       if (m == MATCH_ERROR)
3033         goto cleanup;
3034       if (m == MATCH_YES)
3035         {
3036           if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L",
3037                               &tmp->where) == FAILURE)
3038             goto cleanup;
3039
3040           /* Check F08:C636.  */
3041           if (saw_mold)
3042             {
3043               gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
3044               goto cleanup;
3045             }
3046
3047           /* Check F08:C637.  */
3048           if (ts.type != BT_UNKNOWN)
3049             {
3050               gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3051                          &tmp->where, &old_locus);
3052               goto cleanup;
3053             }
3054
3055           mold = tmp;
3056           tmp = NULL;
3057           saw_mold = true;
3058           mold->mold = 1;
3059
3060           if (gfc_match_char (',') == MATCH_YES)
3061             goto alloc_opt_list;
3062         }
3063
3064         gfc_gobble_whitespace ();
3065
3066         if (gfc_peek_char () == ')')
3067           break;
3068     }
3069
3070
3071   if (gfc_match (" )%t") != MATCH_YES)
3072     goto syntax;
3073
3074   /* Check F08:C637.  */
3075   if (source && mold)
3076     {
3077       gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3078                   &mold->where, &source->where);
3079       goto cleanup;
3080     }
3081
3082   new_st.op = EXEC_ALLOCATE;
3083   new_st.expr1 = stat;
3084   new_st.expr2 = errmsg;
3085   if (source)
3086     new_st.expr3 = source;
3087   else
3088     new_st.expr3 = mold;
3089   new_st.ext.alloc.list = head;
3090   new_st.ext.alloc.ts = ts;
3091
3092   return MATCH_YES;
3093
3094 syntax:
3095   gfc_syntax_error (ST_ALLOCATE);
3096
3097 cleanup:
3098   gfc_free_expr (errmsg);
3099   gfc_free_expr (source);
3100   gfc_free_expr (stat);
3101   gfc_free_expr (mold);
3102   if (tmp && tmp->expr_type) gfc_free_expr (tmp);
3103   gfc_free_alloc_list (head);
3104   return MATCH_ERROR;
3105 }
3106
3107
3108 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3109    a set of pointer assignments to intrinsic NULL().  */
3110
3111 match
3112 gfc_match_nullify (void)
3113 {
3114   gfc_code *tail;
3115   gfc_expr *e, *p;
3116   match m;
3117
3118   tail = NULL;
3119
3120   if (gfc_match_char ('(') != MATCH_YES)
3121     goto syntax;
3122
3123   for (;;)
3124     {
3125       m = gfc_match_variable (&p, 0);
3126       if (m == MATCH_ERROR)
3127         goto cleanup;
3128       if (m == MATCH_NO)
3129         goto syntax;
3130
3131       if (gfc_check_do_variable (p->symtree))
3132         goto cleanup;
3133
3134       if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
3135         {
3136           gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
3137           goto cleanup;
3138         }
3139
3140       /* build ' => NULL() '.  */
3141       e = gfc_get_null_expr (&gfc_current_locus);
3142
3143       /* Chain to list.  */
3144       if (tail == NULL)
3145         tail = &new_st;
3146       else
3147         {
3148           tail->next = gfc_get_code ();
3149           tail = tail->next;
3150         }
3151
3152       tail->op = EXEC_POINTER_ASSIGN;
3153       tail->expr1 = p;
3154       tail->expr2 = e;
3155
3156       if (gfc_match (" )%t") == MATCH_YES)
3157         break;
3158       if (gfc_match_char (',') != MATCH_YES)
3159         goto syntax;
3160     }
3161
3162   return MATCH_YES;
3163
3164 syntax:
3165   gfc_syntax_error (ST_NULLIFY);
3166
3167 cleanup:
3168   gfc_free_statements (new_st.next);
3169   new_st.next = NULL;
3170   gfc_free_expr (new_st.expr1);
3171   new_st.expr1 = NULL;
3172   gfc_free_expr (new_st.expr2);
3173   new_st.expr2 = NULL;
3174   return MATCH_ERROR;
3175 }
3176
3177
3178 /* Match a DEALLOCATE statement.  */
3179
3180 match
3181 gfc_match_deallocate (void)
3182 {
3183   gfc_alloc *head, *tail;
3184   gfc_expr *stat, *errmsg, *tmp;
3185   gfc_symbol *sym;
3186   match m;
3187   bool saw_stat, saw_errmsg, b1, b2;
3188
3189   head = tail = NULL;
3190   stat = errmsg = tmp = NULL;
3191   saw_stat = saw_errmsg = false;
3192
3193   if (gfc_match_char ('(') != MATCH_YES)
3194     goto syntax;
3195
3196   for (;;)
3197     {
3198       if (head == NULL)
3199         head = tail = gfc_get_alloc ();
3200       else
3201         {
3202           tail->next = gfc_get_alloc ();
3203           tail = tail->next;
3204         }
3205
3206       m = gfc_match_variable (&tail->expr, 0);
3207       if (m == MATCH_ERROR)
3208         goto cleanup;
3209       if (m == MATCH_NO)
3210         goto syntax;
3211
3212       if (gfc_check_do_variable (tail->expr->symtree))
3213         goto cleanup;
3214
3215       sym = tail->expr->symtree->n.sym;
3216
3217       if (gfc_pure (NULL) && gfc_impure_variable (sym))
3218         {
3219           gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3220           goto cleanup;
3221         }
3222
3223       /* FIXME: disable the checking on derived types.  */
3224       b1 = !(tail->expr->ref
3225            && (tail->expr->ref->type == REF_COMPONENT
3226                || tail->expr->ref->type == REF_ARRAY));
3227       if (sym && sym->ts.type == BT_CLASS)
3228         b2 = !(CLASS_DATA (sym)->attr.allocatable
3229                || CLASS_DATA (sym)->attr.class_pointer);
3230       else
3231         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3232                       || sym->attr.proc_pointer);
3233       if (b1 && b2)
3234         {
3235           gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3236                      "or an allocatable variable");
3237           goto cleanup;
3238         }
3239
3240       if (gfc_match_char (',') != MATCH_YES)
3241         break;
3242
3243 dealloc_opt_list:
3244
3245       m = gfc_match (" stat = %v", &tmp);
3246       if (m == MATCH_ERROR)
3247         goto cleanup;
3248       if (m == MATCH_YES)
3249         {
3250           if (saw_stat)
3251             {
3252               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3253               gfc_free_expr (tmp);
3254               goto cleanup;
3255             }
3256
3257           stat = tmp;
3258           saw_stat = true;
3259
3260           if (gfc_check_do_variable (stat->symtree))
3261             goto cleanup;
3262
3263           if (gfc_match_char (',') == MATCH_YES)
3264             goto dealloc_opt_list;
3265         }
3266
3267       m = gfc_match (" errmsg = %v", &tmp);
3268       if (m == MATCH_ERROR)
3269         goto cleanup;
3270       if (m == MATCH_YES)
3271         {
3272           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
3273                               &tmp->where) == FAILURE)
3274             goto cleanup;
3275
3276           if (saw_errmsg)
3277             {
3278               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3279               gfc_free_expr (tmp);
3280               goto cleanup;
3281             }
3282
3283           errmsg = tmp;
3284           saw_errmsg = true;
3285
3286           if (gfc_match_char (',') == MATCH_YES)
3287             goto dealloc_opt_list;
3288         }
3289
3290         gfc_gobble_whitespace ();
3291
3292         if (gfc_peek_char () == ')')
3293           break;
3294     }
3295
3296   if (gfc_match (" )%t") != MATCH_YES)
3297     goto syntax;
3298
3299   new_st.op = EXEC_DEALLOCATE;
3300   new_st.expr1 = stat;
3301   new_st.expr2 = errmsg;
3302   new_st.ext.alloc.list = head;
3303
3304   return MATCH_YES;
3305
3306 syntax:
3307   gfc_syntax_error (ST_DEALLOCATE);
3308
3309 cleanup:
3310   gfc_free_expr (errmsg);
3311   gfc_free_expr (stat);
3312   gfc_free_alloc_list (head);
3313   return MATCH_ERROR;
3314 }
3315
3316
3317 /* Match a RETURN statement.  */
3318
3319 match
3320 gfc_match_return (void)
3321 {
3322   gfc_expr *e;
3323   match m;
3324   gfc_compile_state s;
3325
3326   e = NULL;
3327
3328   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
3329     {
3330       gfc_error ("Image control statement RETURN at %C in CRITICAL block");
3331       return MATCH_ERROR;
3332     }
3333
3334   if (gfc_match_eos () == MATCH_YES)
3335     goto done;
3336
3337   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
3338     {
3339       gfc_error ("Alternate RETURN statement at %C is only allowed within "
3340                  "a SUBROUTINE");
3341       goto cleanup;
3342     }
3343
3344   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN "
3345                       "at %C") == FAILURE)
3346     return MATCH_ERROR;
3347
3348   if (gfc_current_form == FORM_FREE)
3349     {
3350       /* The following are valid, so we can't require a blank after the
3351         RETURN keyword:
3352           return+1
3353           return(1)  */
3354       char c = gfc_peek_ascii_char ();
3355       if (ISALPHA (c) || ISDIGIT (c))
3356         return MATCH_NO;
3357     }
3358
3359   m = gfc_match (" %e%t", &e);
3360   if (m == MATCH_YES)
3361     goto done;
3362   if (m == MATCH_ERROR)
3363     goto cleanup;
3364
3365   gfc_syntax_error (ST_RETURN);
3366
3367 cleanup:
3368   gfc_free_expr (e);
3369   return MATCH_ERROR;
3370
3371 done:
3372   gfc_enclosing_unit (&s);
3373   if (s == COMP_PROGRAM
3374       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
3375                         "main program at %C") == FAILURE)
3376       return MATCH_ERROR;
3377
3378   new_st.op = EXEC_RETURN;
3379   new_st.expr1 = e;
3380
3381   return MATCH_YES;
3382 }
3383
3384
3385 /* Match the call of a type-bound procedure, if CALL%var has already been
3386    matched and var found to be a derived-type variable.  */
3387
3388 static match
3389 match_typebound_call (gfc_symtree* varst)
3390 {
3391   gfc_expr* base;
3392   match m;
3393
3394   base = gfc_get_expr ();
3395   base->expr_type = EXPR_VARIABLE;
3396   base->symtree = varst;
3397   base->where = gfc_current_locus;
3398   gfc_set_sym_referenced (varst->n.sym);
3399
3400   m = gfc_match_varspec (base, 0, true, true);
3401   if (m == MATCH_NO)
3402     gfc_error ("Expected component reference at %C");
3403   if (m != MATCH_YES)
3404     return MATCH_ERROR;
3405
3406   if (gfc_match_eos () != MATCH_YES)
3407     {
3408       gfc_error ("Junk after CALL at %C");
3409       return MATCH_ERROR;
3410     }
3411
3412   if (base->expr_type == EXPR_COMPCALL)
3413     new_st.op = EXEC_COMPCALL;
3414   else if (base->expr_type == EXPR_PPC)
3415     new_st.op = EXEC_CALL_PPC;
3416   else
3417     {
3418       gfc_error ("Expected type-bound procedure or procedure pointer component "
3419                  "at %C");
3420       return MATCH_ERROR;
3421     }
3422   new_st.expr1 = base;
3423
3424   return MATCH_YES;
3425 }
3426
3427
3428 /* Match a CALL statement.  The tricky part here are possible
3429    alternate return specifiers.  We handle these by having all
3430    "subroutines" actually return an integer via a register that gives
3431    the return number.  If the call specifies alternate returns, we
3432    generate code for a SELECT statement whose case clauses contain
3433    GOTOs to the various labels.  */
3434
3435 match
3436 gfc_match_call (void)
3437 {
3438   char name[GFC_MAX_SYMBOL_LEN + 1];
3439   gfc_actual_arglist *a, *arglist;
3440   gfc_case *new_case;
3441   gfc_symbol *sym;
3442   gfc_symtree *st;
3443   gfc_code *c;
3444   match m;
3445   int i;
3446
3447   arglist = NULL;
3448
3449   m = gfc_match ("% %n", name);
3450   if (m == MATCH_NO)
3451     goto syntax;
3452   if (m != MATCH_YES)
3453     return m;
3454
3455   if (gfc_get_ha_sym_tree (name, &st))
3456     return MATCH_ERROR;
3457
3458   sym = st->n.sym;
3459
3460   /* If this is a variable of derived-type, it probably starts a type-bound
3461      procedure call.  */
3462   if ((sym->attr.flavor != FL_PROCEDURE
3463        || gfc_is_function_return_value (sym, gfc_current_ns))
3464       && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
3465     return match_typebound_call (st);
3466
3467   /* If it does not seem to be callable (include functions so that the
3468      right association is made.  They are thrown out in resolution.)
3469      ...  */
3470   if (!sym->attr.generic
3471         && !sym->attr.subroutine
3472         && !sym->attr.function)
3473     {
3474       if (!(sym->attr.external && !sym->attr.referenced))
3475         {
3476           /* ...create a symbol in this scope...  */
3477           if (sym->ns != gfc_current_ns
3478                 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
3479             return MATCH_ERROR;
3480
3481           if (sym != st->n.sym)
3482             sym = st->n.sym;
3483         }
3484
3485       /* ...and then to try to make the symbol into a subroutine.  */
3486       if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
3487         return MATCH_ERROR;
3488     }
3489
3490   gfc_set_sym_referenced (sym);
3491
3492   if (gfc_match_eos () != MATCH_YES)
3493     {
3494       m = gfc_match_actual_arglist (1, &arglist);
3495       if (m == MATCH_NO)
3496         goto syntax;
3497       if (m == MATCH_ERROR)
3498         goto cleanup;
3499
3500       if (gfc_match_eos () != MATCH_YES)
3501         goto syntax;
3502     }
3503
3504   /* If any alternate return labels were found, construct a SELECT
3505      statement that will jump to the right place.  */
3506
3507   i = 0;
3508   for (a = arglist; a; a = a->next)
3509     if (a->expr == NULL)
3510       i = 1;
3511
3512   if (i)
3513     {
3514       gfc_symtree *select_st;
3515       gfc_symbol *select_sym;
3516       char name[GFC_MAX_SYMBOL_LEN + 1];
3517
3518       new_st.next = c = gfc_get_code ();
3519       c->op = EXEC_SELECT;
3520       sprintf (name, "_result_%s", sym->name);
3521       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
3522
3523       select_sym = select_st->n.sym;
3524       select_sym->ts.type = BT_INTEGER;
3525       select_sym->ts.kind = gfc_default_integer_kind;
3526       gfc_set_sym_referenced (select_sym);
3527       c->expr1 = gfc_get_expr ();
3528       c->expr1->expr_type = EXPR_VARIABLE;
3529       c->expr1->symtree = select_st;
3530       c->expr1->ts = select_sym->ts;
3531       c->expr1->where = gfc_current_locus;
3532
3533       i = 0;
3534       for (a = arglist; a; a = a->next)
3535         {
3536           if (a->expr != NULL)
3537             continue;
3538
3539           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
3540             continue;
3541
3542           i++;
3543
3544           c->block = gfc_get_code ();
3545           c = c->block;
3546           c->op = EXEC_SELECT;
3547
3548           new_case = gfc_get_case ();
3549           new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
3550           new_case->low = new_case->high;
3551           c->ext.case_list = new_case;
3552
3553           c->next = gfc_get_code ();
3554           c->next->op = EXEC_GOTO;
3555           c->next->label1 = a->label;
3556         }
3557     }
3558
3559   new_st.op = EXEC_CALL;
3560   new_st.symtree = st;
3561   new_st.ext.actual = arglist;
3562
3563   return MATCH_YES;
3564
3565 syntax:
3566   gfc_syntax_error (ST_CALL);
3567
3568 cleanup:
3569   gfc_free_actual_arglist (arglist);
3570   return MATCH_ERROR;
3571 }
3572
3573
3574 /* Given a name, return a pointer to the common head structure,
3575    creating it if it does not exist. If FROM_MODULE is nonzero, we
3576    mangle the name so that it doesn't interfere with commons defined
3577    in the using namespace.
3578    TODO: Add to global symbol tree.  */
3579
3580 gfc_common_head *
3581 gfc_get_common (const char *name, int from_module)
3582 {
3583   gfc_symtree *st;
3584   static int serial = 0;
3585   char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
3586
3587   if (from_module)
3588     {
3589       /* A use associated common block is only needed to correctly layout
3590          the variables it contains.  */
3591       snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
3592       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
3593     }
3594   else
3595     {
3596       st = gfc_find_symtree (gfc_current_ns->common_root, name);
3597
3598       if (st == NULL)
3599         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
3600     }
3601
3602   if (st->n.common == NULL)
3603     {
3604       st->n.common = gfc_get_common_head ();
3605       st->n.common->where = gfc_current_locus;
3606       strcpy (st->n.common->name, name);
3607     }
3608
3609   return st->n.common;
3610 }
3611
3612
3613 /* Match a common block name.  */
3614
3615 match match_common_name (char *name)
3616 {
3617   match m;
3618
3619   if (gfc_match_char ('/') == MATCH_NO)
3620     {
3621       name[0] = '\0';
3622       return MATCH_YES;
3623     }
3624
3625   if (gfc_match_char ('/') == MATCH_YES)
3626     {
3627       name[0] = '\0';
3628       return MATCH_YES;
3629     }
3630
3631   m = gfc_match_name (name);
3632
3633   if (m == MATCH_ERROR)
3634     return MATCH_ERROR;
3635   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
3636     return MATCH_YES;
3637
3638   gfc_error ("Syntax error in common block name at %C");
3639   return MATCH_ERROR;
3640 }
3641
3642
3643 /* Match a COMMON statement.  */
3644
3645 match
3646 gfc_match_common (void)
3647 {
3648   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
3649   char name[GFC_MAX_SYMBOL_LEN + 1];
3650   gfc_common_head *t;
3651   gfc_array_spec *as;
3652   gfc_equiv *e1, *e2;
3653   match m;
3654   gfc_gsymbol *gsym;
3655
3656   old_blank_common = gfc_current_ns->blank_common.head;
3657   if (old_blank_common)
3658     {
3659       while (old_blank_common->common_next)
3660         old_blank_common = old_blank_common->common_next;
3661     }
3662
3663   as = NULL;
3664
3665   for (;;)
3666     {
3667       m = match_common_name (name);
3668       if (m == MATCH_ERROR)
3669         goto cleanup;
3670
3671       gsym = gfc_get_gsymbol (name);
3672       if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
3673         {
3674           gfc_error ("Symbol '%s' at %C is already an external symbol that "
3675                      "is not COMMON", name);
3676           goto cleanup;
3677         }
3678
3679       if (gsym->type == GSYM_UNKNOWN)
3680         {
3681           gsym->type = GSYM_COMMON;
3682           gsym->where = gfc_current_locus;
3683           gsym->defined = 1;
3684         }
3685
3686       gsym->used = 1;
3687
3688       if (name[0] == '\0')
3689         {
3690           t = &gfc_current_ns->blank_common;
3691           if (t->head == NULL)
3692             t->where = gfc_current_locus;
3693         }
3694       else
3695         {
3696           t = gfc_get_common (name, 0);
3697         }
3698       head = &t->head;
3699
3700       if (*head == NULL)
3701         tail = NULL;
3702       else
3703         {
3704           tail = *head;
3705           while (tail->common_next)
3706             tail = tail->common_next;
3707         }
3708
3709       /* Grab the list of symbols.  */
3710       for (;;)
3711         {
3712           m = gfc_match_symbol (&sym, 0);
3713           if (m == MATCH_ERROR)
3714             goto cleanup;
3715           if (m == MATCH_NO)
3716             goto syntax;
3717
3718           /* Store a ref to the common block for error checking.  */
3719           sym->common_block = t;
3720
3721           /* See if we know the current common block is bind(c), and if
3722              so, then see if we can check if the symbol is (which it'll
3723              need to be).  This can happen if the bind(c) attr stmt was
3724              applied to the common block, and the variable(s) already
3725              defined, before declaring the common block.  */
3726           if (t->is_bind_c == 1)
3727             {
3728               if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
3729                 {
3730                   /* If we find an error, just print it and continue,
3731                      cause it's just semantic, and we can see if there
3732                      are more errors.  */
3733                   gfc_error_now ("Variable '%s' at %L in common block '%s' "
3734                                  "at %C must be declared with a C "
3735                                  "interoperable kind since common block "
3736                                  "'%s' is bind(c)",
3737                                  sym->name, &(sym->declared_at), t->name,
3738                                  t->name);
3739                 }
3740
3741               if (sym->attr.is_bind_c == 1)
3742                 gfc_error_now ("Variable '%s' in common block "
3743                                "'%s' at %C can not be bind(c) since "
3744                                "it is not global", sym->name, t->name);
3745             }
3746
3747           if (sym->attr.in_common)
3748             {
3749               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
3750                          sym->name);
3751               goto cleanup;
3752             }
3753
3754           if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
3755                || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
3756             {
3757               if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
3758                                                "can only be COMMON in "
3759                                                "BLOCK DATA", sym->name)
3760                   == FAILURE)
3761                 goto cleanup;
3762             }
3763
3764           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
3765             goto cleanup;
3766
3767           if (tail != NULL)
3768             tail->common_next = sym;
3769           else
3770             *head = sym;
3771
3772           tail = sym;
3773
3774           /* Deal with an optional array specification after the
3775              symbol name.  */
3776           m = gfc_match_array_spec (&as, true, true);
3777           if (m == MATCH_ERROR)
3778             goto cleanup;
3779
3780           if (m == MATCH_YES)
3781             {
3782               if (as->type != AS_EXPLICIT)
3783                 {
3784                   gfc_error ("Array specification for symbol '%s' in COMMON "
3785                              "at %C must be explicit", sym->name);
3786                   goto cleanup;
3787                 }
3788
3789               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
3790                 goto cleanup;
3791
3792               if (sym->attr.pointer)
3793                 {
3794                   gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3795                              "POINTER array", sym->name);
3796                   goto cleanup;
3797                 }
3798
3799               sym->as = as;
3800               as = NULL;
3801
3802             }
3803
3804           sym->common_head = t;
3805
3806           /* Check to see if the symbol is already in an equivalence group.
3807              If it is, set the other members as being in common.  */
3808           if (sym->attr.in_equivalence)
3809             {
3810               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
3811                 {
3812                   for (e2 = e1; e2; e2 = e2->eq)
3813                     if (e2->expr->symtree->n.sym == sym)
3814                       goto equiv_found;
3815
3816                   continue;
3817
3818           equiv_found:
3819
3820                   for (e2 = e1; e2; e2 = e2->eq)
3821                     {
3822                       other = e2->expr->symtree->n.sym;
3823                       if (other->common_head
3824                           && other->common_head != sym->common_head)
3825                         {
3826                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
3827                                      "%C is being indirectly equivalenced to "
3828                                      "another COMMON block '%s'",
3829                                      sym->name, sym->common_head->name,
3830                                      other->common_head->name);
3831                             goto cleanup;
3832                         }
3833                       other->attr.in_common = 1;
3834                       other->common_head = t;
3835                     }
3836                 }
3837             }
3838
3839
3840           gfc_gobble_whitespace ();
3841           if (gfc_match_eos () == MATCH_YES)
3842             goto done;
3843           if (gfc_peek_ascii_char () == '/')
3844             break;
3845           if (gfc_match_char (',') != MATCH_YES)
3846             goto syntax;
3847           gfc_gobble_whitespace ();
3848           if (gfc_peek_ascii_char () == '/')
3849             break;
3850         }
3851     }
3852
3853 done:
3854   return MATCH_YES;
3855
3856 syntax:
3857   gfc_syntax_error (ST_COMMON);
3858
3859 cleanup:
3860   if (old_blank_common)
3861     old_blank_common->common_next = NULL;
3862   else
3863     gfc_current_ns->blank_common.head = NULL;
3864   gfc_free_array_spec (as);
3865   return MATCH_ERROR;
3866 }
3867
3868
3869 /* Match a BLOCK DATA program unit.  */
3870
3871 match
3872 gfc_match_block_data (void)
3873 {
3874   char name[GFC_MAX_SYMBOL_LEN + 1];
3875   gfc_symbol *sym;
3876   match m;
3877
3878   if (gfc_match_eos () == MATCH_YES)
3879     {
3880       gfc_new_block = NULL;
3881       return MATCH_YES;
3882     }
3883
3884   m = gfc_match ("% %n%t", name);
3885   if (m != MATCH_YES)
3886     return MATCH_ERROR;
3887
3888   if (gfc_get_symbol (name, NULL, &sym))
3889     return MATCH_ERROR;
3890
3891   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
3892     return MATCH_ERROR;
3893
3894   gfc_new_block = sym;
3895
3896   return MATCH_YES;
3897 }
3898
3899
3900 /* Free a namelist structure.  */
3901
3902 void
3903 gfc_free_namelist (gfc_namelist *name)
3904 {
3905   gfc_namelist *n;
3906
3907   for (; name; name = n)
3908     {
3909       n = name->next;
3910       gfc_free (name);
3911     }
3912 }
3913
3914
3915 /* Match a NAMELIST statement.  */
3916
3917 match
3918 gfc_match_namelist (void)
3919 {
3920   gfc_symbol *group_name, *sym;
3921   gfc_namelist *nl;
3922   match m, m2;
3923
3924   m = gfc_match (" / %s /", &group_name);
3925   if (m == MATCH_NO)
3926     goto syntax;
3927   if (m == MATCH_ERROR)
3928     goto error;
3929
3930   for (;;)
3931     {
3932       if (group_name->ts.type != BT_UNKNOWN)
3933         {
3934           gfc_error ("Namelist group name '%s' at %C already has a basic "
3935                      "type of %s", group_name->name,
3936                      gfc_typename (&group_name->ts));
3937           return MATCH_ERROR;
3938         }
3939
3940       if (group_name->attr.flavor == FL_NAMELIST
3941           && group_name->attr.use_assoc
3942           && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
3943                              "at %C already is USE associated and can"
3944                              "not be respecified.", group_name->name)
3945              == FAILURE)
3946         return MATCH_ERROR;
3947
3948       if (group_name->attr.flavor != FL_NAMELIST
3949           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
3950                              group_name->name, NULL) == FAILURE)
3951         return MATCH_ERROR;
3952
3953       for (;;)
3954         {
3955           m = gfc_match_symbol (&sym, 1);
3956           if (m == MATCH_NO)
3957             goto syntax;
3958           if (m == MATCH_ERROR)
3959             goto error;
3960
3961           if (sym->attr.in_namelist == 0
3962               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
3963             goto error;
3964
3965           /* Use gfc_error_check here, rather than goto error, so that
3966              these are the only errors for the next two lines.  */
3967           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3968             {
3969               gfc_error ("Assumed size array '%s' in namelist '%s' at "
3970                          "%C is not allowed", sym->name, group_name->name);
3971               gfc_error_check ();
3972             }
3973
3974           if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl->length == NULL)
3975             {
3976               gfc_error ("Assumed character length '%s' in namelist '%s' at "
3977                          "%C is not allowed", sym->name, group_name->name);
3978               gfc_error_check ();
3979             }
3980
3981           nl = gfc_get_namelist ();
3982           nl->sym = sym;
3983           sym->refs++;
3984
3985           if (group_name->namelist == NULL)
3986             group_name->namelist = group_name->namelist_tail = nl;
3987           else
3988             {
3989               group_name->namelist_tail->next = nl;
3990               group_name->namelist_tail = nl;
3991             }
3992
3993           if (gfc_match_eos () == MATCH_YES)
3994             goto done;
3995
3996           m = gfc_match_char (',');
3997
3998           if (gfc_match_char ('/') == MATCH_YES)
3999             {
4000               m2 = gfc_match (" %s /", &group_name);
4001               if (m2 == MATCH_YES)
4002                 break;
4003               if (m2 == MATCH_ERROR)
4004                 goto error;
4005               goto syntax;
4006             }
4007
4008           if (m != MATCH_YES)
4009             goto syntax;
4010         }
4011     }
4012
4013 done:
4014   return MATCH_YES;
4015
4016 syntax:
4017   gfc_syntax_error (ST_NAMELIST);
4018
4019 error:
4020   return MATCH_ERROR;
4021 }
4022
4023
4024 /* Match a MODULE statement.  */
4025
4026 match
4027 gfc_match_module (void)
4028 {
4029   match m;
4030
4031   m = gfc_match (" %s%t", &gfc_new_block);
4032   if (m != MATCH_YES)
4033     return m;
4034
4035   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
4036                       gfc_new_block->name, NULL) == FAILURE)
4037     return MATCH_ERROR;
4038
4039   return MATCH_YES;
4040 }
4041
4042
4043 /* Free equivalence sets and lists.  Recursively is the easiest way to
4044    do this.  */
4045
4046 void
4047 gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
4048 {
4049   if (eq == stop)
4050     return;
4051
4052   gfc_free_equiv (eq->eq);
4053   gfc_free_equiv_until (eq->next, stop);
4054   gfc_free_expr (eq->expr);
4055   gfc_free (eq);
4056 }
4057
4058
4059 void
4060 gfc_free_equiv (gfc_equiv *eq)
4061 {
4062   gfc_free_equiv_until (eq, NULL);
4063 }
4064
4065
4066 /* Match an EQUIVALENCE statement.  */
4067
4068 match
4069 gfc_match_equivalence (void)
4070 {
4071   gfc_equiv *eq, *set, *tail;
4072   gfc_ref *ref;
4073   gfc_symbol *sym;
4074   match m;
4075   gfc_common_head *common_head = NULL;
4076   bool common_flag;
4077   int cnt;
4078
4079   tail = NULL;
4080
4081   for (;;)
4082     {
4083       eq = gfc_get_equiv ();
4084       if (tail == NULL)
4085         tail = eq;
4086
4087       eq->next = gfc_current_ns->equiv;
4088       gfc_current_ns->equiv = eq;
4089
4090       if (gfc_match_char ('(') != MATCH_YES)
4091         goto syntax;
4092
4093       set = eq;
4094       common_flag = FALSE;
4095       cnt = 0;
4096
4097       for (;;)
4098         {
4099           m = gfc_match_equiv_variable (&set->expr);
4100           if (m == MATCH_ERROR)
4101             goto cleanup;
4102           if (m == MATCH_NO)
4103             goto syntax;
4104
4105           /*  count the number of objects.  */
4106           cnt++;
4107
4108           if (gfc_match_char ('%') == MATCH_YES)
4109             {
4110               gfc_error ("Derived type component %C is not a "
4111                          "permitted EQUIVALENCE member");
4112               goto cleanup;
4113             }
4114
4115           for (ref = set->expr->ref; ref; ref = ref->next)
4116             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
4117               {
4118                 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4119                            "be an array section");
4120                 goto cleanup;
4121               }
4122
4123           sym = set->expr->symtree->n.sym;
4124
4125           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
4126             goto cleanup;
4127
4128           if (sym->attr.in_common)
4129             {
4130               common_flag = TRUE;
4131               common_head = sym->common_head;
4132             }
4133
4134           if (gfc_match_char (')') == MATCH_YES)
4135             break;
4136
4137           if (gfc_match_char (',') != MATCH_YES)
4138             goto syntax;
4139
4140           set->eq = gfc_get_equiv ();
4141           set = set->eq;
4142         }
4143
4144       if (cnt < 2)
4145         {
4146           gfc_error ("EQUIVALENCE at %C requires two or more objects");
4147           goto cleanup;
4148         }
4149
4150       /* If one of the members of an equivalence is in common, then
4151          mark them all as being in common.  Before doing this, check
4152          that members of the equivalence group are not in different
4153          common blocks.  */
4154       if (common_flag)
4155         for (set = eq; set; set = set->eq)
4156           {
4157             sym = set->expr->symtree->n.sym;
4158             if (sym->common_head && sym->common_head != common_head)
4159               {
4160                 gfc_error ("Attempt to indirectly overlap COMMON "
4161                            "blocks %s and %s by EQUIVALENCE at %C",
4162                            sym->common_head->name, common_head->name);
4163                 goto cleanup;
4164               }
4165             sym->attr.in_common = 1;
4166             sym->common_head = common_head;
4167           }
4168
4169       if (gfc_match_eos () == MATCH_YES)
4170         break;
4171       if (gfc_match_char (',') != MATCH_YES)
4172         {
4173           gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4174           goto cleanup;
4175         }
4176     }
4177
4178   return MATCH_YES;
4179
4180 syntax:
4181   gfc_syntax_error (ST_EQUIVALENCE);
4182
4183 cleanup:
4184   eq = tail->next;
4185   tail->next = NULL;
4186
4187   gfc_free_equiv (gfc_current_ns->equiv);
4188   gfc_current_ns->equiv = eq;
4189
4190   return MATCH_ERROR;
4191 }
4192
4193
4194 /* Check that a statement function is not recursive. This is done by looking
4195    for the statement function symbol(sym) by looking recursively through its
4196    expression(e).  If a reference to sym is found, true is returned.
4197    12.5.4 requires that any variable of function that is implicitly typed
4198    shall have that type confirmed by any subsequent type declaration.  The
4199    implicit typing is conveniently done here.  */
4200 static bool
4201 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
4202
4203 static bool
4204 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
4205 {
4206
4207   if (e == NULL)
4208     return false;
4209
4210   switch (e->expr_type)
4211     {
4212     case EXPR_FUNCTION:
4213       if (e->symtree == NULL)
4214         return false;
4215
4216       /* Check the name before testing for nested recursion!  */
4217       if (sym->name == e->symtree->n.sym->name)
4218         return true;
4219
4220       /* Catch recursion via other statement functions.  */
4221       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
4222           && e->symtree->n.sym->value
4223           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
4224         return true;
4225
4226       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4227         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4228
4229       break;
4230
4231     case EXPR_VARIABLE:
4232       if (e->symtree && sym->name == e->symtree->n.sym->name)
4233         return true;
4234
4235       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4236         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4237       break;
4238
4239     default:
4240       break;
4241     }
4242
4243   return false;
4244 }
4245
4246
4247 static bool
4248 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
4249 {
4250   return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
4251 }
4252
4253
4254 /* Match a statement function declaration.  It is so easy to match
4255    non-statement function statements with a MATCH_ERROR as opposed to
4256    MATCH_NO that we suppress error message in most cases.  */
4257
4258 match
4259 gfc_match_st_function (void)
4260 {
4261   gfc_error_buf old_error;
4262   gfc_symbol *sym;
4263   gfc_expr *expr;
4264   match m;
4265
4266   m = gfc_match_symbol (&sym, 0);
4267   if (m != MATCH_YES)
4268     return m;
4269
4270   gfc_push_error (&old_error);
4271
4272   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
4273                          sym->name, NULL) == FAILURE)
4274     goto undo_error;
4275
4276   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
4277     goto undo_error;
4278
4279   m = gfc_match (" = %e%t", &expr);
4280   if (m == MATCH_NO)
4281     goto undo_error;
4282
4283   gfc_free_error (&old_error);
4284   if (m == MATCH_ERROR)
4285     return m;
4286
4287   if (recursive_stmt_fcn (expr, sym))
4288     {
4289       gfc_error ("Statement function at %L is recursive", &expr->where);
4290       return MATCH_ERROR;
4291     }
4292
4293   sym->value = expr;
4294
4295   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
4296                       "Statement function at %C") == FAILURE)
4297     return MATCH_ERROR;
4298
4299   return MATCH_YES;
4300
4301 undo_error:
4302   gfc_pop_error (&old_error);
4303   return MATCH_NO;
4304 }
4305
4306
4307 /***************** SELECT CASE subroutines ******************/
4308
4309 /* Free a single case structure.  */
4310
4311 static void
4312 free_case (gfc_case *p)
4313 {
4314   if (p->low == p->high)
4315     p->high = NULL;
4316   gfc_free_expr (p->low);
4317   gfc_free_expr (p->high);
4318   gfc_free (p);
4319 }
4320
4321
4322 /* Free a list of case structures.  */
4323
4324 void
4325 gfc_free_case_list (gfc_case *p)
4326 {
4327   gfc_case *q;
4328
4329   for (; p; p = q)
4330     {
4331       q = p->next;
4332       free_case (p);
4333     }
4334 }
4335
4336
4337 /* Match a single case selector.  */
4338
4339 static match
4340 match_case_selector (gfc_case **cp)
4341 {
4342   gfc_case *c;
4343   match m;
4344
4345   c = gfc_get_case ();
4346   c->where = gfc_current_locus;
4347
4348   if (gfc_match_char (':') == MATCH_YES)
4349     {
4350       m = gfc_match_init_expr (&c->high);
4351       if (m == MATCH_NO)
4352         goto need_expr;
4353       if (m == MATCH_ERROR)
4354         goto cleanup;
4355     }
4356   else
4357     {
4358       m = gfc_match_init_expr (&c->low);
4359       if (m == MATCH_ERROR)
4360         goto cleanup;
4361       if (m == MATCH_NO)
4362         goto need_expr;
4363
4364       /* If we're not looking at a ':' now, make a range out of a single
4365          target.  Else get the upper bound for the case range.  */
4366       if (gfc_match_char (':') != MATCH_YES)
4367         c->high = c->low;
4368       else
4369         {
4370           m = gfc_match_init_expr (&c->high);
4371           if (m == MATCH_ERROR)
4372             goto cleanup;
4373           /* MATCH_NO is fine.  It's OK if nothing is there!  */
4374         }
4375     }
4376
4377   *cp = c;
4378   return MATCH_YES;
4379
4380 need_expr:
4381   gfc_error ("Expected initialization expression in CASE at %C");
4382
4383 cleanup:
4384   free_case (c);
4385   return MATCH_ERROR;
4386 }
4387
4388
4389 /* Match the end of a case statement.  */
4390
4391 static match
4392 match_case_eos (void)
4393 {
4394   char name[GFC_MAX_SYMBOL_LEN + 1];
4395   match m;
4396
4397   if (gfc_match_eos () == MATCH_YES)
4398     return MATCH_YES;
4399
4400   /* If the case construct doesn't have a case-construct-name, we
4401      should have matched the EOS.  */
4402   if (!gfc_current_block ())
4403     return MATCH_NO;
4404
4405   gfc_gobble_whitespace ();
4406
4407   m = gfc_match_name (name);
4408   if (m != MATCH_YES)
4409     return m;
4410
4411   if (strcmp (name, gfc_current_block ()->name) != 0)
4412     {
4413       gfc_error ("Expected block name '%s' of SELECT construct at %C",
4414                  gfc_current_block ()->name);
4415       return MATCH_ERROR;
4416     }
4417
4418   return gfc_match_eos ();
4419 }
4420
4421
4422 /* Match a SELECT statement.  */
4423
4424 match
4425 gfc_match_select (void)
4426 {
4427   gfc_expr *expr;
4428   match m;
4429
4430   m = gfc_match_label ();
4431   if (m == MATCH_ERROR)
4432     return m;
4433
4434   m = gfc_match (" select case ( %e )%t", &expr);
4435   if (m != MATCH_YES)
4436     return m;
4437
4438   new_st.op = EXEC_SELECT;
4439   new_st.expr1 = expr;
4440
4441   return MATCH_YES;
4442 }
4443
4444
4445 /* Push the current selector onto the SELECT TYPE stack.  */
4446
4447 static void
4448 select_type_push (gfc_symbol *sel)
4449 {
4450   gfc_select_type_stack *top = gfc_get_select_type_stack ();
4451   top->selector = sel;
4452   top->tmp = NULL;
4453   top->prev = select_type_stack;
4454
4455   select_type_stack = top;
4456 }
4457
4458
4459 /* Set the temporary for the current SELECT TYPE selector.  */
4460
4461 static void
4462 select_type_set_tmp (gfc_typespec *ts)
4463 {
4464   char name[GFC_MAX_SYMBOL_LEN];
4465   gfc_symtree *tmp;
4466
4467   if (!ts)
4468     {
4469       select_type_stack->tmp = NULL;
4470       return;
4471     }
4472
4473   if (!gfc_type_is_extensible (ts->u.derived))
4474     return;
4475
4476   if (ts->type == BT_CLASS)
4477     sprintf (name, "tmp$class$%s", ts->u.derived->name);
4478   else
4479     sprintf (name, "tmp$type$%s", ts->u.derived->name);
4480   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
4481   gfc_add_type (tmp->n.sym, ts, NULL);
4482   gfc_set_sym_referenced (tmp->n.sym);
4483   gfc_add_pointer (&tmp->n.sym->attr, NULL);
4484   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
4485   if (ts->type == BT_CLASS)
4486     {
4487       gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
4488                               &tmp->n.sym->as, false);
4489       tmp->n.sym->attr.class_ok = 1;
4490     }
4491
4492   /* Add an association for it, so the rest of the parser knows it is
4493      an associate-name.  The target will be set during resolution.  */
4494   tmp->n.sym->assoc = gfc_get_association_list ();
4495   tmp->n.sym->assoc->dangling = 1;
4496   tmp->n.sym->assoc->st = tmp;
4497
4498   select_type_stack->tmp = tmp;
4499 }
4500
4501
4502 /* Match a SELECT TYPE statement.  */
4503
4504 match
4505 gfc_match_select_type (void)
4506 {
4507   gfc_expr *expr1, *expr2 = NULL;
4508   match m;
4509   char name[GFC_MAX_SYMBOL_LEN];
4510
4511   m = gfc_match_label ();
4512   if (m == MATCH_ERROR)
4513     return m;
4514
4515   m = gfc_match (" select type ( ");
4516   if (m != MATCH_YES)
4517     return m;
4518
4519   gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
4520
4521   m = gfc_match (" %n => %e", name, &expr2);
4522   if (m == MATCH_YES)
4523     {
4524       expr1 = gfc_get_expr();
4525       expr1->expr_type = EXPR_VARIABLE;
4526       if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
4527         {
4528           m = MATCH_ERROR;
4529           goto cleanup;
4530         }
4531       if (expr2->ts.type == BT_UNKNOWN)
4532         expr1->symtree->n.sym->attr.untyped = 1;
4533       else
4534         expr1->symtree->n.sym->ts = expr2->ts;
4535       expr1->symtree->n.sym->attr.referenced = 1;
4536       expr1->symtree->n.sym->attr.class_ok = 1;
4537     }
4538   else
4539     {
4540       m = gfc_match (" %e ", &expr1);
4541       if (m != MATCH_YES)
4542         goto cleanup;
4543     }
4544
4545   m = gfc_match (" )%t");
4546   if (m != MATCH_YES)
4547     goto cleanup;
4548
4549   /* Check for F03:C811.  */
4550   if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
4551     {
4552       gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
4553                  "use associate-name=>");
4554       m = MATCH_ERROR;
4555       goto cleanup;
4556     }
4557
4558   new_st.op = EXEC_SELECT_TYPE;
4559   new_st.expr1 = expr1;
4560   new_st.expr2 = expr2;
4561   new_st.ext.block.ns = gfc_current_ns;
4562
4563   select_type_push (expr1->symtree->n.sym);
4564
4565   return MATCH_YES;
4566
4567 cleanup:
4568   gfc_current_ns = gfc_current_ns->parent;
4569   return m;
4570 }
4571
4572
4573 /* Match a CASE statement.  */
4574
4575 match
4576 gfc_match_case (void)
4577 {
4578   gfc_case *c, *head, *tail;
4579   match m;
4580
4581   head = tail = NULL;
4582
4583   if (gfc_current_state () != COMP_SELECT)
4584     {
4585       gfc_error ("Unexpected CASE statement at %C");
4586       return MATCH_ERROR;
4587     }
4588
4589   if (gfc_match ("% default") == MATCH_YES)
4590     {
4591       m = match_case_eos ();
4592       if (m == MATCH_NO)
4593         goto syntax;
4594       if (m == MATCH_ERROR)
4595         goto cleanup;
4596
4597       new_st.op = EXEC_SELECT;
4598       c = gfc_get_case ();
4599       c->where = gfc_current_locus;
4600       new_st.ext.case_list = c;
4601       return MATCH_YES;
4602     }
4603
4604   if (gfc_match_char ('(') != MATCH_YES)
4605     goto syntax;
4606
4607   for (;;)
4608     {
4609       if (match_case_selector (&c) == MATCH_ERROR)
4610         goto cleanup;
4611
4612       if (head == NULL)
4613         head = c;
4614       else
4615         tail->next = c;
4616
4617       tail = c;
4618
4619       if (gfc_match_char (')') == MATCH_YES)
4620         break;
4621       if (gfc_match_char (',') != MATCH_YES)
4622         goto syntax;
4623     }
4624
4625   m = match_case_eos ();
4626   if (m == MATCH_NO)
4627     goto syntax;
4628   if (m == MATCH_ERROR)
4629     goto cleanup;
4630
4631   new_st.op = EXEC_SELECT;
4632   new_st.ext.case_list = head;
4633
4634   return MATCH_YES;
4635
4636 syntax:
4637   gfc_error ("Syntax error in CASE specification at %C");
4638
4639 cleanup:
4640   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
4641   return MATCH_ERROR;
4642 }
4643
4644
4645 /* Match a TYPE IS statement.  */
4646
4647 match
4648 gfc_match_type_is (void)
4649 {
4650   gfc_case *c = NULL;
4651   match m;
4652
4653   if (gfc_current_state () != COMP_SELECT_TYPE)
4654     {
4655       gfc_error ("Unexpected TYPE IS statement at %C");
4656       return MATCH_ERROR;
4657     }
4658
4659   if (gfc_match_char ('(') != MATCH_YES)
4660     goto syntax;
4661
4662   c = gfc_get_case ();
4663   c->where = gfc_current_locus;
4664
4665   /* TODO: Once unlimited polymorphism is implemented, we will need to call
4666      match_type_spec here.  */
4667   if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
4668     goto cleanup;
4669
4670   if (gfc_match_char (')') != MATCH_YES)
4671     goto syntax;
4672
4673   m = match_case_eos ();
4674   if (m == MATCH_NO)
4675     goto syntax;
4676   if (m == MATCH_ERROR)
4677     goto cleanup;
4678
4679   new_st.op = EXEC_SELECT_TYPE;
4680   new_st.ext.case_list = c;
4681
4682   /* Create temporary variable.  */
4683   select_type_set_tmp (&c->ts);
4684
4685   return MATCH_YES;
4686
4687 syntax:
4688   gfc_error ("Syntax error in TYPE IS specification at %C");
4689
4690 cleanup:
4691   if (c != NULL)
4692     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
4693   return MATCH_ERROR;
4694 }
4695
4696
4697 /* Match a CLASS IS or CLASS DEFAULT statement.  */
4698
4699 match
4700 gfc_match_class_is (void)
4701 {
4702   gfc_case *c = NULL;
4703   match m;
4704
4705   if (gfc_current_state () != COMP_SELECT_TYPE)
4706     return MATCH_NO;
4707
4708   if (gfc_match ("% default") == MATCH_YES)
4709     {
4710       m = match_case_eos ();
4711       if (m == MATCH_NO)
4712         goto syntax;
4713       if (m == MATCH_ERROR)
4714         goto cleanup;
4715
4716       new_st.op = EXEC_SELECT_TYPE;
4717       c = gfc_get_case ();
4718       c->where = gfc_current_locus;
4719       c->ts.type = BT_UNKNOWN;
4720       new_st.ext.case_list = c;
4721       select_type_set_tmp (NULL);
4722       return MATCH_YES;
4723     }
4724
4725   m = gfc_match ("% is");
4726   if (m == MATCH_NO)
4727     goto syntax;
4728   if (m == MATCH_ERROR)
4729     goto cleanup;
4730
4731   if (gfc_match_char ('(') != MATCH_YES)
4732     goto syntax;
4733
4734   c = gfc_get_case ();
4735   c->where = gfc_current_locus;
4736
4737   if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
4738     goto cleanup;
4739
4740   if (c->ts.type == BT_DERIVED)
4741     c->ts.type = BT_CLASS;
4742
4743   if (gfc_match_char (')') != MATCH_YES)
4744     goto syntax;
4745
4746   m = match_case_eos ();
4747   if (m == MATCH_NO)
4748     goto syntax;
4749   if (m == MATCH_ERROR)
4750     goto cleanup;
4751
4752   new_st.op = EXEC_SELECT_TYPE;
4753   new_st.ext.case_list = c;
4754
4755   /* Create temporary variable.  */
4756   select_type_set_tmp (&c->ts);
4757
4758   return MATCH_YES;
4759
4760 syntax:
4761   gfc_error ("Syntax error in CLASS IS specification at %C");
4762
4763 cleanup:
4764   if (c != NULL)
4765     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
4766   return MATCH_ERROR;
4767 }
4768
4769
4770 /********************* WHERE subroutines ********************/
4771
4772 /* Match the rest of a simple WHERE statement that follows an IF statement.
4773  */
4774
4775 static match
4776 match_simple_where (void)
4777 {
4778   gfc_expr *expr;
4779   gfc_code *c;
4780   match m;
4781
4782   m = gfc_match (" ( %e )", &expr);
4783   if (m != MATCH_YES)
4784     return m;
4785
4786   m = gfc_match_assignment ();
4787   if (m == MATCH_NO)
4788     goto syntax;
4789   if (m == MATCH_ERROR)
4790     goto cleanup;
4791
4792   if (gfc_match_eos () != MATCH_YES)
4793     goto syntax;
4794
4795   c = gfc_get_code ();
4796
4797   c->op = EXEC_WHERE;
4798   c->expr1 = expr;
4799   c->next = gfc_get_code ();
4800
4801   *c->next = new_st;
4802   gfc_clear_new_st ();
4803
4804   new_st.op = EXEC_WHERE;
4805   new_st.block = c;
4806
4807   return MATCH_YES;
4808
4809 syntax:
4810   gfc_syntax_error (ST_WHERE);
4811
4812 cleanup:
4813   gfc_free_expr (expr);
4814   return MATCH_ERROR;
4815 }
4816
4817
4818 /* Match a WHERE statement.  */
4819
4820 match
4821 gfc_match_where (gfc_statement *st)
4822 {
4823   gfc_expr *expr;
4824   match m0, m;
4825   gfc_code *c;
4826
4827   m0 = gfc_match_label ();
4828   if (m0 == MATCH_ERROR)
4829     return m0;
4830
4831   m = gfc_match (" where ( %e )", &expr);
4832   if (m != MATCH_YES)
4833     return m;
4834
4835   if (gfc_match_eos () == MATCH_YES)
4836     {
4837       *st = ST_WHERE_BLOCK;
4838       new_st.op = EXEC_WHERE;
4839       new_st.expr1 = expr;
4840       return MATCH_YES;
4841     }
4842
4843   m = gfc_match_assignment ();
4844   if (m == MATCH_NO)
4845     gfc_syntax_error (ST_WHERE);
4846
4847   if (m != MATCH_YES)
4848     {
4849       gfc_free_expr (expr);
4850       return MATCH_ERROR;
4851     }
4852
4853   /* We've got a simple WHERE statement.  */
4854   *st = ST_WHERE;
4855   c = gfc_get_code ();
4856
4857   c->op = EXEC_WHERE;
4858   c->expr1 = expr;
4859   c->next = gfc_get_code ();
4860
4861   *c->next = new_st;
4862   gfc_clear_new_st ();
4863
4864   new_st.op = EXEC_WHERE;
4865   new_st.block = c;
4866
4867   return MATCH_YES;
4868 }
4869
4870
4871 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
4872    new_st if successful.  */
4873
4874 match
4875 gfc_match_elsewhere (void)
4876 {
4877   char name[GFC_MAX_SYMBOL_LEN + 1];
4878   gfc_expr *expr;
4879   match m;
4880
4881   if (gfc_current_state () != COMP_WHERE)
4882     {
4883       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
4884       return MATCH_ERROR;
4885     }
4886
4887   expr = NULL;
4888
4889   if (gfc_match_char ('(') == MATCH_YES)
4890     {
4891       m = gfc_match_expr (&expr);
4892       if (m == MATCH_NO)
4893         goto syntax;
4894       if (m == MATCH_ERROR)
4895         return MATCH_ERROR;
4896
4897       if (gfc_match_char (')') != MATCH_YES)
4898         goto syntax;
4899     }
4900
4901   if (gfc_match_eos () != MATCH_YES)
4902     {
4903       /* Only makes sense if we have a where-construct-name.  */
4904       if (!gfc_current_block ())
4905         {
4906           m = MATCH_ERROR;
4907           goto cleanup;
4908         }
4909       /* Better be a name at this point.  */
4910       m = gfc_match_name (name);
4911       if (m == MATCH_NO)
4912         goto syntax;
4913       if (m == MATCH_ERROR)
4914         goto cleanup;
4915
4916       if (gfc_match_eos () != MATCH_YES)
4917         goto syntax;
4918
4919       if (strcmp (name, gfc_current_block ()->name) != 0)
4920         {
4921           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
4922                      name, gfc_current_block ()->name);
4923           goto cleanup;
4924         }
4925     }
4926
4927   new_st.op = EXEC_WHERE;
4928   new_st.expr1 = expr;
4929   return MATCH_YES;
4930
4931 syntax:
4932   gfc_syntax_error (ST_ELSEWHERE);
4933
4934 cleanup:
4935   gfc_free_expr (expr);
4936   return MATCH_ERROR;
4937 }
4938
4939
4940 /******************** FORALL subroutines ********************/
4941
4942 /* Free a list of FORALL iterators.  */
4943
4944 void
4945 gfc_free_forall_iterator (gfc_forall_iterator *iter)
4946 {
4947   gfc_forall_iterator *next;
4948
4949   while (iter)
4950     {
4951       next = iter->next;
4952       gfc_free_expr (iter->var);
4953       gfc_free_expr (iter->start);
4954       gfc_free_expr (iter->end);
4955       gfc_free_expr (iter->stride);
4956       gfc_free (iter);
4957       iter = next;
4958     }
4959 }
4960
4961
4962 /* Match an iterator as part of a FORALL statement.  The format is:
4963
4964      <var> = <start>:<end>[:<stride>]
4965
4966    On MATCH_NO, the caller tests for the possibility that there is a
4967    scalar mask expression.  */
4968
4969 static match
4970 match_forall_iterator (gfc_forall_iterator **result)
4971 {
4972   gfc_forall_iterator *iter;
4973   locus where;
4974   match m;
4975
4976   where = gfc_current_locus;
4977   iter = XCNEW (gfc_forall_iterator);
4978
4979   m = gfc_match_expr (&iter->var);
4980   if (m != MATCH_YES)
4981     goto cleanup;
4982
4983   if (gfc_match_char ('=') != MATCH_YES
4984       || iter->var->expr_type != EXPR_VARIABLE)
4985     {
4986       m = MATCH_NO;
4987       goto cleanup;
4988     }
4989
4990   m = gfc_match_expr (&iter->start);
4991   if (m != MATCH_YES)
4992     goto cleanup;
4993
4994   if (gfc_match_char (':') != MATCH_YES)
4995     goto syntax;
4996
4997   m = gfc_match_expr (&iter->end);
4998   if (m == MATCH_NO)
4999     goto syntax;
5000   if (m == MATCH_ERROR)
5001     goto cleanup;
5002
5003   if (gfc_match_char (':') == MATCH_NO)
5004     iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
5005   else
5006     {
5007       m = gfc_match_expr (&iter->stride);
5008       if (m == MATCH_NO)
5009         goto syntax;
5010       if (m == MATCH_ERROR)
5011         goto cleanup;
5012     }
5013
5014   /* Mark the iteration variable's symbol as used as a FORALL index.  */
5015   iter->var->symtree->n.sym->forall_index = true;
5016
5017   *result = iter;
5018   return MATCH_YES;
5019
5020 syntax:
5021   gfc_error ("Syntax error in FORALL iterator at %C");
5022   m = MATCH_ERROR;
5023
5024 cleanup:
5025
5026   gfc_current_locus = where;
5027   gfc_free_forall_iterator (iter);
5028   return m;
5029 }
5030
5031
5032 /* Match the header of a FORALL statement.  */
5033
5034 static match
5035 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
5036 {
5037   gfc_forall_iterator *head, *tail, *new_iter;
5038   gfc_expr *msk;
5039   match m;
5040
5041   gfc_gobble_whitespace ();
5042
5043   head = tail = NULL;
5044   msk = NULL;
5045
5046   if (gfc_match_char ('(') != MATCH_YES)
5047     return MATCH_NO;
5048
5049   m = match_forall_iterator (&new_iter);
5050   if (m == MATCH_ERROR)
5051     goto cleanup;
5052   if (m == MATCH_NO)
5053     goto syntax;
5054
5055   head = tail = new_iter;
5056
5057   for (;;)
5058     {
5059       if (gfc_match_char (',') != MATCH_YES)
5060         break;
5061
5062       m = match_forall_iterator (&new_iter);
5063       if (m == MATCH_ERROR)
5064         goto cleanup;
5065
5066       if (m == MATCH_YES)
5067         {
5068           tail->next = new_iter;
5069           tail = new_iter;
5070           continue;
5071         }
5072
5073       /* Have to have a mask expression.  */
5074
5075       m = gfc_match_expr (&msk);
5076       if (m == MATCH_NO)
5077         goto syntax;
5078       if (m == MATCH_ERROR)
5079         goto cleanup;
5080
5081       break;
5082     }
5083
5084   if (gfc_match_char (')') == MATCH_NO)
5085     goto syntax;
5086
5087   *phead = head;
5088   *mask = msk;
5089   return MATCH_YES;
5090
5091 syntax:
5092   gfc_syntax_error (ST_FORALL);
5093
5094 cleanup:
5095   gfc_free_expr (msk);
5096   gfc_free_forall_iterator (head);
5097
5098   return MATCH_ERROR;
5099 }
5100
5101 /* Match the rest of a simple FORALL statement that follows an
5102    IF statement.  */
5103
5104 static match
5105 match_simple_forall (void)
5106 {
5107   gfc_forall_iterator *head;
5108   gfc_expr *mask;
5109   gfc_code *c;
5110   match m;
5111
5112   mask = NULL;
5113   head = NULL;
5114   c = NULL;
5115
5116   m = match_forall_header (&head, &mask);
5117
5118   if (m == MATCH_NO)
5119     goto syntax;
5120   if (m != MATCH_YES)
5121     goto cleanup;
5122
5123   m = gfc_match_assignment ();
5124
5125   if (m == MATCH_ERROR)
5126     goto cleanup;
5127   if (m == MATCH_NO)
5128     {
5129       m = gfc_match_pointer_assignment ();
5130       if (m == MATCH_ERROR)
5131         goto cleanup;
5132       if (m == MATCH_NO)
5133         goto syntax;
5134     }
5135
5136   c = gfc_get_code ();
5137   *c = new_st;
5138   c->loc = gfc_current_locus;
5139
5140   if (gfc_match_eos () != MATCH_YES)
5141     goto syntax;
5142
5143   gfc_clear_new_st ();
5144   new_st.op = EXEC_FORALL;
5145   new_st.expr1 = mask;
5146   new_st.ext.forall_iterator = head;
5147   new_st.block = gfc_get_code ();
5148
5149   new_st.block->op = EXEC_FORALL;
5150   new_st.block->next = c;
5151
5152   return MATCH_YES;
5153
5154 syntax:
5155   gfc_syntax_error (ST_FORALL);
5156
5157 cleanup:
5158   gfc_free_forall_iterator (head);
5159   gfc_free_expr (mask);
5160
5161   return MATCH_ERROR;
5162 }
5163
5164
5165 /* Match a FORALL statement.  */
5166
5167 match
5168 gfc_match_forall (gfc_statement *st)
5169 {
5170   gfc_forall_iterator *head;
5171   gfc_expr *mask;
5172   gfc_code *c;
5173   match m0, m;
5174
5175   head = NULL;
5176   mask = NULL;
5177   c = NULL;
5178
5179   m0 = gfc_match_label ();
5180   if (m0 == MATCH_ERROR)
5181     return MATCH_ERROR;
5182
5183   m = gfc_match (" forall");
5184   if (m != MATCH_YES)
5185     return m;
5186
5187   m = match_forall_header (&head, &mask);
5188   if (m == MATCH_ERROR)
5189     goto cleanup;
5190   if (m == MATCH_NO)
5191     goto syntax;
5192
5193   if (gfc_match_eos () == MATCH_YES)
5194     {
5195       *st = ST_FORALL_BLOCK;
5196       new_st.op = EXEC_FORALL;
5197       new_st.expr1 = mask;
5198       new_st.ext.forall_iterator = head;
5199       return MATCH_YES;
5200     }
5201
5202   m = gfc_match_assignment ();
5203   if (m == MATCH_ERROR)
5204     goto cleanup;
5205   if (m == MATCH_NO)
5206     {
5207       m = gfc_match_pointer_assignment ();
5208       if (m == MATCH_ERROR)
5209         goto cleanup;
5210       if (m == MATCH_NO)
5211         goto syntax;
5212     }
5213
5214   c = gfc_get_code ();
5215   *c = new_st;
5216   c->loc = gfc_current_locus;
5217
5218   gfc_clear_new_st ();
5219   new_st.op = EXEC_FORALL;
5220   new_st.expr1 = mask;
5221   new_st.ext.forall_iterator = head;
5222   new_st.block = gfc_get_code ();
5223   new_st.block->op = EXEC_FORALL;
5224   new_st.block->next = c;
5225
5226   *st = ST_FORALL;
5227   return MATCH_YES;
5228
5229 syntax:
5230   gfc_syntax_error (ST_FORALL);
5231
5232 cleanup:
5233   gfc_free_forall_iterator (head);
5234   gfc_free_expr (mask);
5235   gfc_free_statements (c);
5236   return MATCH_NO;
5237 }