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