gcc/fortran/match.c

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