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