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