gcc/fortran/match.c

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