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