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