gcc/fortran/match.c

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