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