gcc/fortran/match.c

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