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, 2011
   4    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     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_implicit_pure (NULL))
1750     gfc_current_ns->proc_name->attr.implicit_pure = 0;
1751
1752   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C")
1753       == FAILURE)
1754     return MATCH_ERROR;
1755
1756   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
1757     {
1758        gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
1759        return MATCH_ERROR;
1760     }
1761
1762   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
1763     {
1764       gfc_error ("Nested CRITICAL block at %C");
1765       return MATCH_ERROR;
1766     }
1767
1768   new_st.op = EXEC_CRITICAL;
1769
1770   if (label != NULL
1771       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1772     return MATCH_ERROR;
1773
1774   return MATCH_YES;
1775 }
1776
1777
1778 /* Match a BLOCK statement.  */
1779
1780 match
1781 gfc_match_block (void)
1782 {
1783   match m;
1784
1785   if (gfc_match_label () == MATCH_ERROR)
1786     return MATCH_ERROR;
1787
1788   if (gfc_match (" block") != MATCH_YES)
1789     return MATCH_NO;
1790
1791   /* For this to be a correct BLOCK statement, the line must end now.  */
1792   m = gfc_match_eos ();
1793   if (m == MATCH_ERROR)
1794     return MATCH_ERROR;
1795   if (m == MATCH_NO)
1796     return MATCH_NO;
1797
1798   return MATCH_YES;
1799 }
1800
1801
1802 /* Match an ASSOCIATE statement.  */
1803
1804 match
1805 gfc_match_associate (void)
1806 {
1807   if (gfc_match_label () == MATCH_ERROR)
1808     return MATCH_ERROR;
1809
1810   if (gfc_match (" associate") != MATCH_YES)
1811     return MATCH_NO;
1812
1813   /* Match the association list.  */
1814   if (gfc_match_char ('(') != MATCH_YES)
1815     {
1816       gfc_error ("Expected association list at %C");
1817       return MATCH_ERROR;
1818     }
1819   new_st.ext.block.assoc = NULL;
1820   while (true)
1821     {
1822       gfc_association_list* newAssoc = gfc_get_association_list ();
1823       gfc_association_list* a;
1824
1825       /* Match the next association.  */
1826       if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
1827             != MATCH_YES)
1828         {
1829           gfc_error ("Expected association at %C");
1830           goto assocListError;
1831         }
1832       newAssoc->where = gfc_current_locus;
1833
1834       /* Check that the current name is not yet in the list.  */
1835       for (a = new_st.ext.block.assoc; a; a = a->next)
1836         if (!strcmp (a->name, newAssoc->name))
1837           {
1838             gfc_error ("Duplicate name '%s' in association at %C",
1839                        newAssoc->name);
1840             goto assocListError;
1841           }
1842
1843       /* The target expression must not be coindexed.  */
1844       if (gfc_is_coindexed (newAssoc->target))
1845         {
1846           gfc_error ("Association target at %C must not be coindexed");
1847           goto assocListError;
1848         }
1849
1850       /* The `variable' field is left blank for now; because the target is not
1851          yet resolved, we can't use gfc_has_vector_subscript to determine it
1852          for now.  This is set during resolution.  */
1853
1854       /* Put it into the list.  */
1855       newAssoc->next = new_st.ext.block.assoc;
1856       new_st.ext.block.assoc = newAssoc;
1857
1858       /* Try next one or end if closing parenthesis is found.  */
1859       gfc_gobble_whitespace ();
1860       if (gfc_peek_char () == ')')
1861         break;
1862       if (gfc_match_char (',') != MATCH_YES)
1863         {
1864           gfc_error ("Expected ')' or ',' at %C");
1865           return MATCH_ERROR;
1866         }
1867
1868       continue;
1869
1870 assocListError:
1871       free (newAssoc);
1872       goto error;
1873     }
1874   if (gfc_match_char (')') != MATCH_YES)
1875     {
1876       /* This should never happen as we peek above.  */
1877       gcc_unreachable ();
1878     }
1879
1880   if (gfc_match_eos () != MATCH_YES)
1881     {
1882       gfc_error ("Junk after ASSOCIATE statement at %C");
1883       goto error;
1884     }
1885
1886   return MATCH_YES;
1887
1888 error:
1889   gfc_free_association_list (new_st.ext.block.assoc);
1890   return MATCH_ERROR;
1891 }
1892
1893
1894 /* Match a DO statement.  */
1895
1896 match
1897 gfc_match_do (void)
1898 {
1899   gfc_iterator iter, *ip;
1900   locus old_loc;
1901   gfc_st_label *label;
1902   match m;
1903
1904   old_loc = gfc_current_locus;
1905
1906   label = NULL;
1907   iter.var = iter.start = iter.end = iter.step = NULL;
1908
1909   m = gfc_match_label ();
1910   if (m == MATCH_ERROR)
1911     return m;
1912
1913   if (gfc_match (" do") != MATCH_YES)
1914     return MATCH_NO;
1915
1916   m = gfc_match_st_label (&label);
1917   if (m == MATCH_ERROR)
1918     goto cleanup;
1919
1920   /* Match an infinite DO, make it like a DO WHILE(.TRUE.).  */
1921
1922   if (gfc_match_eos () == MATCH_YES)
1923     {
1924       iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
1925       new_st.op = EXEC_DO_WHILE;
1926       goto done;
1927     }
1928
1929   /* Match an optional comma, if no comma is found, a space is obligatory.  */
1930   if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
1931     return MATCH_NO;
1932
1933   /* Check for balanced parens.  */
1934
1935   if (gfc_match_parens () == MATCH_ERROR)
1936     return MATCH_ERROR;
1937
1938   /* See if we have a DO WHILE.  */
1939   if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1940     {
1941       new_st.op = EXEC_DO_WHILE;
1942       goto done;
1943     }
1944
1945   /* The abortive DO WHILE may have done something to the symbol
1946      table, so we start over.  */
1947   gfc_undo_symbols ();
1948   gfc_current_locus = old_loc;
1949
1950   gfc_match_label ();           /* This won't error.  */
1951   gfc_match (" do ");           /* This will work.  */
1952
1953   gfc_match_st_label (&label);  /* Can't error out.  */
1954   gfc_match_char (',');         /* Optional comma.  */
1955
1956   m = gfc_match_iterator (&iter, 0);
1957   if (m == MATCH_NO)
1958     return MATCH_NO;
1959   if (m == MATCH_ERROR)
1960     goto cleanup;
1961
1962   iter.var->symtree->n.sym->attr.implied_index = 0;
1963   gfc_check_do_variable (iter.var->symtree);
1964
1965   if (gfc_match_eos () != MATCH_YES)
1966     {
1967       gfc_syntax_error (ST_DO);
1968       goto cleanup;
1969     }
1970
1971   new_st.op = EXEC_DO;
1972
1973 done:
1974   if (label != NULL
1975       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1976     goto cleanup;
1977
1978   new_st.label1 = label;
1979
1980   if (new_st.op == EXEC_DO_WHILE)
1981     new_st.expr1 = iter.end;
1982   else
1983     {
1984       new_st.ext.iterator = ip = gfc_get_iterator ();
1985       *ip = iter;
1986     }
1987
1988   return MATCH_YES;
1989
1990 cleanup:
1991   gfc_free_iterator (&iter, 0);
1992
1993   return MATCH_ERROR;
1994 }
1995
1996
1997 /* Match an EXIT or CYCLE statement.  */
1998
1999 static match
2000 match_exit_cycle (gfc_statement st, gfc_exec_op op)
2001 {
2002   gfc_state_data *p, *o;
2003   gfc_symbol *sym;
2004   match m;
2005   int cnt;
2006
2007   if (gfc_match_eos () == MATCH_YES)
2008     sym = NULL;
2009   else
2010     {
2011       char name[GFC_MAX_SYMBOL_LEN + 1];
2012       gfc_symtree* stree;
2013
2014       m = gfc_match ("% %n%t", name);
2015       if (m == MATCH_ERROR)
2016         return MATCH_ERROR;
2017       if (m == MATCH_NO)
2018         {
2019           gfc_syntax_error (st);
2020           return MATCH_ERROR;
2021         }
2022
2023       /* Find the corresponding symbol.  If there's a BLOCK statement
2024          between here and the label, it is not in gfc_current_ns but a parent
2025          namespace!  */
2026       stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
2027       if (!stree)
2028         {
2029           gfc_error ("Name '%s' in %s statement at %C is unknown",
2030                      name, gfc_ascii_statement (st));
2031           return MATCH_ERROR;
2032         }
2033
2034       sym = stree->n.sym;
2035       if (sym->attr.flavor != FL_LABEL)
2036         {
2037           gfc_error ("Name '%s' in %s statement at %C is not a construct name",
2038                      name, gfc_ascii_statement (st));
2039           return MATCH_ERROR;
2040         }
2041     }
2042
2043   /* Find the loop specified by the label (or lack of a label).  */
2044   for (o = NULL, p = gfc_state_stack; p; p = p->previous)
2045     if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
2046       o = p;
2047     else if (p->state == COMP_CRITICAL)
2048       {
2049         gfc_error("%s statement at %C leaves CRITICAL construct",
2050                   gfc_ascii_statement (st));
2051         return MATCH_ERROR;
2052       }
2053     else if ((sym && sym == p->sym) || (!sym && p->state == COMP_DO))
2054       break;
2055
2056   if (p == NULL)
2057     {
2058       if (sym == NULL)
2059         gfc_error ("%s statement at %C is not within a construct",
2060                    gfc_ascii_statement (st));
2061       else
2062         gfc_error ("%s statement at %C is not within construct '%s'",
2063                    gfc_ascii_statement (st), sym->name);
2064
2065       return MATCH_ERROR;
2066     }
2067
2068   /* Special checks for EXIT from non-loop constructs.  */
2069   switch (p->state)
2070     {
2071     case COMP_DO:
2072       break;
2073
2074     case COMP_CRITICAL:
2075       /* This is already handled above.  */
2076       gcc_unreachable ();
2077
2078     case COMP_ASSOCIATE:
2079     case COMP_BLOCK:
2080     case COMP_IF:
2081     case COMP_SELECT:
2082     case COMP_SELECT_TYPE:
2083       gcc_assert (sym);
2084       if (op == EXEC_CYCLE)
2085         {
2086           gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2087                      " construct '%s'", sym->name);
2088           return MATCH_ERROR;
2089         }
2090       gcc_assert (op == EXEC_EXIT);
2091       if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: EXIT statement with no"
2092                           " do-construct-name at %C") == FAILURE)
2093         return MATCH_ERROR;
2094       break;
2095
2096     default:
2097       gfc_error ("%s statement at %C is not applicable to construct '%s'",
2098                  gfc_ascii_statement (st), sym->name);
2099       return MATCH_ERROR;
2100     }
2101
2102   if (o != NULL)
2103     {
2104       gfc_error ("%s statement at %C leaving OpenMP structured block",
2105                  gfc_ascii_statement (st));
2106       return MATCH_ERROR;
2107     }
2108
2109   for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
2110     o = o->previous;
2111   if (cnt > 0
2112       && o != NULL
2113       && o->state == COMP_OMP_STRUCTURED_BLOCK
2114       && (o->head->op == EXEC_OMP_DO
2115           || o->head->op == EXEC_OMP_PARALLEL_DO))
2116     {
2117       int collapse = 1;
2118       gcc_assert (o->head->next != NULL
2119                   && (o->head->next->op == EXEC_DO
2120                       || o->head->next->op == EXEC_DO_WHILE)
2121                   && o->previous != NULL
2122                   && o->previous->tail->op == o->head->op);
2123       if (o->previous->tail->ext.omp_clauses != NULL
2124           && o->previous->tail->ext.omp_clauses->collapse > 1)
2125         collapse = o->previous->tail->ext.omp_clauses->collapse;
2126       if (st == ST_EXIT && cnt <= collapse)
2127         {
2128           gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2129           return MATCH_ERROR;
2130         }
2131       if (st == ST_CYCLE && cnt < collapse)
2132         {
2133           gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2134                      " !$OMP DO loop");
2135           return MATCH_ERROR;
2136         }
2137     }
2138
2139   /* Save the first statement in the construct - needed by the backend.  */
2140   new_st.ext.which_construct = p->construct;
2141
2142   new_st.op = op;
2143
2144   return MATCH_YES;
2145 }
2146
2147
2148 /* Match the EXIT statement.  */
2149
2150 match
2151 gfc_match_exit (void)
2152 {
2153   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
2154 }
2155
2156
2157 /* Match the CYCLE statement.  */
2158
2159 match
2160 gfc_match_cycle (void)
2161 {
2162   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
2163 }
2164
2165
2166 /* Match a number or character constant after an (ALL) STOP or PAUSE statement.  */
2167
2168 static match
2169 gfc_match_stopcode (gfc_statement st)
2170 {
2171   gfc_expr *e;
2172   match m;
2173
2174   e = NULL;
2175
2176   if (gfc_match_eos () != MATCH_YES)
2177     {
2178       m = gfc_match_init_expr (&e);
2179       if (m == MATCH_ERROR)
2180         goto cleanup;
2181       if (m == MATCH_NO)
2182         goto syntax;
2183
2184       if (gfc_match_eos () != MATCH_YES)
2185         goto syntax;
2186     }
2187
2188   if (gfc_pure (NULL))
2189     {
2190       gfc_error ("%s statement not allowed in PURE procedure at %C",
2191                  gfc_ascii_statement (st));
2192       goto cleanup;
2193     }
2194
2195   if (gfc_implicit_pure (NULL))
2196     gfc_current_ns->proc_name->attr.implicit_pure = 0;
2197
2198   if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
2199     {
2200       gfc_error ("Image control statement STOP at %C in CRITICAL block");
2201       goto cleanup;
2202     }
2203
2204   if (e != NULL)
2205     {
2206       if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
2207         {
2208           gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2209                      &e->where);
2210           goto cleanup;
2211         }
2212
2213       if (e->rank != 0)
2214         {
2215           gfc_error ("STOP code at %L must be scalar",
2216                      &e->where);
2217           goto cleanup;
2218         }
2219
2220       if (e->ts.type == BT_CHARACTER
2221           && e->ts.kind != gfc_default_character_kind)
2222         {
2223           gfc_error ("STOP code at %L must be default character KIND=%d",
2224                      &e->where, (int) gfc_default_character_kind);
2225           goto cleanup;
2226         }
2227
2228       if (e->ts.type == BT_INTEGER
2229           && e->ts.kind != gfc_default_integer_kind)
2230         {
2231           gfc_error ("STOP code at %L must be default integer KIND=%d",
2232                      &e->where, (int) gfc_default_integer_kind);
2233           goto cleanup;
2234         }
2235     }
2236
2237   switch (st)
2238     {
2239     case ST_STOP:
2240       new_st.op = EXEC_STOP;
2241       break;
2242     case ST_ERROR_STOP:
2243       new_st.op = EXEC_ERROR_STOP;
2244       break;
2245     case ST_PAUSE:
2246       new_st.op = EXEC_PAUSE;
2247       break;
2248     default:
2249       gcc_unreachable ();
2250     }
2251
2252   new_st.expr1 = e;
2253   new_st.ext.stop_code = -1;
2254
2255   return MATCH_YES;
2256
2257 syntax:
2258   gfc_syntax_error (st);
2259
2260 cleanup:
2261
2262   gfc_free_expr (e);
2263   return MATCH_ERROR;
2264 }
2265
2266
2267 /* Match the (deprecated) PAUSE statement.  */
2268
2269 match
2270 gfc_match_pause (void)
2271 {
2272   match m;
2273
2274   m = gfc_match_stopcode (ST_PAUSE);
2275   if (m == MATCH_YES)
2276     {
2277       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
2278           " at %C")
2279           == FAILURE)
2280         m = MATCH_ERROR;
2281     }
2282   return m;
2283 }
2284
2285
2286 /* Match the STOP statement.  */
2287
2288 match
2289 gfc_match_stop (void)
2290 {
2291   return gfc_match_stopcode (ST_STOP);
2292 }
2293
2294
2295 /* Match the ERROR STOP statement.  */
2296
2297 match
2298 gfc_match_error_stop (void)
2299 {
2300   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C")
2301       == FAILURE)
2302     return MATCH_ERROR;
2303
2304   return gfc_match_stopcode (ST_ERROR_STOP);
2305 }
2306
2307
2308 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2309      SYNC ALL [(sync-stat-list)]
2310      SYNC MEMORY [(sync-stat-list)]
2311      SYNC IMAGES (image-set [, sync-stat-list] )
2312    with sync-stat is int-expr or *.  */
2313
2314 static match
2315 sync_statement (gfc_statement st)
2316 {
2317   match m;
2318   gfc_expr *tmp, *imageset, *stat, *errmsg;
2319   bool saw_stat, saw_errmsg;
2320
2321   tmp = imageset = stat = errmsg = NULL;
2322   saw_stat = saw_errmsg = false;
2323
2324   if (gfc_pure (NULL))
2325     {
2326       gfc_error ("Image control statement SYNC at %C in PURE procedure");
2327       return MATCH_ERROR;
2328     }
2329
2330   if (gfc_implicit_pure (NULL))
2331     gfc_current_ns->proc_name->attr.implicit_pure = 0;
2332
2333   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C")
2334       == FAILURE)
2335     return MATCH_ERROR;
2336
2337   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
2338     {
2339        gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2340        return MATCH_ERROR;
2341     }
2342
2343   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
2344     {
2345       gfc_error ("Image control statement SYNC at %C in CRITICAL block");
2346       return MATCH_ERROR;
2347     }
2348
2349   if (gfc_match_eos () == MATCH_YES)
2350     {
2351       if (st == ST_SYNC_IMAGES)
2352         goto syntax;
2353       goto done;
2354     }
2355
2356   if (gfc_match_char ('(') != MATCH_YES)
2357     goto syntax;
2358
2359   if (st == ST_SYNC_IMAGES)
2360     {
2361       /* Denote '*' as imageset == NULL.  */
2362       m = gfc_match_char ('*');
2363       if (m == MATCH_ERROR)
2364         goto syntax;
2365       if (m == MATCH_NO)
2366         {
2367           if (gfc_match ("%e", &imageset) != MATCH_YES)
2368             goto syntax;
2369         }
2370       m = gfc_match_char (',');
2371       if (m == MATCH_ERROR)
2372         goto syntax;
2373       if (m == MATCH_NO)
2374         {
2375           m = gfc_match_char (')');
2376           if (m == MATCH_YES)
2377             goto done;
2378           goto syntax;
2379         }
2380     }
2381
2382   for (;;)
2383     {
2384       m = gfc_match (" stat = %v", &tmp);
2385       if (m == MATCH_ERROR)
2386         goto syntax;
2387       if (m == MATCH_YES)
2388         {
2389           if (saw_stat)
2390             {
2391               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2392               goto cleanup;
2393             }
2394           stat = tmp;
2395           saw_stat = true;
2396
2397           if (gfc_match_char (',') == MATCH_YES)
2398             continue;
2399         }
2400
2401       m = gfc_match (" errmsg = %v", &tmp);
2402       if (m == MATCH_ERROR)
2403         goto syntax;
2404       if (m == MATCH_YES)
2405         {
2406           if (saw_errmsg)
2407             {
2408               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2409               goto cleanup;
2410             }
2411           errmsg = tmp;
2412           saw_errmsg = true;
2413
2414           if (gfc_match_char (',') == MATCH_YES)
2415             continue;
2416         }
2417
2418       gfc_gobble_whitespace ();
2419
2420       if (gfc_peek_char () == ')')
2421         break;
2422
2423       goto syntax;
2424     }
2425
2426   if (gfc_match (" )%t") != MATCH_YES)
2427     goto syntax;
2428
2429 done:
2430   switch (st)
2431     {
2432     case ST_SYNC_ALL:
2433       new_st.op = EXEC_SYNC_ALL;
2434       break;
2435     case ST_SYNC_IMAGES:
2436       new_st.op = EXEC_SYNC_IMAGES;
2437       break;
2438     case ST_SYNC_MEMORY:
2439       new_st.op = EXEC_SYNC_MEMORY;
2440       break;
2441     default:
2442       gcc_unreachable ();
2443     }
2444
2445   new_st.expr1 = imageset;
2446   new_st.expr2 = stat;
2447   new_st.expr3 = errmsg;
2448
2449   return MATCH_YES;
2450
2451 syntax:
2452   gfc_syntax_error (st);
2453
2454 cleanup:
2455   gfc_free_expr (tmp);
2456   gfc_free_expr (imageset);
2457   gfc_free_expr (stat);
2458   gfc_free_expr (errmsg);
2459
2460   return MATCH_ERROR;
2461 }
2462
2463
2464 /* Match SYNC ALL statement.  */
2465
2466 match
2467 gfc_match_sync_all (void)
2468 {
2469   return sync_statement (ST_SYNC_ALL);
2470 }
2471
2472
2473 /* Match SYNC IMAGES statement.  */
2474
2475 match
2476 gfc_match_sync_images (void)
2477 {
2478   return sync_statement (ST_SYNC_IMAGES);
2479 }
2480
2481
2482 /* Match SYNC MEMORY statement.  */
2483
2484 match
2485 gfc_match_sync_memory (void)
2486 {
2487   return sync_statement (ST_SYNC_MEMORY);
2488 }
2489
2490
2491 /* Match a CONTINUE statement.  */
2492
2493 match
2494 gfc_match_continue (void)
2495 {
2496   if (gfc_match_eos () != MATCH_YES)
2497     {
2498       gfc_syntax_error (ST_CONTINUE);
2499       return MATCH_ERROR;
2500     }
2501
2502   new_st.op = EXEC_CONTINUE;
2503   return MATCH_YES;
2504 }
2505
2506
2507 /* Match the (deprecated) ASSIGN statement.  */
2508
2509 match
2510 gfc_match_assign (void)
2511 {
2512   gfc_expr *expr;
2513   gfc_st_label *label;
2514
2515   if (gfc_match (" %l", &label) == MATCH_YES)
2516     {
2517       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
2518         return MATCH_ERROR;
2519       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
2520         {
2521           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
2522                               "statement at %C")
2523               == FAILURE)
2524             return MATCH_ERROR;
2525
2526           expr->symtree->n.sym->attr.assign = 1;
2527
2528           new_st.op = EXEC_LABEL_ASSIGN;
2529           new_st.label1 = label;
2530           new_st.expr1 = expr;
2531           return MATCH_YES;
2532         }
2533     }
2534   return MATCH_NO;
2535 }
2536
2537
2538 /* Match the GO TO statement.  As a computed GOTO statement is
2539    matched, it is transformed into an equivalent SELECT block.  No
2540    tree is necessary, and the resulting jumps-to-jumps are
2541    specifically optimized away by the back end.  */
2542
2543 match
2544 gfc_match_goto (void)
2545 {
2546   gfc_code *head, *tail;
2547   gfc_expr *expr;
2548   gfc_case *cp;
2549   gfc_st_label *label;
2550   int i;
2551   match m;
2552
2553   if (gfc_match (" %l%t", &label) == MATCH_YES)
2554     {
2555       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2556         return MATCH_ERROR;
2557
2558       new_st.op = EXEC_GOTO;
2559       new_st.label1 = label;
2560       return MATCH_YES;
2561     }
2562
2563   /* The assigned GO TO statement.  */
2564
2565   if (gfc_match_variable (&expr, 0) == MATCH_YES)
2566     {
2567       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
2568                           "statement at %C")
2569           == FAILURE)
2570         return MATCH_ERROR;
2571
2572       new_st.op = EXEC_GOTO;
2573       new_st.expr1 = expr;
2574
2575       if (gfc_match_eos () == MATCH_YES)
2576         return MATCH_YES;
2577
2578       /* Match label list.  */
2579       gfc_match_char (',');
2580       if (gfc_match_char ('(') != MATCH_YES)
2581         {
2582           gfc_syntax_error (ST_GOTO);
2583           return MATCH_ERROR;
2584         }
2585       head = tail = NULL;
2586
2587       do
2588         {
2589           m = gfc_match_st_label (&label);
2590           if (m != MATCH_YES)
2591             goto syntax;
2592
2593           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2594             goto cleanup;
2595
2596           if (head == NULL)
2597             head = tail = gfc_get_code ();
2598           else
2599             {
2600               tail->block = gfc_get_code ();
2601               tail = tail->block;
2602             }
2603
2604           tail->label1 = label;
2605           tail->op = EXEC_GOTO;
2606         }
2607       while (gfc_match_char (',') == MATCH_YES);
2608
2609       if (gfc_match (")%t") != MATCH_YES)
2610         goto syntax;
2611
2612       if (head == NULL)
2613         {
2614            gfc_error ("Statement label list in GOTO at %C cannot be empty");
2615            goto syntax;
2616         }
2617       new_st.block = head;
2618
2619       return MATCH_YES;
2620     }
2621
2622   /* Last chance is a computed GO TO statement.  */
2623   if (gfc_match_char ('(') != MATCH_YES)
2624     {
2625       gfc_syntax_error (ST_GOTO);
2626       return MATCH_ERROR;
2627     }
2628
2629   head = tail = NULL;
2630   i = 1;
2631
2632   do
2633     {
2634       m = gfc_match_st_label (&label);
2635       if (m != MATCH_YES)
2636         goto syntax;
2637
2638       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2639         goto cleanup;
2640
2641       if (head == NULL)
2642         head = tail = gfc_get_code ();
2643       else
2644         {
2645           tail->block = gfc_get_code ();
2646           tail = tail->block;
2647         }
2648
2649       cp = gfc_get_case ();
2650       cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
2651                                              NULL, i++);
2652
2653       tail->op = EXEC_SELECT;
2654       tail->ext.block.case_list = cp;
2655
2656       tail->next = gfc_get_code ();
2657       tail->next->op = EXEC_GOTO;
2658       tail->next->label1 = label;
2659     }
2660   while (gfc_match_char (',') == MATCH_YES);
2661
2662   if (gfc_match_char (')') != MATCH_YES)
2663     goto syntax;
2664
2665   if (head == NULL)
2666     {
2667       gfc_error ("Statement label list in GOTO at %C cannot be empty");
2668       goto syntax;
2669     }
2670
2671   /* Get the rest of the statement.  */
2672   gfc_match_char (',');
2673
2674   if (gfc_match (" %e%t", &expr) != MATCH_YES)
2675     goto syntax;
2676
2677   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO "
2678                       "at %C") == FAILURE)
2679     return MATCH_ERROR;
2680
2681   /* At this point, a computed GOTO has been fully matched and an
2682      equivalent SELECT statement constructed.  */
2683
2684   new_st.op = EXEC_SELECT;
2685   new_st.expr1 = NULL;
2686
2687   /* Hack: For a "real" SELECT, the expression is in expr. We put
2688      it in expr2 so we can distinguish then and produce the correct
2689      diagnostics.  */
2690   new_st.expr2 = expr;
2691   new_st.block = head;
2692   return MATCH_YES;
2693
2694 syntax:
2695   gfc_syntax_error (ST_GOTO);
2696 cleanup:
2697   gfc_free_statements (head);
2698   return MATCH_ERROR;
2699 }
2700
2701
2702 /* Frees a list of gfc_alloc structures.  */
2703
2704 void
2705 gfc_free_alloc_list (gfc_alloc *p)
2706 {
2707   gfc_alloc *q;
2708
2709   for (; p; p = q)
2710     {
2711       q = p->next;
2712       gfc_free_expr (p->expr);
2713       free (p);
2714     }
2715 }
2716
2717
2718 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
2719    an accessible derived type.  */
2720
2721 static match
2722 match_derived_type_spec (gfc_typespec *ts)
2723 {
2724   char name[GFC_MAX_SYMBOL_LEN + 1];
2725   locus old_locus;
2726   gfc_symbol *derived;
2727
2728   old_locus = gfc_current_locus;
2729
2730   if (gfc_match ("%n", name) != MATCH_YES)
2731     {
2732        gfc_current_locus = old_locus;
2733        return MATCH_NO;
2734     }
2735
2736   gfc_find_symbol (name, NULL, 1, &derived);
2737
2738   if (derived && derived->attr.flavor == FL_DERIVED)
2739     {
2740       ts->type = BT_DERIVED;
2741       ts->u.derived = derived;
2742       return MATCH_YES;
2743     }
2744
2745   gfc_current_locus = old_locus;
2746   return MATCH_NO;
2747 }
2748
2749
2750 /* Match a Fortran 2003 type-spec (F03:R401).  This is similar to
2751    gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2752    It only includes the intrinsic types from the Fortran 2003 standard
2753    (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2754    the implicit_flag is not needed, so it was removed. Derived types are
2755    identified by their name alone.  */
2756
2757 static match
2758 match_type_spec (gfc_typespec *ts)
2759 {
2760   match m;
2761   locus old_locus;
2762
2763   gfc_clear_ts (ts);
2764   gfc_gobble_whitespace ();
2765   old_locus = gfc_current_locus;
2766
2767   if (match_derived_type_spec (ts) == MATCH_YES)
2768     {
2769       /* Enforce F03:C401.  */
2770       if (ts->u.derived->attr.abstract)
2771         {
2772           gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
2773                      ts->u.derived->name, &old_locus);
2774           return MATCH_ERROR;
2775         }
2776       return MATCH_YES;
2777     }
2778
2779   if (gfc_match ("integer") == MATCH_YES)
2780     {
2781       ts->type = BT_INTEGER;
2782       ts->kind = gfc_default_integer_kind;
2783       goto kind_selector;
2784     }
2785
2786   if (gfc_match ("real") == MATCH_YES)
2787     {
2788       ts->type = BT_REAL;
2789       ts->kind = gfc_default_real_kind;
2790       goto kind_selector;
2791     }
2792
2793   if (gfc_match ("double precision") == MATCH_YES)
2794     {
2795       ts->type = BT_REAL;
2796       ts->kind = gfc_default_double_kind;
2797       return MATCH_YES;
2798     }
2799
2800   if (gfc_match ("complex") == MATCH_YES)
2801     {
2802       ts->type = BT_COMPLEX;
2803       ts->kind = gfc_default_complex_kind;
2804       goto kind_selector;
2805     }
2806
2807   if (gfc_match ("character") == MATCH_YES)
2808     {
2809       ts->type = BT_CHARACTER;
2810
2811       m = gfc_match_char_spec (ts);
2812
2813       if (m == MATCH_NO)
2814         m = MATCH_YES;
2815
2816       return m;
2817     }
2818
2819   if (gfc_match ("logical") == MATCH_YES)
2820     {
2821       ts->type = BT_LOGICAL;
2822       ts->kind = gfc_default_logical_kind;
2823       goto kind_selector;
2824     }
2825
2826   /* If a type is not matched, simply return MATCH_NO.  */
2827   gfc_current_locus = old_locus;
2828   return MATCH_NO;
2829
2830 kind_selector:
2831
2832   gfc_gobble_whitespace ();
2833   if (gfc_peek_ascii_char () == '*')
2834     {
2835       gfc_error ("Invalid type-spec at %C");
2836       return MATCH_ERROR;
2837     }
2838
2839   m = gfc_match_kind_spec (ts, false);
2840
2841   if (m == MATCH_NO)
2842     m = MATCH_YES;              /* No kind specifier found.  */
2843
2844   return m;
2845 }
2846
2847
2848 /* Match an ALLOCATE statement.  */
2849
2850 match
2851 gfc_match_allocate (void)
2852 {
2853   gfc_alloc *head, *tail;
2854   gfc_expr *stat, *errmsg, *tmp, *source, *mold;
2855   gfc_typespec ts;
2856   gfc_symbol *sym;
2857   match m;
2858   locus old_locus, deferred_locus;
2859   bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
2860
2861   head = tail = NULL;
2862   stat = errmsg = source = mold = tmp = NULL;
2863   saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
2864
2865   if (gfc_match_char ('(') != MATCH_YES)
2866     goto syntax;
2867
2868   /* Match an optional type-spec.  */
2869   old_locus = gfc_current_locus;
2870   m = match_type_spec (&ts);
2871   if (m == MATCH_ERROR)
2872     goto cleanup;
2873   else if (m == MATCH_NO)
2874     {
2875       char name[GFC_MAX_SYMBOL_LEN + 3];
2876
2877       if (gfc_match ("%n :: ", name) == MATCH_YES)
2878         {
2879           gfc_error ("Error in type-spec at %L", &old_locus);
2880           goto cleanup;
2881         }
2882
2883       ts.type = BT_UNKNOWN;
2884     }
2885   else
2886     {
2887       if (gfc_match (" :: ") == MATCH_YES)
2888         {
2889           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
2890                               "ALLOCATE at %L", &old_locus) == FAILURE)
2891             goto cleanup;
2892
2893           if (ts.deferred)
2894             {
2895               gfc_error ("Type-spec at %L cannot contain a deferred "
2896                          "type parameter", &old_locus);
2897               goto cleanup;
2898             }
2899         }
2900       else
2901         {
2902           ts.type = BT_UNKNOWN;
2903           gfc_current_locus = old_locus;
2904         }
2905     }
2906
2907   for (;;)
2908     {
2909       if (head == NULL)
2910         head = tail = gfc_get_alloc ();
2911       else
2912         {
2913           tail->next = gfc_get_alloc ();
2914           tail = tail->next;
2915         }
2916
2917       m = gfc_match_variable (&tail->expr, 0);
2918       if (m == MATCH_NO)
2919         goto syntax;
2920       if (m == MATCH_ERROR)
2921         goto cleanup;
2922
2923       if (gfc_check_do_variable (tail->expr->symtree))
2924         goto cleanup;
2925
2926       if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2927         {
2928           gfc_error ("Bad allocate-object at %C for a PURE procedure");
2929           goto cleanup;
2930         }
2931
2932       if (gfc_implicit_pure (NULL)
2933             && gfc_impure_variable (tail->expr->symtree->n.sym))
2934         gfc_current_ns->proc_name->attr.implicit_pure = 0;
2935
2936       if (tail->expr->ts.deferred)
2937         {
2938           saw_deferred = true;
2939           deferred_locus = tail->expr->where;
2940         }
2941
2942       /* The ALLOCATE statement had an optional typespec.  Check the
2943          constraints.  */
2944       if (ts.type != BT_UNKNOWN)
2945         {
2946           /* Enforce F03:C624.  */
2947           if (!gfc_type_compatible (&tail->expr->ts, &ts))
2948             {
2949               gfc_error ("Type of entity at %L is type incompatible with "
2950                          "typespec", &tail->expr->where);
2951               goto cleanup;
2952             }
2953
2954           /* Enforce F03:C627.  */
2955           if (ts.kind != tail->expr->ts.kind)
2956             {
2957               gfc_error ("Kind type parameter for entity at %L differs from "
2958                          "the kind type parameter of the typespec",
2959                          &tail->expr->where);
2960               goto cleanup;
2961             }
2962         }
2963
2964       if (tail->expr->ts.type == BT_DERIVED)
2965         tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
2966
2967       /* FIXME: disable the checking on derived types and arrays.  */
2968       sym = tail->expr->symtree->n.sym;
2969       b1 = !(tail->expr->ref
2970            && (tail->expr->ref->type == REF_COMPONENT
2971                 || tail->expr->ref->type == REF_ARRAY));
2972       if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
2973         b2 = !(CLASS_DATA (sym)->attr.allocatable
2974                || CLASS_DATA (sym)->attr.class_pointer);
2975       else
2976         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
2977                       || sym->attr.proc_pointer);
2978       b3 = sym && sym->ns && sym->ns->proc_name
2979            && (sym->ns->proc_name->attr.allocatable
2980                 || sym->ns->proc_name->attr.pointer
2981                 || sym->ns->proc_name->attr.proc_pointer);
2982       if (b1 && b2 && !b3)
2983         {
2984           gfc_error ("Allocate-object at %L is not a nonprocedure pointer "
2985                      "or an allocatable variable", &tail->expr->where);
2986           goto cleanup;
2987         }
2988
2989       if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
2990         {
2991           gfc_error ("Shape specification for allocatable scalar at %C");
2992           goto cleanup;
2993         }
2994
2995       if (gfc_match_char (',') != MATCH_YES)
2996         break;
2997
2998 alloc_opt_list:
2999
3000       m = gfc_match (" stat = %v", &tmp);
3001       if (m == MATCH_ERROR)
3002         goto cleanup;
3003       if (m == MATCH_YES)
3004         {
3005           /* Enforce C630.  */
3006           if (saw_stat)
3007             {
3008               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3009               goto cleanup;
3010             }
3011
3012           stat = tmp;
3013           tmp = NULL;
3014           saw_stat = true;
3015
3016           if (gfc_check_do_variable (stat->symtree))
3017             goto cleanup;
3018
3019           if (gfc_match_char (',') == MATCH_YES)
3020             goto alloc_opt_list;
3021         }
3022
3023       m = gfc_match (" errmsg = %v", &tmp);
3024       if (m == MATCH_ERROR)
3025         goto cleanup;
3026       if (m == MATCH_YES)
3027         {
3028           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
3029                               &tmp->where) == FAILURE)
3030             goto cleanup;
3031
3032           /* Enforce C630.  */
3033           if (saw_errmsg)
3034             {
3035               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3036               goto cleanup;
3037             }
3038
3039           errmsg = tmp;
3040           tmp = NULL;
3041           saw_errmsg = true;
3042
3043           if (gfc_match_char (',') == MATCH_YES)
3044             goto alloc_opt_list;
3045         }
3046
3047       m = gfc_match (" source = %e", &tmp);
3048       if (m == MATCH_ERROR)
3049         goto cleanup;
3050       if (m == MATCH_YES)
3051         {
3052           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
3053                               &tmp->where) == FAILURE)
3054             goto cleanup;
3055
3056           /* Enforce C630.  */
3057           if (saw_source)
3058             {
3059               gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
3060               goto cleanup;
3061             }
3062
3063           /* The next 2 conditionals check C631.  */
3064           if (ts.type != BT_UNKNOWN)
3065             {
3066               gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3067                          &tmp->where, &old_locus);
3068               goto cleanup;
3069             }
3070
3071           if (head->next)
3072             {
3073               gfc_error ("SOURCE tag at %L requires only a single entity in "
3074                          "the allocation-list", &tmp->where);
3075               goto cleanup;
3076             }
3077
3078           source = tmp;
3079           tmp = NULL;
3080           saw_source = true;
3081
3082           if (gfc_match_char (',') == MATCH_YES)
3083             goto alloc_opt_list;
3084         }
3085
3086       m = gfc_match (" mold = %e", &tmp);
3087       if (m == MATCH_ERROR)
3088         goto cleanup;
3089       if (m == MATCH_YES)
3090         {
3091           if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L",
3092                               &tmp->where) == FAILURE)
3093             goto cleanup;
3094
3095           /* Check F08:C636.  */
3096           if (saw_mold)
3097             {
3098               gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
3099               goto cleanup;
3100             }
3101
3102           /* Check F08:C637.  */
3103           if (ts.type != BT_UNKNOWN)
3104             {
3105               gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3106                          &tmp->where, &old_locus);
3107               goto cleanup;
3108             }
3109
3110           mold = tmp;
3111           tmp = NULL;
3112           saw_mold = true;
3113           mold->mold = 1;
3114
3115           if (gfc_match_char (',') == MATCH_YES)
3116             goto alloc_opt_list;
3117         }
3118
3119         gfc_gobble_whitespace ();
3120
3121         if (gfc_peek_char () == ')')
3122           break;
3123     }
3124
3125   if (gfc_match (" )%t") != MATCH_YES)
3126     goto syntax;
3127
3128   /* Check F08:C637.  */
3129   if (source && mold)
3130     {
3131       gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3132                   &mold->where, &source->where);
3133       goto cleanup;
3134     }
3135
3136   /* Check F03:C623,  */
3137   if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
3138     {
3139       gfc_error ("Allocate-object at %L with a deferred type parameter "
3140                  "requires either a type-spec or SOURCE tag or a MOLD tag",
3141                  &deferred_locus);
3142       goto cleanup;
3143     }
3144
3145   new_st.op = EXEC_ALLOCATE;
3146   new_st.expr1 = stat;
3147   new_st.expr2 = errmsg;
3148   if (source)
3149     new_st.expr3 = source;
3150   else
3151     new_st.expr3 = mold;
3152   new_st.ext.alloc.list = head;
3153   new_st.ext.alloc.ts = ts;
3154
3155   return MATCH_YES;
3156
3157 syntax:
3158   gfc_syntax_error (ST_ALLOCATE);
3159
3160 cleanup:
3161   gfc_free_expr (errmsg);
3162   gfc_free_expr (source);
3163   gfc_free_expr (stat);
3164   gfc_free_expr (mold);
3165   if (tmp && tmp->expr_type) gfc_free_expr (tmp);
3166   gfc_free_alloc_list (head);
3167   return MATCH_ERROR;
3168 }
3169
3170
3171 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3172    a set of pointer assignments to intrinsic NULL().  */
3173
3174 match
3175 gfc_match_nullify (void)
3176 {
3177   gfc_code *tail;
3178   gfc_expr *e, *p;
3179   match m;
3180
3181   tail = NULL;
3182
3183   if (gfc_match_char ('(') != MATCH_YES)
3184     goto syntax;
3185
3186   for (;;)
3187     {
3188       m = gfc_match_variable (&p, 0);
3189       if (m == MATCH_ERROR)
3190         goto cleanup;
3191       if (m == MATCH_NO)
3192         goto syntax;
3193
3194       if (gfc_check_do_variable (p->symtree))
3195         goto cleanup;
3196
3197       /* F2008, C1242.  */
3198       if (gfc_is_coindexed (p))
3199         {
3200           gfc_error ("Pointer object at %C shall not be conindexed");
3201           goto cleanup;
3202         }
3203
3204       /* build ' => NULL() '.  */
3205       e = gfc_get_null_expr (&gfc_current_locus);
3206
3207       /* Chain to list.  */
3208       if (tail == NULL)
3209         tail = &new_st;
3210       else
3211         {
3212           tail->next = gfc_get_code ();
3213           tail = tail->next;
3214         }
3215
3216       tail->op = EXEC_POINTER_ASSIGN;
3217       tail->expr1 = p;
3218       tail->expr2 = e;
3219
3220       if (gfc_match (" )%t") == MATCH_YES)
3221         break;
3222       if (gfc_match_char (',') != MATCH_YES)
3223         goto syntax;
3224     }
3225
3226   return MATCH_YES;
3227
3228 syntax:
3229   gfc_syntax_error (ST_NULLIFY);
3230
3231 cleanup:
3232   gfc_free_statements (new_st.next);
3233   new_st.next = NULL;
3234   gfc_free_expr (new_st.expr1);
3235   new_st.expr1 = NULL;
3236   gfc_free_expr (new_st.expr2);
3237   new_st.expr2 = NULL;
3238   return MATCH_ERROR;
3239 }
3240
3241
3242 /* Match a DEALLOCATE statement.  */
3243
3244 match
3245 gfc_match_deallocate (void)
3246 {
3247   gfc_alloc *head, *tail;
3248   gfc_expr *stat, *errmsg, *tmp;
3249   gfc_symbol *sym;
3250   match m;
3251   bool saw_stat, saw_errmsg, b1, b2;
3252
3253   head = tail = NULL;
3254   stat = errmsg = tmp = NULL;
3255   saw_stat = saw_errmsg = false;
3256
3257   if (gfc_match_char ('(') != MATCH_YES)
3258     goto syntax;
3259
3260   for (;;)
3261     {
3262       if (head == NULL)
3263         head = tail = gfc_get_alloc ();
3264       else
3265         {
3266           tail->next = gfc_get_alloc ();
3267           tail = tail->next;
3268         }
3269
3270       m = gfc_match_variable (&tail->expr, 0);
3271       if (m == MATCH_ERROR)
3272         goto cleanup;
3273       if (m == MATCH_NO)
3274         goto syntax;
3275
3276       if (gfc_check_do_variable (tail->expr->symtree))
3277         goto cleanup;
3278
3279       sym = tail->expr->symtree->n.sym;
3280
3281       if (gfc_pure (NULL) && gfc_impure_variable (sym))
3282         {
3283           gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3284           goto cleanup;
3285         }
3286
3287       if (gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
3288         gfc_current_ns->proc_name->attr.implicit_pure = 0;
3289
3290       /* FIXME: disable the checking on derived types.  */
3291       b1 = !(tail->expr->ref
3292            && (tail->expr->ref->type == REF_COMPONENT
3293                || tail->expr->ref->type == REF_ARRAY));
3294       if (sym && sym->ts.type == BT_CLASS)
3295         b2 = !(CLASS_DATA (sym)->attr.allocatable
3296                || CLASS_DATA (sym)->attr.class_pointer);
3297       else
3298         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3299                       || sym->attr.proc_pointer);
3300       if (b1 && b2)
3301         {
3302           gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3303                      "or an allocatable variable");
3304           goto cleanup;
3305         }
3306
3307       if (gfc_match_char (',') != MATCH_YES)
3308         break;
3309
3310 dealloc_opt_list:
3311
3312       m = gfc_match (" stat = %v", &tmp);
3313       if (m == MATCH_ERROR)
3314         goto cleanup;
3315       if (m == MATCH_YES)
3316         {
3317           if (saw_stat)
3318             {
3319               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3320               gfc_free_expr (tmp);
3321               goto cleanup;
3322             }
3323
3324           stat = tmp;
3325           saw_stat = true;
3326
3327           if (gfc_check_do_variable (stat->symtree))
3328             goto cleanup;
3329
3330           if (gfc_match_char (',') == MATCH_YES)
3331             goto dealloc_opt_list;
3332         }
3333
3334       m = gfc_match (" errmsg = %v", &tmp);
3335       if (m == MATCH_ERROR)
3336         goto cleanup;
3337       if (m == MATCH_YES)
3338         {
3339           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
3340                               &tmp->where) == FAILURE)
3341             goto cleanup;
3342
3343           if (saw_errmsg)
3344             {
3345               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3346               gfc_free_expr (tmp);
3347               goto cleanup;
3348             }
3349
3350           errmsg = tmp;
3351           saw_errmsg = true;
3352
3353           if (gfc_match_char (',') == MATCH_YES)
3354             goto dealloc_opt_list;
3355         }
3356
3357         gfc_gobble_whitespace ();
3358
3359         if (gfc_peek_char () == ')')
3360           break;
3361     }
3362
3363   if (gfc_match (" )%t") != MATCH_YES)
3364     goto syntax;
3365
3366   new_st.op = EXEC_DEALLOCATE;
3367   new_st.expr1 = stat;
3368   new_st.expr2 = errmsg;
3369   new_st.ext.alloc.list = head;
3370
3371   return MATCH_YES;
3372
3373 syntax:
3374   gfc_syntax_error (ST_DEALLOCATE);
3375
3376 cleanup:
3377   gfc_free_expr (errmsg);
3378   gfc_free_expr (stat);
3379   gfc_free_alloc_list (head);
3380   return MATCH_ERROR;
3381 }
3382
3383
3384 /* Match a RETURN statement.  */
3385
3386 match
3387 gfc_match_return (void)
3388 {
3389   gfc_expr *e;
3390   match m;
3391   gfc_compile_state s;
3392
3393   e = NULL;
3394
3395   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
3396     {
3397       gfc_error ("Image control statement RETURN at %C in CRITICAL block");
3398       return MATCH_ERROR;
3399     }
3400
3401   if (gfc_match_eos () == MATCH_YES)
3402     goto done;
3403
3404   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
3405     {
3406       gfc_error ("Alternate RETURN statement at %C is only allowed within "
3407                  "a SUBROUTINE");
3408       goto cleanup;
3409     }
3410
3411   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN "
3412                       "at %C") == FAILURE)
3413     return MATCH_ERROR;
3414
3415   if (gfc_current_form == FORM_FREE)
3416     {
3417       /* The following are valid, so we can't require a blank after the
3418         RETURN keyword:
3419           return+1
3420           return(1)  */
3421       char c = gfc_peek_ascii_char ();
3422       if (ISALPHA (c) || ISDIGIT (c))
3423         return MATCH_NO;
3424     }
3425
3426   m = gfc_match (" %e%t", &e);
3427   if (m == MATCH_YES)
3428     goto done;
3429   if (m == MATCH_ERROR)
3430     goto cleanup;
3431
3432   gfc_syntax_error (ST_RETURN);
3433
3434 cleanup:
3435   gfc_free_expr (e);
3436   return MATCH_ERROR;
3437
3438 done:
3439   gfc_enclosing_unit (&s);
3440   if (s == COMP_PROGRAM
3441       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
3442                         "main program at %C") == FAILURE)
3443       return MATCH_ERROR;
3444
3445   new_st.op = EXEC_RETURN;
3446   new_st.expr1 = e;
3447
3448   return MATCH_YES;
3449 }
3450
3451
3452 /* Match the call of a type-bound procedure, if CALL%var has already been
3453    matched and var found to be a derived-type variable.  */
3454
3455 static match
3456 match_typebound_call (gfc_symtree* varst)
3457 {
3458   gfc_expr* base;
3459   match m;
3460
3461   base = gfc_get_expr ();
3462   base->expr_type = EXPR_VARIABLE;
3463   base->symtree = varst;
3464   base->where = gfc_current_locus;
3465   gfc_set_sym_referenced (varst->n.sym);
3466
3467   m = gfc_match_varspec (base, 0, true, true);
3468   if (m == MATCH_NO)
3469     gfc_error ("Expected component reference at %C");
3470   if (m != MATCH_YES)
3471     return MATCH_ERROR;
3472
3473   if (gfc_match_eos () != MATCH_YES)
3474     {
3475       gfc_error ("Junk after CALL at %C");
3476       return MATCH_ERROR;
3477     }
3478
3479   if (base->expr_type == EXPR_COMPCALL)
3480     new_st.op = EXEC_COMPCALL;
3481   else if (base->expr_type == EXPR_PPC)
3482     new_st.op = EXEC_CALL_PPC;
3483   else
3484     {
3485       gfc_error ("Expected type-bound procedure or procedure pointer component "
3486                  "at %C");
3487       return MATCH_ERROR;
3488     }
3489   new_st.expr1 = base;
3490
3491   return MATCH_YES;
3492 }
3493
3494
3495 /* Match a CALL statement.  The tricky part here are possible
3496    alternate return specifiers.  We handle these by having all
3497    "subroutines" actually return an integer via a register that gives
3498    the return number.  If the call specifies alternate returns, we
3499    generate code for a SELECT statement whose case clauses contain
3500    GOTOs to the various labels.  */
3501
3502 match
3503 gfc_match_call (void)
3504 {
3505   char name[GFC_MAX_SYMBOL_LEN + 1];
3506   gfc_actual_arglist *a, *arglist;
3507   gfc_case *new_case;
3508   gfc_symbol *sym;
3509   gfc_symtree *st;
3510   gfc_code *c;
3511   match m;
3512   int i;
3513
3514   arglist = NULL;
3515
3516   m = gfc_match ("% %n", name);
3517   if (m == MATCH_NO)
3518     goto syntax;
3519   if (m != MATCH_YES)
3520     return m;
3521
3522   if (gfc_get_ha_sym_tree (name, &st))
3523     return MATCH_ERROR;
3524
3525   sym = st->n.sym;
3526
3527   /* If this is a variable of derived-type, it probably starts a type-bound
3528      procedure call.  */
3529   if ((sym->attr.flavor != FL_PROCEDURE
3530        || gfc_is_function_return_value (sym, gfc_current_ns))
3531       && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
3532     return match_typebound_call (st);
3533
3534   /* If it does not seem to be callable (include functions so that the
3535      right association is made.  They are thrown out in resolution.)
3536      ...  */
3537   if (!sym->attr.generic
3538         && !sym->attr.subroutine
3539         && !sym->attr.function)
3540     {
3541       if (!(sym->attr.external && !sym->attr.referenced))
3542         {
3543           /* ...create a symbol in this scope...  */
3544           if (sym->ns != gfc_current_ns
3545                 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
3546             return MATCH_ERROR;
3547
3548           if (sym != st->n.sym)
3549             sym = st->n.sym;
3550         }
3551
3552       /* ...and then to try to make the symbol into a subroutine.  */
3553       if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
3554         return MATCH_ERROR;
3555     }
3556
3557   gfc_set_sym_referenced (sym);
3558
3559   if (gfc_match_eos () != MATCH_YES)
3560     {
3561       m = gfc_match_actual_arglist (1, &arglist);
3562       if (m == MATCH_NO)
3563         goto syntax;
3564       if (m == MATCH_ERROR)
3565         goto cleanup;
3566
3567       if (gfc_match_eos () != MATCH_YES)
3568         goto syntax;
3569     }
3570
3571   /* If any alternate return labels were found, construct a SELECT
3572      statement that will jump to the right place.  */
3573
3574   i = 0;
3575   for (a = arglist; a; a = a->next)
3576     if (a->expr == NULL)
3577       i = 1;
3578
3579   if (i)
3580     {
3581       gfc_symtree *select_st;
3582       gfc_symbol *select_sym;
3583       char name[GFC_MAX_SYMBOL_LEN + 1];
3584
3585       new_st.next = c = gfc_get_code ();
3586       c->op = EXEC_SELECT;
3587       sprintf (name, "_result_%s", sym->name);
3588       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
3589
3590       select_sym = select_st->n.sym;
3591       select_sym->ts.type = BT_INTEGER;
3592       select_sym->ts.kind = gfc_default_integer_kind;
3593       gfc_set_sym_referenced (select_sym);
3594       c->expr1 = gfc_get_expr ();
3595       c->expr1->expr_type = EXPR_VARIABLE;
3596       c->expr1->symtree = select_st;
3597       c->expr1->ts = select_sym->ts;
3598       c->expr1->where = gfc_current_locus;
3599
3600       i = 0;
3601       for (a = arglist; a; a = a->next)
3602         {
3603           if (a->expr != NULL)
3604             continue;
3605
3606           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
3607             continue;
3608
3609           i++;
3610
3611           c->block = gfc_get_code ();
3612           c = c->block;
3613           c->op = EXEC_SELECT;
3614
3615           new_case = gfc_get_case ();
3616           new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
3617           new_case->low = new_case->high;
3618           c->ext.block.case_list = new_case;
3619
3620           c->next = gfc_get_code ();
3621           c->next->op = EXEC_GOTO;
3622           c->next->label1 = a->label;
3623         }
3624     }
3625
3626   new_st.op = EXEC_CALL;
3627   new_st.symtree = st;
3628   new_st.ext.actual = arglist;
3629
3630   return MATCH_YES;
3631
3632 syntax:
3633   gfc_syntax_error (ST_CALL);
3634
3635 cleanup:
3636   gfc_free_actual_arglist (arglist);
3637   return MATCH_ERROR;
3638 }
3639
3640
3641 /* Given a name, return a pointer to the common head structure,
3642    creating it if it does not exist. If FROM_MODULE is nonzero, we
3643    mangle the name so that it doesn't interfere with commons defined
3644    in the using namespace.
3645    TODO: Add to global symbol tree.  */
3646
3647 gfc_common_head *
3648 gfc_get_common (const char *name, int from_module)
3649 {
3650   gfc_symtree *st;
3651   static int serial = 0;
3652   char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
3653
3654   if (from_module)
3655     {
3656       /* A use associated common block is only needed to correctly layout
3657          the variables it contains.  */
3658       snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
3659       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
3660     }
3661   else
3662     {
3663       st = gfc_find_symtree (gfc_current_ns->common_root, name);
3664
3665       if (st == NULL)
3666         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
3667     }
3668
3669   if (st->n.common == NULL)
3670     {
3671       st->n.common = gfc_get_common_head ();
3672       st->n.common->where = gfc_current_locus;
3673       strcpy (st->n.common->name, name);
3674     }
3675
3676   return st->n.common;
3677 }
3678
3679
3680 /* Match a common block name.  */
3681
3682 match match_common_name (char *name)
3683 {
3684   match m;
3685
3686   if (gfc_match_char ('/') == MATCH_NO)
3687     {
3688       name[0] = '\0';
3689       return MATCH_YES;
3690     }
3691
3692   if (gfc_match_char ('/') == MATCH_YES)
3693     {
3694       name[0] = '\0';
3695       return MATCH_YES;
3696     }
3697
3698   m = gfc_match_name (name);
3699
3700   if (m == MATCH_ERROR)
3701     return MATCH_ERROR;
3702   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
3703     return MATCH_YES;
3704
3705   gfc_error ("Syntax error in common block name at %C");
3706   return MATCH_ERROR;
3707 }
3708
3709
3710 /* Match a COMMON statement.  */
3711
3712 match
3713 gfc_match_common (void)
3714 {
3715   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
3716   char name[GFC_MAX_SYMBOL_LEN + 1];
3717   gfc_common_head *t;
3718   gfc_array_spec *as;
3719   gfc_equiv *e1, *e2;
3720   match m;
3721   gfc_gsymbol *gsym;
3722
3723   old_blank_common = gfc_current_ns->blank_common.head;
3724   if (old_blank_common)
3725     {
3726       while (old_blank_common->common_next)
3727         old_blank_common = old_blank_common->common_next;
3728     }
3729
3730   as = NULL;
3731
3732   for (;;)
3733     {
3734       m = match_common_name (name);
3735       if (m == MATCH_ERROR)
3736         goto cleanup;
3737
3738       gsym = gfc_get_gsymbol (name);
3739       if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
3740         {
3741           gfc_error ("Symbol '%s' at %C is already an external symbol that "
3742                      "is not COMMON", name);
3743           goto cleanup;
3744         }
3745
3746       if (gsym->type == GSYM_UNKNOWN)
3747         {
3748           gsym->type = GSYM_COMMON;
3749           gsym->where = gfc_current_locus;
3750           gsym->defined = 1;
3751         }
3752
3753       gsym->used = 1;
3754
3755       if (name[0] == '\0')
3756         {
3757           t = &gfc_current_ns->blank_common;
3758           if (t->head == NULL)
3759             t->where = gfc_current_locus;
3760         }
3761       else
3762         {
3763           t = gfc_get_common (name, 0);
3764         }
3765       head = &t->head;
3766
3767       if (*head == NULL)
3768         tail = NULL;
3769       else
3770         {
3771           tail = *head;
3772           while (tail->common_next)
3773             tail = tail->common_next;
3774         }
3775
3776       /* Grab the list of symbols.  */
3777       for (;;)
3778         {
3779           m = gfc_match_symbol (&sym, 0);
3780           if (m == MATCH_ERROR)
3781             goto cleanup;
3782           if (m == MATCH_NO)
3783             goto syntax;
3784
3785           /* Store a ref to the common block for error checking.  */
3786           sym->common_block = t;
3787
3788           /* See if we know the current common block is bind(c), and if
3789              so, then see if we can check if the symbol is (which it'll
3790              need to be).  This can happen if the bind(c) attr stmt was
3791              applied to the common block, and the variable(s) already
3792              defined, before declaring the common block.  */
3793           if (t->is_bind_c == 1)
3794             {
3795               if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
3796                 {
3797                   /* If we find an error, just print it and continue,
3798                      cause it's just semantic, and we can see if there
3799                      are more errors.  */
3800                   gfc_error_now ("Variable '%s' at %L in common block '%s' "
3801                                  "at %C must be declared with a C "
3802                                  "interoperable kind since common block "
3803                                  "'%s' is bind(c)",
3804                                  sym->name, &(sym->declared_at), t->name,
3805                                  t->name);
3806                 }
3807
3808               if (sym->attr.is_bind_c == 1)
3809                 gfc_error_now ("Variable '%s' in common block "
3810                                "'%s' at %C can not be bind(c) since "
3811                                "it is not global", sym->name, t->name);
3812             }
3813
3814           if (sym->attr.in_common)
3815             {
3816               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
3817                          sym->name);
3818               goto cleanup;
3819             }
3820
3821           if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
3822                || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
3823             {
3824               if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
3825                                                "can only be COMMON in "
3826                                                "BLOCK DATA", sym->name)
3827                   == FAILURE)
3828                 goto cleanup;
3829             }
3830
3831           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
3832             goto cleanup;
3833
3834           if (tail != NULL)
3835             tail->common_next = sym;
3836           else
3837             *head = sym;
3838
3839           tail = sym;
3840
3841           /* Deal with an optional array specification after the
3842              symbol name.  */
3843           m = gfc_match_array_spec (&as, true, true);
3844           if (m == MATCH_ERROR)
3845             goto cleanup;
3846
3847           if (m == MATCH_YES)
3848             {
3849               if (as->type != AS_EXPLICIT)
3850                 {
3851                   gfc_error ("Array specification for symbol '%s' in COMMON "
3852                              "at %C must be explicit", sym->name);
3853                   goto cleanup;
3854                 }
3855
3856               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
3857                 goto cleanup;
3858
3859               if (sym->attr.pointer)
3860                 {
3861                   gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3862                              "POINTER array", sym->name);
3863                   goto cleanup;
3864                 }
3865
3866               sym->as = as;
3867               as = NULL;
3868
3869             }
3870
3871           sym->common_head = t;
3872
3873           /* Check to see if the symbol is already in an equivalence group.
3874              If it is, set the other members as being in common.  */
3875           if (sym->attr.in_equivalence)
3876             {
3877               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
3878                 {
3879                   for (e2 = e1; e2; e2 = e2->eq)
3880                     if (e2->expr->symtree->n.sym == sym)
3881                       goto equiv_found;
3882
3883                   continue;
3884
3885           equiv_found:
3886
3887                   for (e2 = e1; e2; e2 = e2->eq)
3888                     {
3889                       other = e2->expr->symtree->n.sym;
3890                       if (other->common_head
3891                           && other->common_head != sym->common_head)
3892                         {
3893                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
3894                                      "%C is being indirectly equivalenced to "
3895                                      "another COMMON block '%s'",
3896                                      sym->name, sym->common_head->name,
3897                                      other->common_head->name);
3898                             goto cleanup;
3899                         }
3900                       other->attr.in_common = 1;
3901                       other->common_head = t;
3902                     }
3903                 }
3904             }
3905
3906
3907           gfc_gobble_whitespace ();
3908           if (gfc_match_eos () == MATCH_YES)
3909             goto done;
3910           if (gfc_peek_ascii_char () == '/')
3911             break;
3912           if (gfc_match_char (',') != MATCH_YES)
3913             goto syntax;
3914           gfc_gobble_whitespace ();
3915           if (gfc_peek_ascii_char () == '/')
3916             break;
3917         }
3918     }
3919
3920 done:
3921   return MATCH_YES;
3922
3923 syntax:
3924   gfc_syntax_error (ST_COMMON);
3925
3926 cleanup:
3927   if (old_blank_common)
3928     old_blank_common->common_next = NULL;
3929   else
3930     gfc_current_ns->blank_common.head = NULL;
3931   gfc_free_array_spec (as);
3932   return MATCH_ERROR;
3933 }
3934
3935
3936 /* Match a BLOCK DATA program unit.  */
3937
3938 match
3939 gfc_match_block_data (void)
3940 {
3941   char name[GFC_MAX_SYMBOL_LEN + 1];
3942   gfc_symbol *sym;
3943   match m;
3944
3945   if (gfc_match_eos () == MATCH_YES)
3946     {
3947       gfc_new_block = NULL;
3948       return MATCH_YES;
3949     }
3950
3951   m = gfc_match ("% %n%t", name);
3952   if (m != MATCH_YES)
3953     return MATCH_ERROR;
3954
3955   if (gfc_get_symbol (name, NULL, &sym))
3956     return MATCH_ERROR;
3957
3958   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
3959     return MATCH_ERROR;
3960
3961   gfc_new_block = sym;
3962
3963   return MATCH_YES;
3964 }
3965
3966
3967 /* Free a namelist structure.  */
3968
3969 void
3970 gfc_free_namelist (gfc_namelist *name)
3971 {
3972   gfc_namelist *n;
3973
3974   for (; name; name = n)
3975     {
3976       n = name->next;
3977       free (name);
3978     }
3979 }
3980
3981
3982 /* Match a NAMELIST statement.  */
3983
3984 match
3985 gfc_match_namelist (void)
3986 {
3987   gfc_symbol *group_name, *sym;
3988   gfc_namelist *nl;
3989   match m, m2;
3990
3991   m = gfc_match (" / %s /", &group_name);
3992   if (m == MATCH_NO)
3993     goto syntax;
3994   if (m == MATCH_ERROR)
3995     goto error;
3996
3997   for (;;)
3998     {
3999       if (group_name->ts.type != BT_UNKNOWN)
4000         {
4001           gfc_error ("Namelist group name '%s' at %C already has a basic "
4002                      "type of %s", group_name->name,
4003                      gfc_typename (&group_name->ts));
4004           return MATCH_ERROR;
4005         }
4006
4007       if (group_name->attr.flavor == FL_NAMELIST
4008           && group_name->attr.use_assoc
4009           && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
4010                              "at %C already is USE associated and can"
4011                              "not be respecified.", group_name->name)
4012              == FAILURE)
4013         return MATCH_ERROR;
4014
4015       if (group_name->attr.flavor != FL_NAMELIST
4016           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
4017                              group_name->name, NULL) == FAILURE)
4018         return MATCH_ERROR;
4019
4020       for (;;)
4021         {
4022           m = gfc_match_symbol (&sym, 1);
4023           if (m == MATCH_NO)
4024             goto syntax;
4025           if (m == MATCH_ERROR)
4026             goto error;
4027
4028           if (sym->attr.in_namelist == 0
4029               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
4030             goto error;
4031
4032           /* Use gfc_error_check here, rather than goto error, so that
4033              these are the only errors for the next two lines.  */
4034           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
4035             {
4036               gfc_error ("Assumed size array '%s' in namelist '%s' at "
4037                          "%C is not allowed", sym->name, group_name->name);
4038               gfc_error_check ();
4039             }
4040
4041           nl = gfc_get_namelist ();
4042           nl->sym = sym;
4043           sym->refs++;
4044
4045           if (group_name->namelist == NULL)
4046             group_name->namelist = group_name->namelist_tail = nl;
4047           else
4048             {
4049               group_name->namelist_tail->next = nl;
4050               group_name->namelist_tail = nl;
4051             }
4052
4053           if (gfc_match_eos () == MATCH_YES)
4054             goto done;
4055
4056           m = gfc_match_char (',');
4057
4058           if (gfc_match_char ('/') == MATCH_YES)
4059             {
4060               m2 = gfc_match (" %s /", &group_name);
4061               if (m2 == MATCH_YES)
4062                 break;
4063               if (m2 == MATCH_ERROR)
4064                 goto error;
4065               goto syntax;
4066             }
4067
4068           if (m != MATCH_YES)
4069             goto syntax;
4070         }
4071     }
4072
4073 done:
4074   return MATCH_YES;
4075
4076 syntax:
4077   gfc_syntax_error (ST_NAMELIST);
4078
4079 error:
4080   return MATCH_ERROR;
4081 }
4082
4083
4084 /* Match a MODULE statement.  */
4085
4086 match
4087 gfc_match_module (void)
4088 {
4089   match m;
4090
4091   m = gfc_match (" %s%t", &gfc_new_block);
4092   if (m != MATCH_YES)
4093     return m;
4094
4095   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
4096                       gfc_new_block->name, NULL) == FAILURE)
4097     return MATCH_ERROR;
4098
4099   return MATCH_YES;
4100 }
4101
4102
4103 /* Free equivalence sets and lists.  Recursively is the easiest way to
4104    do this.  */
4105
4106 void
4107 gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
4108 {
4109   if (eq == stop)
4110     return;
4111
4112   gfc_free_equiv (eq->eq);
4113   gfc_free_equiv_until (eq->next, stop);
4114   gfc_free_expr (eq->expr);
4115   free (eq);
4116 }
4117
4118
4119 void
4120 gfc_free_equiv (gfc_equiv *eq)
4121 {
4122   gfc_free_equiv_until (eq, NULL);
4123 }
4124
4125
4126 /* Match an EQUIVALENCE statement.  */
4127
4128 match
4129 gfc_match_equivalence (void)
4130 {
4131   gfc_equiv *eq, *set, *tail;
4132   gfc_ref *ref;
4133   gfc_symbol *sym;
4134   match m;
4135   gfc_common_head *common_head = NULL;
4136   bool common_flag;
4137   int cnt;
4138
4139   tail = NULL;
4140
4141   for (;;)
4142     {
4143       eq = gfc_get_equiv ();
4144       if (tail == NULL)
4145         tail = eq;
4146
4147       eq->next = gfc_current_ns->equiv;
4148       gfc_current_ns->equiv = eq;
4149
4150       if (gfc_match_char ('(') != MATCH_YES)
4151         goto syntax;
4152
4153       set = eq;
4154       common_flag = FALSE;
4155       cnt = 0;
4156
4157       for (;;)
4158         {
4159           m = gfc_match_equiv_variable (&set->expr);
4160           if (m == MATCH_ERROR)
4161             goto cleanup;
4162           if (m == MATCH_NO)
4163             goto syntax;
4164
4165           /*  count the number of objects.  */
4166           cnt++;
4167
4168           if (gfc_match_char ('%') == MATCH_YES)
4169             {
4170               gfc_error ("Derived type component %C is not a "
4171                          "permitted EQUIVALENCE member");
4172               goto cleanup;
4173             }
4174
4175           for (ref = set->expr->ref; ref; ref = ref->next)
4176             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
4177               {
4178                 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4179                            "be an array section");
4180                 goto cleanup;
4181               }
4182
4183           sym = set->expr->symtree->n.sym;
4184
4185           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
4186             goto cleanup;
4187
4188           if (sym->attr.in_common)
4189             {
4190               common_flag = TRUE;
4191               common_head = sym->common_head;
4192             }
4193
4194           if (gfc_match_char (')') == MATCH_YES)
4195             break;
4196
4197           if (gfc_match_char (',') != MATCH_YES)
4198             goto syntax;
4199
4200           set->eq = gfc_get_equiv ();
4201           set = set->eq;
4202         }
4203
4204       if (cnt < 2)
4205         {
4206           gfc_error ("EQUIVALENCE at %C requires two or more objects");
4207           goto cleanup;
4208         }
4209
4210       /* If one of the members of an equivalence is in common, then
4211          mark them all as being in common.  Before doing this, check
4212          that members of the equivalence group are not in different
4213          common blocks.  */
4214       if (common_flag)
4215         for (set = eq; set; set = set->eq)
4216           {
4217             sym = set->expr->symtree->n.sym;
4218             if (sym->common_head && sym->common_head != common_head)
4219               {
4220                 gfc_error ("Attempt to indirectly overlap COMMON "
4221                            "blocks %s and %s by EQUIVALENCE at %C",
4222                            sym->common_head->name, common_head->name);
4223                 goto cleanup;
4224               }
4225             sym->attr.in_common = 1;
4226             sym->common_head = common_head;
4227           }
4228
4229       if (gfc_match_eos () == MATCH_YES)
4230         break;
4231       if (gfc_match_char (',') != MATCH_YES)
4232         {
4233           gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4234           goto cleanup;
4235         }
4236     }
4237
4238   return MATCH_YES;
4239
4240 syntax:
4241   gfc_syntax_error (ST_EQUIVALENCE);
4242
4243 cleanup:
4244   eq = tail->next;
4245   tail->next = NULL;
4246
4247   gfc_free_equiv (gfc_current_ns->equiv);
4248   gfc_current_ns->equiv = eq;
4249
4250   return MATCH_ERROR;
4251 }
4252
4253
4254 /* Check that a statement function is not recursive. This is done by looking
4255    for the statement function symbol(sym) by looking recursively through its
4256    expression(e).  If a reference to sym is found, true is returned.
4257    12.5.4 requires that any variable of function that is implicitly typed
4258    shall have that type confirmed by any subsequent type declaration.  The
4259    implicit typing is conveniently done here.  */
4260 static bool
4261 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
4262
4263 static bool
4264 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
4265 {
4266
4267   if (e == NULL)
4268     return false;
4269
4270   switch (e->expr_type)
4271     {
4272     case EXPR_FUNCTION:
4273       if (e->symtree == NULL)
4274         return false;
4275
4276       /* Check the name before testing for nested recursion!  */
4277       if (sym->name == e->symtree->n.sym->name)
4278         return true;
4279
4280       /* Catch recursion via other statement functions.  */
4281       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
4282           && e->symtree->n.sym->value
4283           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
4284         return true;
4285
4286       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4287         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4288
4289       break;
4290
4291     case EXPR_VARIABLE:
4292       if (e->symtree && sym->name == e->symtree->n.sym->name)
4293         return true;
4294
4295       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4296         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4297       break;
4298
4299     default:
4300       break;
4301     }
4302
4303   return false;
4304 }
4305
4306
4307 static bool
4308 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
4309 {
4310   return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
4311 }
4312
4313
4314 /* Match a statement function declaration.  It is so easy to match
4315    non-statement function statements with a MATCH_ERROR as opposed to
4316    MATCH_NO that we suppress error message in most cases.  */
4317
4318 match
4319 gfc_match_st_function (void)
4320 {
4321   gfc_error_buf old_error;
4322   gfc_symbol *sym;
4323   gfc_expr *expr;
4324   match m;
4325
4326   m = gfc_match_symbol (&sym, 0);
4327   if (m != MATCH_YES)
4328     return m;
4329
4330   gfc_push_error (&old_error);
4331
4332   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
4333                          sym->name, NULL) == FAILURE)
4334     goto undo_error;
4335
4336   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
4337     goto undo_error;
4338
4339   m = gfc_match (" = %e%t", &expr);
4340   if (m == MATCH_NO)
4341     goto undo_error;
4342
4343   gfc_free_error (&old_error);
4344   if (m == MATCH_ERROR)
4345     return m;
4346
4347   if (recursive_stmt_fcn (expr, sym))
4348     {
4349       gfc_error ("Statement function at %L is recursive", &expr->where);
4350       return MATCH_ERROR;
4351     }
4352
4353   sym->value = expr;
4354
4355   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
4356                       "Statement function at %C") == FAILURE)
4357     return MATCH_ERROR;
4358
4359   return MATCH_YES;
4360
4361 undo_error:
4362   gfc_pop_error (&old_error);
4363   return MATCH_NO;
4364 }
4365
4366
4367 /***************** SELECT CASE subroutines ******************/
4368
4369 /* Free a single case structure.  */
4370
4371 static void
4372 free_case (gfc_case *p)
4373 {
4374   if (p->low == p->high)
4375     p->high = NULL;
4376   gfc_free_expr (p->low);
4377   gfc_free_expr (p->high);
4378   free (p);
4379 }
4380
4381
4382 /* Free a list of case structures.  */
4383
4384 void
4385 gfc_free_case_list (gfc_case *p)
4386 {
4387   gfc_case *q;
4388
4389   for (; p; p = q)
4390     {
4391       q = p->next;
4392       free_case (p);
4393     }
4394 }
4395
4396
4397 /* Match a single case selector.  */
4398
4399 static match
4400 match_case_selector (gfc_case **cp)
4401 {
4402   gfc_case *c;
4403   match m;
4404
4405   c = gfc_get_case ();
4406   c->where = gfc_current_locus;
4407
4408   if (gfc_match_char (':') == MATCH_YES)
4409     {
4410       m = gfc_match_init_expr (&c->high);
4411       if (m == MATCH_NO)
4412         goto need_expr;
4413       if (m == MATCH_ERROR)
4414         goto cleanup;
4415     }
4416   else
4417     {
4418       m = gfc_match_init_expr (&c->low);
4419       if (m == MATCH_ERROR)
4420         goto cleanup;
4421       if (m == MATCH_NO)
4422         goto need_expr;
4423
4424       /* If we're not looking at a ':' now, make a range out of a single
4425          target.  Else get the upper bound for the case range.  */
4426       if (gfc_match_char (':') != MATCH_YES)
4427         c->high = c->low;
4428       else
4429         {
4430           m = gfc_match_init_expr (&c->high);
4431           if (m == MATCH_ERROR)
4432             goto cleanup;
4433           /* MATCH_NO is fine.  It's OK if nothing is there!  */
4434         }
4435     }
4436
4437   *cp = c;
4438   return MATCH_YES;
4439
4440 need_expr:
4441   gfc_error ("Expected initialization expression in CASE at %C");
4442
4443 cleanup:
4444   free_case (c);
4445   return MATCH_ERROR;
4446 }
4447
4448
4449 /* Match the end of a case statement.  */
4450
4451 static match
4452 match_case_eos (void)
4453 {
4454   char name[GFC_MAX_SYMBOL_LEN + 1];
4455   match m;
4456
4457   if (gfc_match_eos () == MATCH_YES)
4458     return MATCH_YES;
4459
4460   /* If the case construct doesn't have a case-construct-name, we
4461      should have matched the EOS.  */
4462   if (!gfc_current_block ())
4463     return MATCH_NO;
4464
4465   gfc_gobble_whitespace ();
4466
4467   m = gfc_match_name (name);
4468   if (m != MATCH_YES)
4469     return m;
4470
4471   if (strcmp (name, gfc_current_block ()->name) != 0)
4472     {
4473       gfc_error ("Expected block name '%s' of SELECT construct at %C",
4474                  gfc_current_block ()->name);
4475       return MATCH_ERROR;
4476     }
4477
4478   return gfc_match_eos ();
4479 }
4480
4481
4482 /* Match a SELECT statement.  */
4483
4484 match
4485 gfc_match_select (void)
4486 {
4487   gfc_expr *expr;
4488   match m;
4489
4490   m = gfc_match_label ();
4491   if (m == MATCH_ERROR)
4492     return m;
4493
4494   m = gfc_match (" select case ( %e )%t", &expr);
4495   if (m != MATCH_YES)
4496     return m;
4497
4498   new_st.op = EXEC_SELECT;
4499   new_st.expr1 = expr;
4500
4501   return MATCH_YES;
4502 }
4503
4504
4505 /* Push the current selector onto the SELECT TYPE stack.  */
4506
4507 static void
4508 select_type_push (gfc_symbol *sel)
4509 {
4510   gfc_select_type_stack *top = gfc_get_select_type_stack ();
4511   top->selector = sel;
4512   top->tmp = NULL;
4513   top->prev = select_type_stack;
4514
4515   select_type_stack = top;
4516 }
4517
4518
4519 /* Set the temporary for the current SELECT TYPE selector.  */
4520
4521 static void
4522 select_type_set_tmp (gfc_typespec *ts)
4523 {
4524   char name[GFC_MAX_SYMBOL_LEN];
4525   gfc_symtree *tmp;
4526
4527   if (!ts)
4528     {
4529       select_type_stack->tmp = NULL;
4530       return;
4531     }
4532
4533   if (!gfc_type_is_extensible (ts->u.derived))
4534     return;
4535
4536   if (ts->type == BT_CLASS)
4537     sprintf (name, "__tmp_class_%s", ts->u.derived->name);
4538   else
4539     sprintf (name, "__tmp_type_%s", ts->u.derived->name);
4540   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
4541   gfc_add_type (tmp->n.sym, ts, NULL);
4542   gfc_set_sym_referenced (tmp->n.sym);
4543   if (select_type_stack->selector->ts.type == BT_CLASS &&
4544       CLASS_DATA (select_type_stack->selector)->attr.allocatable)
4545     gfc_add_allocatable (&tmp->n.sym->attr, NULL);
4546   else
4547     gfc_add_pointer (&tmp->n.sym->attr, NULL);
4548   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
4549   if (ts->type == BT_CLASS)
4550     gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
4551                             &tmp->n.sym->as, false);
4552   tmp->n.sym->attr.select_type_temporary = 1;
4553
4554   /* Add an association for it, so the rest of the parser knows it is
4555      an associate-name.  The target will be set during resolution.  */
4556   tmp->n.sym->assoc = gfc_get_association_list ();
4557   tmp->n.sym->assoc->dangling = 1;
4558   tmp->n.sym->assoc->st = tmp;
4559
4560   select_type_stack->tmp = tmp;
4561 }
4562
4563
4564 /* Match a SELECT TYPE statement.  */
4565
4566 match
4567 gfc_match_select_type (void)
4568 {
4569   gfc_expr *expr1, *expr2 = NULL;
4570   match m;
4571   char name[GFC_MAX_SYMBOL_LEN];
4572
4573   m = gfc_match_label ();
4574   if (m == MATCH_ERROR)
4575     return m;
4576
4577   m = gfc_match (" select type ( ");
4578   if (m != MATCH_YES)
4579     return m;
4580
4581   gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
4582
4583   m = gfc_match (" %n => %e", name, &expr2);
4584   if (m == MATCH_YES)
4585     {
4586       expr1 = gfc_get_expr();
4587       expr1->expr_type = EXPR_VARIABLE;
4588       if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
4589         {
4590           m = MATCH_ERROR;
4591           goto cleanup;
4592         }
4593       if (expr2->ts.type == BT_UNKNOWN)
4594         expr1->symtree->n.sym->attr.untyped = 1;
4595       else
4596         expr1->symtree->n.sym->ts = expr2->ts;
4597       expr1->symtree->n.sym->attr.flavor = FL_VARIABLE;
4598       expr1->symtree->n.sym->attr.referenced = 1;
4599       expr1->symtree->n.sym->attr.class_ok = 1;
4600     }
4601   else
4602     {
4603       m = gfc_match (" %e ", &expr1);
4604       if (m != MATCH_YES)
4605         goto cleanup;
4606     }
4607
4608   m = gfc_match (" )%t");
4609   if (m != MATCH_YES)
4610     goto cleanup;
4611
4612   /* Check for F03:C811.  */
4613   if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
4614     {
4615       gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
4616                  "use associate-name=>");
4617       m = MATCH_ERROR;
4618       goto cleanup;
4619     }
4620
4621   new_st.op = EXEC_SELECT_TYPE;
4622   new_st.expr1 = expr1;
4623   new_st.expr2 = expr2;
4624   new_st.ext.block.ns = gfc_current_ns;
4625
4626   select_type_push (expr1->symtree->n.sym);
4627
4628   return MATCH_YES;
4629
4630 cleanup:
4631   gfc_current_ns = gfc_current_ns->parent;
4632   return m;
4633 }
4634
4635
4636 /* Match a CASE statement.  */
4637
4638 match
4639 gfc_match_case (void)
4640 {
4641   gfc_case *c, *head, *tail;
4642   match m;
4643
4644   head = tail = NULL;
4645
4646   if (gfc_current_state () != COMP_SELECT)
4647     {
4648       gfc_error ("Unexpected CASE statement at %C");
4649       return MATCH_ERROR;
4650     }
4651
4652   if (gfc_match ("% default") == MATCH_YES)
4653     {
4654       m = match_case_eos ();
4655       if (m == MATCH_NO)
4656         goto syntax;
4657       if (m == MATCH_ERROR)
4658         goto cleanup;
4659
4660       new_st.op = EXEC_SELECT;
4661       c = gfc_get_case ();
4662       c->where = gfc_current_locus;
4663       new_st.ext.block.case_list = c;
4664       return MATCH_YES;
4665     }
4666
4667   if (gfc_match_char ('(') != MATCH_YES)
4668     goto syntax;
4669
4670   for (;;)
4671     {
4672       if (match_case_selector (&c) == MATCH_ERROR)
4673         goto cleanup;
4674
4675       if (head == NULL)
4676         head = c;
4677       else
4678         tail->next = c;
4679
4680       tail = c;
4681
4682       if (gfc_match_char (')') == MATCH_YES)
4683         break;
4684       if (gfc_match_char (',') != MATCH_YES)
4685         goto syntax;
4686     }
4687
4688   m = match_case_eos ();
4689   if (m == MATCH_NO)
4690     goto syntax;
4691   if (m == MATCH_ERROR)
4692     goto cleanup;
4693
4694   new_st.op = EXEC_SELECT;
4695   new_st.ext.block.case_list = head;
4696
4697   return MATCH_YES;
4698
4699 syntax:
4700   gfc_error ("Syntax error in CASE specification at %C");
4701
4702 cleanup:
4703   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
4704   return MATCH_ERROR;
4705 }
4706
4707
4708 /* Match a TYPE IS statement.  */
4709
4710 match
4711 gfc_match_type_is (void)
4712 {
4713   gfc_case *c = NULL;
4714   match m;
4715
4716   if (gfc_current_state () != COMP_SELECT_TYPE)
4717     {
4718       gfc_error ("Unexpected TYPE IS statement at %C");
4719       return MATCH_ERROR;
4720     }
4721
4722   if (gfc_match_char ('(') != MATCH_YES)
4723     goto syntax;
4724
4725   c = gfc_get_case ();
4726   c->where = gfc_current_locus;
4727
4728   /* TODO: Once unlimited polymorphism is implemented, we will need to call
4729      match_type_spec here.  */
4730   if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
4731     goto cleanup;
4732
4733   if (gfc_match_char (')') != MATCH_YES)
4734     goto syntax;
4735
4736   m = match_case_eos ();
4737   if (m == MATCH_NO)
4738     goto syntax;
4739   if (m == MATCH_ERROR)
4740     goto cleanup;
4741
4742   new_st.op = EXEC_SELECT_TYPE;
4743   new_st.ext.block.case_list = c;
4744
4745   /* Create temporary variable.  */
4746   select_type_set_tmp (&c->ts);
4747
4748   return MATCH_YES;
4749
4750 syntax:
4751   gfc_error ("Syntax error in TYPE IS specification at %C");
4752
4753 cleanup:
4754   if (c != NULL)
4755     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
4756   return MATCH_ERROR;
4757 }
4758
4759
4760 /* Match a CLASS IS or CLASS DEFAULT statement.  */
4761
4762 match
4763 gfc_match_class_is (void)
4764 {
4765   gfc_case *c = NULL;
4766   match m;
4767
4768   if (gfc_current_state () != COMP_SELECT_TYPE)
4769     return MATCH_NO;
4770
4771   if (gfc_match ("% default") == MATCH_YES)
4772     {
4773       m = match_case_eos ();
4774       if (m == MATCH_NO)
4775         goto syntax;
4776       if (m == MATCH_ERROR)
4777         goto cleanup;
4778
4779       new_st.op = EXEC_SELECT_TYPE;
4780       c = gfc_get_case ();
4781       c->where = gfc_current_locus;
4782       c->ts.type = BT_UNKNOWN;
4783       new_st.ext.block.case_list = c;
4784       select_type_set_tmp (NULL);
4785       return MATCH_YES;
4786     }
4787
4788   m = gfc_match ("% is");
4789   if (m == MATCH_NO)
4790     goto syntax;
4791   if (m == MATCH_ERROR)
4792     goto cleanup;
4793
4794   if (gfc_match_char ('(') != MATCH_YES)
4795     goto syntax;
4796
4797   c = gfc_get_case ();
4798   c->where = gfc_current_locus;
4799
4800   if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
4801     goto cleanup;
4802
4803   if (c->ts.type == BT_DERIVED)
4804     c->ts.type = BT_CLASS;
4805
4806   if (gfc_match_char (')') != MATCH_YES)
4807     goto syntax;
4808
4809   m = match_case_eos ();
4810   if (m == MATCH_NO)
4811     goto syntax;
4812   if (m == MATCH_ERROR)
4813     goto cleanup;
4814
4815   new_st.op = EXEC_SELECT_TYPE;
4816   new_st.ext.block.case_list = c;
4817
4818   /* Create temporary variable.  */
4819   select_type_set_tmp (&c->ts);
4820
4821   return MATCH_YES;
4822
4823 syntax:
4824   gfc_error ("Syntax error in CLASS IS specification at %C");
4825
4826 cleanup:
4827   if (c != NULL)
4828     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
4829   return MATCH_ERROR;
4830 }
4831
4832
4833 /********************* WHERE subroutines ********************/
4834
4835 /* Match the rest of a simple WHERE statement that follows an IF statement.
4836  */
4837
4838 static match
4839 match_simple_where (void)
4840 {
4841   gfc_expr *expr;
4842   gfc_code *c;
4843   match m;
4844
4845   m = gfc_match (" ( %e )", &expr);
4846   if (m != MATCH_YES)
4847     return m;
4848
4849   m = gfc_match_assignment ();
4850   if (m == MATCH_NO)
4851     goto syntax;
4852   if (m == MATCH_ERROR)
4853     goto cleanup;
4854
4855   if (gfc_match_eos () != MATCH_YES)
4856     goto syntax;
4857
4858   c = gfc_get_code ();
4859
4860   c->op = EXEC_WHERE;
4861   c->expr1 = expr;
4862   c->next = gfc_get_code ();
4863
4864   *c->next = new_st;
4865   gfc_clear_new_st ();
4866
4867   new_st.op = EXEC_WHERE;
4868   new_st.block = c;
4869
4870   return MATCH_YES;
4871
4872 syntax:
4873   gfc_syntax_error (ST_WHERE);
4874
4875 cleanup:
4876   gfc_free_expr (expr);
4877   return MATCH_ERROR;
4878 }
4879
4880
4881 /* Match a WHERE statement.  */
4882
4883 match
4884 gfc_match_where (gfc_statement *st)
4885 {
4886   gfc_expr *expr;
4887   match m0, m;
4888   gfc_code *c;
4889
4890   m0 = gfc_match_label ();
4891   if (m0 == MATCH_ERROR)
4892     return m0;
4893
4894   m = gfc_match (" where ( %e )", &expr);
4895   if (m != MATCH_YES)
4896     return m;
4897
4898   if (gfc_match_eos () == MATCH_YES)
4899     {
4900       *st = ST_WHERE_BLOCK;
4901       new_st.op = EXEC_WHERE;
4902       new_st.expr1 = expr;
4903       return MATCH_YES;
4904     }
4905
4906   m = gfc_match_assignment ();
4907   if (m == MATCH_NO)
4908     gfc_syntax_error (ST_WHERE);
4909
4910   if (m != MATCH_YES)
4911     {
4912       gfc_free_expr (expr);
4913       return MATCH_ERROR;
4914     }
4915
4916   /* We've got a simple WHERE statement.  */
4917   *st = ST_WHERE;
4918   c = gfc_get_code ();
4919
4920   c->op = EXEC_WHERE;
4921   c->expr1 = expr;
4922   c->next = gfc_get_code ();
4923
4924   *c->next = new_st;
4925   gfc_clear_new_st ();
4926
4927   new_st.op = EXEC_WHERE;
4928   new_st.block = c;
4929
4930   return MATCH_YES;
4931 }
4932
4933
4934 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
4935    new_st if successful.  */
4936
4937 match
4938 gfc_match_elsewhere (void)
4939 {
4940   char name[GFC_MAX_SYMBOL_LEN + 1];
4941   gfc_expr *expr;
4942   match m;
4943
4944   if (gfc_current_state () != COMP_WHERE)
4945     {
4946       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
4947       return MATCH_ERROR;
4948     }
4949
4950   expr = NULL;
4951
4952   if (gfc_match_char ('(') == MATCH_YES)
4953     {
4954       m = gfc_match_expr (&expr);
4955       if (m == MATCH_NO)
4956         goto syntax;
4957       if (m == MATCH_ERROR)
4958         return MATCH_ERROR;
4959
4960       if (gfc_match_char (')') != MATCH_YES)
4961         goto syntax;
4962     }
4963
4964   if (gfc_match_eos () != MATCH_YES)
4965     {
4966       /* Only makes sense if we have a where-construct-name.  */
4967       if (!gfc_current_block ())
4968         {
4969           m = MATCH_ERROR;
4970           goto cleanup;
4971         }
4972       /* Better be a name at this point.  */
4973       m = gfc_match_name (name);
4974       if (m == MATCH_NO)
4975         goto syntax;
4976       if (m == MATCH_ERROR)
4977         goto cleanup;
4978
4979       if (gfc_match_eos () != MATCH_YES)
4980         goto syntax;
4981
4982       if (strcmp (name, gfc_current_block ()->name) != 0)
4983         {
4984           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
4985                      name, gfc_current_block ()->name);
4986           goto cleanup;
4987         }
4988     }
4989
4990   new_st.op = EXEC_WHERE;
4991   new_st.expr1 = expr;
4992   return MATCH_YES;
4993
4994 syntax:
4995   gfc_syntax_error (ST_ELSEWHERE);
4996
4997 cleanup:
4998   gfc_free_expr (expr);
4999   return MATCH_ERROR;
5000 }
5001
5002
5003 /******************** FORALL subroutines ********************/
5004
5005 /* Free a list of FORALL iterators.  */
5006
5007 void
5008 gfc_free_forall_iterator (gfc_forall_iterator *iter)
5009 {
5010   gfc_forall_iterator *next;
5011
5012   while (iter)
5013     {
5014       next = iter->next;
5015       gfc_free_expr (iter->var);
5016       gfc_free_expr (iter->start);
5017       gfc_free_expr (iter->end);
5018       gfc_free_expr (iter->stride);
5019       free (iter);
5020       iter = next;
5021     }
5022 }
5023
5024
5025 /* Match an iterator as part of a FORALL statement.  The format is:
5026
5027      <var> = <start>:<end>[:<stride>]
5028
5029    On MATCH_NO, the caller tests for the possibility that there is a
5030    scalar mask expression.  */
5031
5032 static match
5033 match_forall_iterator (gfc_forall_iterator **result)
5034 {
5035   gfc_forall_iterator *iter;
5036   locus where;
5037   match m;
5038
5039   where = gfc_current_locus;
5040   iter = XCNEW (gfc_forall_iterator);
5041
5042   m = gfc_match_expr (&iter->var);
5043   if (m != MATCH_YES)
5044     goto cleanup;
5045
5046   if (gfc_match_char ('=') != MATCH_YES
5047       || iter->var->expr_type != EXPR_VARIABLE)
5048     {
5049       m = MATCH_NO;
5050       goto cleanup;
5051     }
5052
5053   m = gfc_match_expr (&iter->start);
5054   if (m != MATCH_YES)
5055     goto cleanup;
5056
5057   if (gfc_match_char (':') != MATCH_YES)
5058     goto syntax;
5059
5060   m = gfc_match_expr (&iter->end);
5061   if (m == MATCH_NO)
5062     goto syntax;
5063   if (m == MATCH_ERROR)
5064     goto cleanup;
5065
5066   if (gfc_match_char (':') == MATCH_NO)
5067     iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
5068   else
5069     {
5070       m = gfc_match_expr (&iter->stride);
5071       if (m == MATCH_NO)
5072         goto syntax;
5073       if (m == MATCH_ERROR)
5074         goto cleanup;
5075     }
5076
5077   /* Mark the iteration variable's symbol as used as a FORALL index.  */
5078   iter->var->symtree->n.sym->forall_index = true;
5079
5080   *result = iter;
5081   return MATCH_YES;
5082
5083 syntax:
5084   gfc_error ("Syntax error in FORALL iterator at %C");
5085   m = MATCH_ERROR;
5086
5087 cleanup:
5088
5089   gfc_current_locus = where;
5090   gfc_free_forall_iterator (iter);
5091   return m;
5092 }
5093
5094
5095 /* Match the header of a FORALL statement.  */
5096
5097 static match
5098 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
5099 {
5100   gfc_forall_iterator *head, *tail, *new_iter;
5101   gfc_expr *msk;
5102   match m;
5103
5104   gfc_gobble_whitespace ();
5105
5106   head = tail = NULL;
5107   msk = NULL;
5108
5109   if (gfc_match_char ('(') != MATCH_YES)
5110     return MATCH_NO;
5111
5112   m = match_forall_iterator (&new_iter);
5113   if (m == MATCH_ERROR)
5114     goto cleanup;
5115   if (m == MATCH_NO)
5116     goto syntax;
5117
5118   head = tail = new_iter;
5119
5120   for (;;)
5121     {
5122       if (gfc_match_char (',') != MATCH_YES)
5123         break;
5124
5125       m = match_forall_iterator (&new_iter);
5126       if (m == MATCH_ERROR)
5127         goto cleanup;
5128
5129       if (m == MATCH_YES)
5130         {
5131           tail->next = new_iter;
5132           tail = new_iter;
5133           continue;
5134         }
5135
5136       /* Have to have a mask expression.  */
5137
5138       m = gfc_match_expr (&msk);
5139       if (m == MATCH_NO)
5140         goto syntax;
5141       if (m == MATCH_ERROR)
5142         goto cleanup;
5143
5144       break;
5145     }
5146
5147   if (gfc_match_char (')') == MATCH_NO)
5148     goto syntax;
5149
5150   *phead = head;
5151   *mask = msk;
5152   return MATCH_YES;
5153
5154 syntax:
5155   gfc_syntax_error (ST_FORALL);
5156
5157 cleanup:
5158   gfc_free_expr (msk);
5159   gfc_free_forall_iterator (head);
5160
5161   return MATCH_ERROR;
5162 }
5163
5164 /* Match the rest of a simple FORALL statement that follows an
5165    IF statement.  */
5166
5167 static match
5168 match_simple_forall (void)
5169 {
5170   gfc_forall_iterator *head;
5171   gfc_expr *mask;
5172   gfc_code *c;
5173   match m;
5174
5175   mask = NULL;
5176   head = NULL;
5177   c = NULL;
5178
5179   m = match_forall_header (&head, &mask);
5180
5181   if (m == MATCH_NO)
5182     goto syntax;
5183   if (m != MATCH_YES)
5184     goto cleanup;
5185
5186   m = gfc_match_assignment ();
5187
5188   if (m == MATCH_ERROR)
5189     goto cleanup;
5190   if (m == MATCH_NO)
5191     {
5192       m = gfc_match_pointer_assignment ();
5193       if (m == MATCH_ERROR)
5194         goto cleanup;
5195       if (m == MATCH_NO)
5196         goto syntax;
5197     }
5198
5199   c = gfc_get_code ();
5200   *c = new_st;
5201   c->loc = gfc_current_locus;
5202
5203   if (gfc_match_eos () != MATCH_YES)
5204     goto syntax;
5205
5206   gfc_clear_new_st ();
5207   new_st.op = EXEC_FORALL;
5208   new_st.expr1 = mask;
5209   new_st.ext.forall_iterator = head;
5210   new_st.block = gfc_get_code ();
5211
5212   new_st.block->op = EXEC_FORALL;
5213   new_st.block->next = c;
5214
5215   return MATCH_YES;
5216
5217 syntax:
5218   gfc_syntax_error (ST_FORALL);
5219
5220 cleanup:
5221   gfc_free_forall_iterator (head);
5222   gfc_free_expr (mask);
5223
5224   return MATCH_ERROR;
5225 }
5226
5227
5228 /* Match a FORALL statement.  */
5229
5230 match
5231 gfc_match_forall (gfc_statement *st)
5232 {
5233   gfc_forall_iterator *head;
5234   gfc_expr *mask;
5235   gfc_code *c;
5236   match m0, m;
5237
5238   head = NULL;
5239   mask = NULL;
5240   c = NULL;
5241
5242   m0 = gfc_match_label ();
5243   if (m0 == MATCH_ERROR)
5244     return MATCH_ERROR;
5245
5246   m = gfc_match (" forall");
5247   if (m != MATCH_YES)
5248     return m;
5249
5250   m = match_forall_header (&head, &mask);
5251   if (m == MATCH_ERROR)
5252     goto cleanup;
5253   if (m == MATCH_NO)
5254     goto syntax;
5255
5256   if (gfc_match_eos () == MATCH_YES)
5257     {
5258       *st = ST_FORALL_BLOCK;
5259       new_st.op = EXEC_FORALL;
5260       new_st.expr1 = mask;
5261       new_st.ext.forall_iterator = head;
5262       return MATCH_YES;
5263     }
5264
5265   m = gfc_match_assignment ();
5266   if (m == MATCH_ERROR)
5267     goto cleanup;
5268   if (m == MATCH_NO)
5269     {
5270       m = gfc_match_pointer_assignment ();
5271       if (m == MATCH_ERROR)
5272         goto cleanup;
5273       if (m == MATCH_NO)
5274         goto syntax;
5275     }
5276
5277   c = gfc_get_code ();
5278   *c = new_st;
5279   c->loc = gfc_current_locus;
5280
5281   gfc_clear_new_st ();
5282   new_st.op = EXEC_FORALL;
5283   new_st.expr1 = mask;
5284   new_st.ext.forall_iterator = head;
5285   new_st.block = gfc_get_code ();
5286   new_st.block->op = EXEC_FORALL;
5287   new_st.block->next = c;
5288
5289   *st = ST_FORALL;
5290   return MATCH_YES;
5291
5292 syntax:
5293   gfc_syntax_error (ST_FORALL);
5294
5295 cleanup:
5296   gfc_free_forall_iterator (head);
5297   gfc_free_expr (mask);
5298   gfc_free_statements (c);
5299   return MATCH_NO;
5300 }