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