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   old_locus = gfc_current_locus;
2723
2724   if (gfc_match ("integer") == MATCH_YES)
2725     {
2726       ts->type = BT_INTEGER;
2727       ts->kind = gfc_default_integer_kind;
2728       goto kind_selector;
2729     }
2730
2731   if (gfc_match ("real") == MATCH_YES)
2732     {
2733       ts->type = BT_REAL;
2734       ts->kind = gfc_default_real_kind;
2735       goto kind_selector;
2736     }
2737
2738   if (gfc_match ("double precision") == MATCH_YES)
2739     {
2740       ts->type = BT_REAL;
2741       ts->kind = gfc_default_double_kind;
2742       return MATCH_YES;
2743     }
2744
2745   if (gfc_match ("complex") == MATCH_YES)
2746     {
2747       ts->type = BT_COMPLEX;
2748       ts->kind = gfc_default_complex_kind;
2749       goto kind_selector;
2750     }
2751
2752   if (gfc_match ("character") == MATCH_YES)
2753     {
2754       ts->type = BT_CHARACTER;
2755       goto char_selector;
2756     }
2757
2758   if (gfc_match ("logical") == MATCH_YES)
2759     {
2760       ts->type = BT_LOGICAL;
2761       ts->kind = gfc_default_logical_kind;
2762       goto kind_selector;
2763     }
2764
2765   m = match_derived_type_spec (ts);
2766   if (m == MATCH_YES)
2767     {
2768       old_locus = gfc_current_locus;
2769       if (gfc_match (" :: ") != MATCH_YES)
2770         return MATCH_ERROR;
2771       gfc_current_locus = old_locus;
2772       /* Enfore F03:C401.  */
2773       if (ts->u.derived->attr.abstract)
2774         {
2775           gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
2776                      ts->u.derived->name, &old_locus);
2777           return MATCH_ERROR;
2778         }
2779       return MATCH_YES;
2780     }
2781   else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES)
2782     return MATCH_ERROR;
2783
2784   /* If a type is not matched, simply return MATCH_NO.  */
2785   gfc_current_locus = old_locus;
2786   return MATCH_NO;
2787
2788 kind_selector:
2789
2790   gfc_gobble_whitespace ();
2791   if (gfc_peek_ascii_char () == '*')
2792     {
2793       gfc_error ("Invalid type-spec at %C");
2794       return MATCH_ERROR;
2795     }
2796
2797   m = gfc_match_kind_spec (ts, false);
2798
2799   if (m == MATCH_NO)
2800     m = MATCH_YES;              /* No kind specifier found.  */
2801
2802   return m;
2803
2804 char_selector:
2805
2806   m = gfc_match_char_spec (ts);
2807
2808   if (m == MATCH_NO)
2809     m = MATCH_YES;              /* No kind specifier found.  */
2810
2811   return m;
2812 }
2813
2814
2815 /* Match an ALLOCATE statement.  */
2816
2817 match
2818 gfc_match_allocate (void)
2819 {
2820   gfc_alloc *head, *tail;
2821   gfc_expr *stat, *errmsg, *tmp, *source, *mold;
2822   gfc_typespec ts;
2823   gfc_symbol *sym;
2824   match m;
2825   locus old_locus;
2826   bool saw_stat, saw_errmsg, saw_source, saw_mold, b1, b2, b3;
2827
2828   head = tail = NULL;
2829   stat = errmsg = source = mold = tmp = NULL;
2830   saw_stat = saw_errmsg = saw_source = saw_mold = false;
2831
2832   if (gfc_match_char ('(') != MATCH_YES)
2833     goto syntax;
2834
2835   /* Match an optional type-spec.  */
2836   old_locus = gfc_current_locus;
2837   m = match_type_spec (&ts);
2838   if (m == MATCH_ERROR)
2839     goto cleanup;
2840   else if (m == MATCH_NO)
2841     ts.type = BT_UNKNOWN;
2842   else
2843     {
2844       if (gfc_match (" :: ") == MATCH_YES)
2845         {
2846           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
2847                               "ALLOCATE at %L", &old_locus) == FAILURE)
2848             goto cleanup;
2849         }
2850       else
2851         {
2852           ts.type = BT_UNKNOWN;
2853           gfc_current_locus = old_locus;
2854         }
2855     }
2856
2857   for (;;)
2858     {
2859       if (head == NULL)
2860         head = tail = gfc_get_alloc ();
2861       else
2862         {
2863           tail->next = gfc_get_alloc ();
2864           tail = tail->next;
2865         }
2866
2867       m = gfc_match_variable (&tail->expr, 0);
2868       if (m == MATCH_NO)
2869         goto syntax;
2870       if (m == MATCH_ERROR)
2871         goto cleanup;
2872
2873       if (gfc_check_do_variable (tail->expr->symtree))
2874         goto cleanup;
2875
2876       if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2877         {
2878           gfc_error ("Bad allocate-object at %C for a PURE procedure");
2879           goto cleanup;
2880         }
2881
2882       /* The ALLOCATE statement had an optional typespec.  Check the
2883          constraints.  */
2884       if (ts.type != BT_UNKNOWN)
2885         {
2886           /* Enforce F03:C624.  */
2887           if (!gfc_type_compatible (&tail->expr->ts, &ts))
2888             {
2889               gfc_error ("Type of entity at %L is type incompatible with "
2890                          "typespec", &tail->expr->where);
2891               goto cleanup;
2892             }
2893
2894           /* Enforce F03:C627.  */
2895           if (ts.kind != tail->expr->ts.kind)
2896             {
2897               gfc_error ("Kind type parameter for entity at %L differs from "
2898                          "the kind type parameter of the typespec",
2899                          &tail->expr->where);
2900               goto cleanup;
2901             }
2902         }
2903
2904       if (tail->expr->ts.type == BT_DERIVED)
2905         tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
2906
2907       /* FIXME: disable the checking on derived types and arrays.  */
2908       sym = tail->expr->symtree->n.sym;
2909       b1 = !(tail->expr->ref
2910            && (tail->expr->ref->type == REF_COMPONENT
2911                 || tail->expr->ref->type == REF_ARRAY));
2912       if (sym && sym->ts.type == BT_CLASS)
2913         b2 = !(CLASS_DATA (sym)->attr.allocatable
2914                || CLASS_DATA (sym)->attr.class_pointer);
2915       else
2916         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
2917                       || sym->attr.proc_pointer);
2918       b3 = sym && sym->ns && sym->ns->proc_name
2919            && (sym->ns->proc_name->attr.allocatable
2920                 || sym->ns->proc_name->attr.pointer
2921                 || sym->ns->proc_name->attr.proc_pointer);
2922       if (b1 && b2 && !b3)
2923         {
2924           gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2925                      "or an allocatable variable");
2926           goto cleanup;
2927         }
2928
2929       if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
2930         {
2931           gfc_error ("Shape specification for allocatable scalar at %C");
2932           goto cleanup;
2933         }
2934
2935       if (gfc_match_char (',') != MATCH_YES)
2936         break;
2937
2938 alloc_opt_list:
2939
2940       m = gfc_match (" stat = %v", &tmp);
2941       if (m == MATCH_ERROR)
2942         goto cleanup;
2943       if (m == MATCH_YES)
2944         {
2945           /* Enforce C630.  */
2946           if (saw_stat)
2947             {
2948               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2949               goto cleanup;
2950             }
2951
2952           stat = tmp;
2953           saw_stat = true;
2954
2955           if (gfc_check_do_variable (stat->symtree))
2956             goto cleanup;
2957
2958           if (gfc_match_char (',') == MATCH_YES)
2959             goto alloc_opt_list;
2960         }
2961
2962       m = gfc_match (" errmsg = %v", &tmp);
2963       if (m == MATCH_ERROR)
2964         goto cleanup;
2965       if (m == MATCH_YES)
2966         {
2967           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
2968                               &tmp->where) == FAILURE)
2969             goto cleanup;
2970
2971           /* Enforce C630.  */
2972           if (saw_errmsg)
2973             {
2974               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2975               goto cleanup;
2976             }
2977
2978           errmsg = tmp;
2979           saw_errmsg = true;
2980
2981           if (gfc_match_char (',') == MATCH_YES)
2982             goto alloc_opt_list;
2983         }
2984
2985       m = gfc_match (" source = %e", &tmp);
2986       if (m == MATCH_ERROR)
2987         goto cleanup;
2988       if (m == MATCH_YES)
2989         {
2990           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
2991                               &tmp->where) == FAILURE)
2992             goto cleanup;
2993
2994           /* Enforce C630.  */
2995           if (saw_source)
2996             {
2997               gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
2998               goto cleanup;
2999             }
3000
3001           /* The next 2 conditionals check C631.  */
3002           if (ts.type != BT_UNKNOWN)
3003             {
3004               gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3005                          &tmp->where, &old_locus);
3006               goto cleanup;
3007             }
3008
3009           if (head->next)
3010             {
3011               gfc_error ("SOURCE tag at %L requires only a single entity in "
3012                          "the allocation-list", &tmp->where);
3013               goto cleanup;
3014             }
3015
3016           source = tmp;
3017           saw_source = true;
3018
3019           if (gfc_match_char (',') == MATCH_YES)
3020             goto alloc_opt_list;
3021         }
3022
3023       m = gfc_match (" mold = %e", &tmp);
3024       if (m == MATCH_ERROR)
3025         goto cleanup;
3026       if (m == MATCH_YES)
3027         {
3028           if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L",
3029                               &tmp->where) == FAILURE)
3030             goto cleanup;
3031
3032           /* Check F08:C636.  */
3033           if (saw_mold)
3034             {
3035               gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
3036               goto cleanup;
3037             }
3038
3039           /* Check F08:C637.  */
3040           if (ts.type != BT_UNKNOWN)
3041             {
3042               gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3043                          &tmp->where, &old_locus);
3044               goto cleanup;
3045             }
3046
3047           mold = tmp;
3048           saw_mold = true;
3049           mold->mold = 1;
3050
3051           if (gfc_match_char (',') == MATCH_YES)
3052             goto alloc_opt_list;
3053         }
3054
3055         gfc_gobble_whitespace ();
3056
3057         if (gfc_peek_char () == ')')
3058           break;
3059     }
3060
3061
3062   if (gfc_match (" )%t") != MATCH_YES)
3063     goto syntax;
3064
3065   /* Check F08:C637.  */
3066   if (source && mold)
3067     {
3068       gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3069                   &mold->where, &source->where);
3070       goto cleanup;
3071     }
3072
3073   new_st.op = EXEC_ALLOCATE;
3074   new_st.expr1 = stat;
3075   new_st.expr2 = errmsg;
3076   if (source)
3077     new_st.expr3 = source;
3078   else
3079     new_st.expr3 = mold;
3080   new_st.ext.alloc.list = head;
3081   new_st.ext.alloc.ts = ts;
3082
3083   return MATCH_YES;
3084
3085 syntax:
3086   gfc_syntax_error (ST_ALLOCATE);
3087
3088 cleanup:
3089   gfc_free_expr (errmsg);
3090   gfc_free_expr (source);
3091   gfc_free_expr (stat);
3092   gfc_free_expr (mold);
3093   if (tmp && tmp->expr_type) gfc_free_expr (tmp);
3094   gfc_free_alloc_list (head);
3095   return MATCH_ERROR;
3096 }
3097
3098
3099 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3100    a set of pointer assignments to intrinsic NULL().  */
3101
3102 match
3103 gfc_match_nullify (void)
3104 {
3105   gfc_code *tail;
3106   gfc_expr *e, *p;
3107   match m;
3108
3109   tail = NULL;
3110
3111   if (gfc_match_char ('(') != MATCH_YES)
3112     goto syntax;
3113
3114   for (;;)
3115     {
3116       m = gfc_match_variable (&p, 0);
3117       if (m == MATCH_ERROR)
3118         goto cleanup;
3119       if (m == MATCH_NO)
3120         goto syntax;
3121
3122       if (gfc_check_do_variable (p->symtree))
3123         goto cleanup;
3124
3125       if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
3126         {
3127           gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
3128           goto cleanup;
3129         }
3130
3131       /* build ' => NULL() '.  */
3132       e = gfc_get_null_expr (&gfc_current_locus);
3133
3134       /* Chain to list.  */
3135       if (tail == NULL)
3136         tail = &new_st;
3137       else
3138         {
3139           tail->next = gfc_get_code ();
3140           tail = tail->next;
3141         }
3142
3143       tail->op = EXEC_POINTER_ASSIGN;
3144       tail->expr1 = p;
3145       tail->expr2 = e;
3146
3147       if (gfc_match (" )%t") == MATCH_YES)
3148         break;
3149       if (gfc_match_char (',') != MATCH_YES)
3150         goto syntax;
3151     }
3152
3153   return MATCH_YES;
3154
3155 syntax:
3156   gfc_syntax_error (ST_NULLIFY);
3157
3158 cleanup:
3159   gfc_free_statements (new_st.next);
3160   new_st.next = NULL;
3161   gfc_free_expr (new_st.expr1);
3162   new_st.expr1 = NULL;
3163   gfc_free_expr (new_st.expr2);
3164   new_st.expr2 = NULL;
3165   return MATCH_ERROR;
3166 }
3167
3168
3169 /* Match a DEALLOCATE statement.  */
3170
3171 match
3172 gfc_match_deallocate (void)
3173 {
3174   gfc_alloc *head, *tail;
3175   gfc_expr *stat, *errmsg, *tmp;
3176   gfc_symbol *sym;
3177   match m;
3178   bool saw_stat, saw_errmsg, b1, b2;
3179
3180   head = tail = NULL;
3181   stat = errmsg = tmp = NULL;
3182   saw_stat = saw_errmsg = false;
3183
3184   if (gfc_match_char ('(') != MATCH_YES)
3185     goto syntax;
3186
3187   for (;;)
3188     {
3189       if (head == NULL)
3190         head = tail = gfc_get_alloc ();
3191       else
3192         {
3193           tail->next = gfc_get_alloc ();
3194           tail = tail->next;
3195         }
3196
3197       m = gfc_match_variable (&tail->expr, 0);
3198       if (m == MATCH_ERROR)
3199         goto cleanup;
3200       if (m == MATCH_NO)
3201         goto syntax;
3202
3203       if (gfc_check_do_variable (tail->expr->symtree))
3204         goto cleanup;
3205
3206       sym = tail->expr->symtree->n.sym;
3207
3208       if (gfc_pure (NULL) && gfc_impure_variable (sym))
3209         {
3210           gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3211           goto cleanup;
3212         }
3213
3214       /* FIXME: disable the checking on derived types.  */
3215       b1 = !(tail->expr->ref
3216            && (tail->expr->ref->type == REF_COMPONENT
3217                || tail->expr->ref->type == REF_ARRAY));
3218       if (sym && sym->ts.type == BT_CLASS)
3219         b2 = !(CLASS_DATA (sym)->attr.allocatable
3220                || CLASS_DATA (sym)->attr.class_pointer);
3221       else
3222         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3223                       || sym->attr.proc_pointer);
3224       if (b1 && b2)
3225         {
3226           gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3227                      "or an allocatable variable");
3228           goto cleanup;
3229         }
3230
3231       if (gfc_match_char (',') != MATCH_YES)
3232         break;
3233
3234 dealloc_opt_list:
3235
3236       m = gfc_match (" stat = %v", &tmp);
3237       if (m == MATCH_ERROR)
3238         goto cleanup;
3239       if (m == MATCH_YES)
3240         {
3241           if (saw_stat)
3242             {
3243               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3244               gfc_free_expr (tmp);
3245               goto cleanup;
3246             }
3247
3248           stat = tmp;
3249           saw_stat = true;
3250
3251           if (gfc_check_do_variable (stat->symtree))
3252             goto cleanup;
3253
3254           if (gfc_match_char (',') == MATCH_YES)
3255             goto dealloc_opt_list;
3256         }
3257
3258       m = gfc_match (" errmsg = %v", &tmp);
3259       if (m == MATCH_ERROR)
3260         goto cleanup;
3261       if (m == MATCH_YES)
3262         {
3263           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
3264                               &tmp->where) == FAILURE)
3265             goto cleanup;
3266
3267           if (saw_errmsg)
3268             {
3269               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3270               gfc_free_expr (tmp);
3271               goto cleanup;
3272             }
3273
3274           errmsg = tmp;
3275           saw_errmsg = true;
3276
3277           if (gfc_match_char (',') == MATCH_YES)
3278             goto dealloc_opt_list;
3279         }
3280
3281         gfc_gobble_whitespace ();
3282
3283         if (gfc_peek_char () == ')')
3284           break;
3285     }
3286
3287   if (gfc_match (" )%t") != MATCH_YES)
3288     goto syntax;
3289
3290   new_st.op = EXEC_DEALLOCATE;
3291   new_st.expr1 = stat;
3292   new_st.expr2 = errmsg;
3293   new_st.ext.alloc.list = head;
3294
3295   return MATCH_YES;
3296
3297 syntax:
3298   gfc_syntax_error (ST_DEALLOCATE);
3299
3300 cleanup:
3301   gfc_free_expr (errmsg);
3302   gfc_free_expr (stat);
3303   gfc_free_alloc_list (head);
3304   return MATCH_ERROR;
3305 }
3306
3307
3308 /* Match a RETURN statement.  */
3309
3310 match
3311 gfc_match_return (void)
3312 {
3313   gfc_expr *e;
3314   match m;
3315   gfc_compile_state s;
3316
3317   e = NULL;
3318
3319   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
3320     {
3321       gfc_error ("Image control statement RETURN at %C in CRITICAL block");
3322       return MATCH_ERROR;
3323     }
3324
3325   if (gfc_match_eos () == MATCH_YES)
3326     goto done;
3327
3328   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
3329     {
3330       gfc_error ("Alternate RETURN statement at %C is only allowed within "
3331                  "a SUBROUTINE");
3332       goto cleanup;
3333     }
3334
3335   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN "
3336                       "at %C") == FAILURE)
3337     return MATCH_ERROR;
3338
3339   if (gfc_current_form == FORM_FREE)
3340     {
3341       /* The following are valid, so we can't require a blank after the
3342         RETURN keyword:
3343           return+1
3344           return(1)  */
3345       char c = gfc_peek_ascii_char ();
3346       if (ISALPHA (c) || ISDIGIT (c))
3347         return MATCH_NO;
3348     }
3349
3350   m = gfc_match (" %e%t", &e);
3351   if (m == MATCH_YES)
3352     goto done;
3353   if (m == MATCH_ERROR)
3354     goto cleanup;
3355
3356   gfc_syntax_error (ST_RETURN);
3357
3358 cleanup:
3359   gfc_free_expr (e);
3360   return MATCH_ERROR;
3361
3362 done:
3363   gfc_enclosing_unit (&s);
3364   if (s == COMP_PROGRAM
3365       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
3366                         "main program at %C") == FAILURE)
3367       return MATCH_ERROR;
3368
3369   new_st.op = EXEC_RETURN;
3370   new_st.expr1 = e;
3371
3372   return MATCH_YES;
3373 }
3374
3375
3376 /* Match the call of a type-bound procedure, if CALL%var has already been
3377    matched and var found to be a derived-type variable.  */
3378
3379 static match
3380 match_typebound_call (gfc_symtree* varst)
3381 {
3382   gfc_expr* base;
3383   match m;
3384
3385   base = gfc_get_expr ();
3386   base->expr_type = EXPR_VARIABLE;
3387   base->symtree = varst;
3388   base->where = gfc_current_locus;
3389   gfc_set_sym_referenced (varst->n.sym);
3390
3391   m = gfc_match_varspec (base, 0, true, true);
3392   if (m == MATCH_NO)
3393     gfc_error ("Expected component reference at %C");
3394   if (m != MATCH_YES)
3395     return MATCH_ERROR;
3396
3397   if (gfc_match_eos () != MATCH_YES)
3398     {
3399       gfc_error ("Junk after CALL at %C");
3400       return MATCH_ERROR;
3401     }
3402
3403   if (base->expr_type == EXPR_COMPCALL)
3404     new_st.op = EXEC_COMPCALL;
3405   else if (base->expr_type == EXPR_PPC)
3406     new_st.op = EXEC_CALL_PPC;
3407   else
3408     {
3409       gfc_error ("Expected type-bound procedure or procedure pointer component "
3410                  "at %C");
3411       return MATCH_ERROR;
3412     }
3413   new_st.expr1 = base;
3414
3415   return MATCH_YES;
3416 }
3417
3418
3419 /* Match a CALL statement.  The tricky part here are possible
3420    alternate return specifiers.  We handle these by having all
3421    "subroutines" actually return an integer via a register that gives
3422    the return number.  If the call specifies alternate returns, we
3423    generate code for a SELECT statement whose case clauses contain
3424    GOTOs to the various labels.  */
3425
3426 match
3427 gfc_match_call (void)
3428 {
3429   char name[GFC_MAX_SYMBOL_LEN + 1];
3430   gfc_actual_arglist *a, *arglist;
3431   gfc_case *new_case;
3432   gfc_symbol *sym;
3433   gfc_symtree *st;
3434   gfc_code *c;
3435   match m;
3436   int i;
3437
3438   arglist = NULL;
3439
3440   m = gfc_match ("% %n", name);
3441   if (m == MATCH_NO)
3442     goto syntax;
3443   if (m != MATCH_YES)
3444     return m;
3445
3446   if (gfc_get_ha_sym_tree (name, &st))
3447     return MATCH_ERROR;
3448
3449   sym = st->n.sym;
3450
3451   /* If this is a variable of derived-type, it probably starts a type-bound
3452      procedure call.  */
3453   if ((sym->attr.flavor != FL_PROCEDURE
3454        || gfc_is_function_return_value (sym, gfc_current_ns))
3455       && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
3456     return match_typebound_call (st);
3457
3458   /* If it does not seem to be callable (include functions so that the
3459      right association is made.  They are thrown out in resolution.)
3460      ...  */
3461   if (!sym->attr.generic
3462         && !sym->attr.subroutine
3463         && !sym->attr.function)
3464     {
3465       if (!(sym->attr.external && !sym->attr.referenced))
3466         {
3467           /* ...create a symbol in this scope...  */
3468           if (sym->ns != gfc_current_ns
3469                 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
3470             return MATCH_ERROR;
3471
3472           if (sym != st->n.sym)
3473             sym = st->n.sym;
3474         }
3475
3476       /* ...and then to try to make the symbol into a subroutine.  */
3477       if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
3478         return MATCH_ERROR;
3479     }
3480
3481   gfc_set_sym_referenced (sym);
3482
3483   if (gfc_match_eos () != MATCH_YES)
3484     {
3485       m = gfc_match_actual_arglist (1, &arglist);
3486       if (m == MATCH_NO)
3487         goto syntax;
3488       if (m == MATCH_ERROR)
3489         goto cleanup;
3490
3491       if (gfc_match_eos () != MATCH_YES)
3492         goto syntax;
3493     }
3494
3495   /* If any alternate return labels were found, construct a SELECT
3496      statement that will jump to the right place.  */
3497
3498   i = 0;
3499   for (a = arglist; a; a = a->next)
3500     if (a->expr == NULL)
3501       i = 1;
3502
3503   if (i)
3504     {
3505       gfc_symtree *select_st;
3506       gfc_symbol *select_sym;
3507       char name[GFC_MAX_SYMBOL_LEN + 1];
3508
3509       new_st.next = c = gfc_get_code ();
3510       c->op = EXEC_SELECT;
3511       sprintf (name, "_result_%s", sym->name);
3512       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
3513
3514       select_sym = select_st->n.sym;
3515       select_sym->ts.type = BT_INTEGER;
3516       select_sym->ts.kind = gfc_default_integer_kind;
3517       gfc_set_sym_referenced (select_sym);
3518       c->expr1 = gfc_get_expr ();
3519       c->expr1->expr_type = EXPR_VARIABLE;
3520       c->expr1->symtree = select_st;
3521       c->expr1->ts = select_sym->ts;
3522       c->expr1->where = gfc_current_locus;
3523
3524       i = 0;
3525       for (a = arglist; a; a = a->next)
3526         {
3527           if (a->expr != NULL)
3528             continue;
3529
3530           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
3531             continue;
3532
3533           i++;
3534
3535           c->block = gfc_get_code ();
3536           c = c->block;
3537           c->op = EXEC_SELECT;
3538
3539           new_case = gfc_get_case ();
3540           new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
3541           new_case->low = new_case->high;
3542           c->ext.case_list = new_case;
3543
3544           c->next = gfc_get_code ();
3545           c->next->op = EXEC_GOTO;
3546           c->next->label1 = a->label;
3547         }
3548     }
3549
3550   new_st.op = EXEC_CALL;
3551   new_st.symtree = st;
3552   new_st.ext.actual = arglist;
3553
3554   return MATCH_YES;
3555
3556 syntax:
3557   gfc_syntax_error (ST_CALL);
3558
3559 cleanup:
3560   gfc_free_actual_arglist (arglist);
3561   return MATCH_ERROR;
3562 }
3563
3564
3565 /* Given a name, return a pointer to the common head structure,
3566    creating it if it does not exist. If FROM_MODULE is nonzero, we
3567    mangle the name so that it doesn't interfere with commons defined
3568    in the using namespace.
3569    TODO: Add to global symbol tree.  */
3570
3571 gfc_common_head *
3572 gfc_get_common (const char *name, int from_module)
3573 {
3574   gfc_symtree *st;
3575   static int serial = 0;
3576   char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
3577
3578   if (from_module)
3579     {
3580       /* A use associated common block is only needed to correctly layout
3581          the variables it contains.  */
3582       snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
3583       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
3584     }
3585   else
3586     {
3587       st = gfc_find_symtree (gfc_current_ns->common_root, name);
3588
3589       if (st == NULL)
3590         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
3591     }
3592
3593   if (st->n.common == NULL)
3594     {
3595       st->n.common = gfc_get_common_head ();
3596       st->n.common->where = gfc_current_locus;
3597       strcpy (st->n.common->name, name);
3598     }
3599
3600   return st->n.common;
3601 }
3602
3603
3604 /* Match a common block name.  */
3605
3606 match match_common_name (char *name)
3607 {
3608   match m;
3609
3610   if (gfc_match_char ('/') == MATCH_NO)
3611     {
3612       name[0] = '\0';
3613       return MATCH_YES;
3614     }
3615
3616   if (gfc_match_char ('/') == MATCH_YES)
3617     {
3618       name[0] = '\0';
3619       return MATCH_YES;
3620     }
3621
3622   m = gfc_match_name (name);
3623
3624   if (m == MATCH_ERROR)
3625     return MATCH_ERROR;
3626   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
3627     return MATCH_YES;
3628
3629   gfc_error ("Syntax error in common block name at %C");
3630   return MATCH_ERROR;
3631 }
3632
3633
3634 /* Match a COMMON statement.  */
3635
3636 match
3637 gfc_match_common (void)
3638 {
3639   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
3640   char name[GFC_MAX_SYMBOL_LEN + 1];
3641   gfc_common_head *t;
3642   gfc_array_spec *as;
3643   gfc_equiv *e1, *e2;
3644   match m;
3645   gfc_gsymbol *gsym;
3646
3647   old_blank_common = gfc_current_ns->blank_common.head;
3648   if (old_blank_common)
3649     {
3650       while (old_blank_common->common_next)
3651         old_blank_common = old_blank_common->common_next;
3652     }
3653
3654   as = NULL;
3655
3656   for (;;)
3657     {
3658       m = match_common_name (name);
3659       if (m == MATCH_ERROR)
3660         goto cleanup;
3661
3662       gsym = gfc_get_gsymbol (name);
3663       if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
3664         {
3665           gfc_error ("Symbol '%s' at %C is already an external symbol that "
3666                      "is not COMMON", name);
3667           goto cleanup;
3668         }
3669
3670       if (gsym->type == GSYM_UNKNOWN)
3671         {
3672           gsym->type = GSYM_COMMON;
3673           gsym->where = gfc_current_locus;
3674           gsym->defined = 1;
3675         }
3676
3677       gsym->used = 1;
3678
3679       if (name[0] == '\0')
3680         {
3681           t = &gfc_current_ns->blank_common;
3682           if (t->head == NULL)
3683             t->where = gfc_current_locus;
3684         }
3685       else
3686         {
3687           t = gfc_get_common (name, 0);
3688         }
3689       head = &t->head;
3690
3691       if (*head == NULL)
3692         tail = NULL;
3693       else
3694         {
3695           tail = *head;
3696           while (tail->common_next)
3697             tail = tail->common_next;
3698         }
3699
3700       /* Grab the list of symbols.  */
3701       for (;;)
3702         {
3703           m = gfc_match_symbol (&sym, 0);
3704           if (m == MATCH_ERROR)
3705             goto cleanup;
3706           if (m == MATCH_NO)
3707             goto syntax;
3708
3709           /* Store a ref to the common block for error checking.  */
3710           sym->common_block = t;
3711
3712           /* See if we know the current common block is bind(c), and if
3713              so, then see if we can check if the symbol is (which it'll
3714              need to be).  This can happen if the bind(c) attr stmt was
3715              applied to the common block, and the variable(s) already
3716              defined, before declaring the common block.  */
3717           if (t->is_bind_c == 1)
3718             {
3719               if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
3720                 {
3721                   /* If we find an error, just print it and continue,
3722                      cause it's just semantic, and we can see if there
3723                      are more errors.  */
3724                   gfc_error_now ("Variable '%s' at %L in common block '%s' "
3725                                  "at %C must be declared with a C "
3726                                  "interoperable kind since common block "
3727                                  "'%s' is bind(c)",
3728                                  sym->name, &(sym->declared_at), t->name,
3729                                  t->name);
3730                 }
3731
3732               if (sym->attr.is_bind_c == 1)
3733                 gfc_error_now ("Variable '%s' in common block "
3734                                "'%s' at %C can not be bind(c) since "
3735                                "it is not global", sym->name, t->name);
3736             }
3737
3738           if (sym->attr.in_common)
3739             {
3740               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
3741                          sym->name);
3742               goto cleanup;
3743             }
3744
3745           if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
3746                || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
3747             {
3748               if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
3749                                                "can only be COMMON in "
3750                                                "BLOCK DATA", sym->name)
3751                   == FAILURE)
3752                 goto cleanup;
3753             }
3754
3755           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
3756             goto cleanup;
3757
3758           if (tail != NULL)
3759             tail->common_next = sym;
3760           else
3761             *head = sym;
3762
3763           tail = sym;
3764
3765           /* Deal with an optional array specification after the
3766              symbol name.  */
3767           m = gfc_match_array_spec (&as, true, true);
3768           if (m == MATCH_ERROR)
3769             goto cleanup;
3770
3771           if (m == MATCH_YES)
3772             {
3773               if (as->type != AS_EXPLICIT)
3774                 {
3775                   gfc_error ("Array specification for symbol '%s' in COMMON "
3776                              "at %C must be explicit", sym->name);
3777                   goto cleanup;
3778                 }
3779
3780               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
3781                 goto cleanup;
3782
3783               if (sym->attr.pointer)
3784                 {
3785                   gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3786                              "POINTER array", sym->name);
3787                   goto cleanup;
3788                 }
3789
3790               sym->as = as;
3791               as = NULL;
3792
3793             }
3794
3795           sym->common_head = t;
3796
3797           /* Check to see if the symbol is already in an equivalence group.
3798              If it is, set the other members as being in common.  */
3799           if (sym->attr.in_equivalence)
3800             {
3801               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
3802                 {
3803                   for (e2 = e1; e2; e2 = e2->eq)
3804                     if (e2->expr->symtree->n.sym == sym)
3805                       goto equiv_found;
3806
3807                   continue;
3808
3809           equiv_found:
3810
3811                   for (e2 = e1; e2; e2 = e2->eq)
3812                     {
3813                       other = e2->expr->symtree->n.sym;
3814                       if (other->common_head
3815                           && other->common_head != sym->common_head)
3816                         {
3817                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
3818                                      "%C is being indirectly equivalenced to "
3819                                      "another COMMON block '%s'",
3820                                      sym->name, sym->common_head->name,
3821                                      other->common_head->name);
3822                             goto cleanup;
3823                         }
3824                       other->attr.in_common = 1;
3825                       other->common_head = t;
3826                     }
3827                 }
3828             }
3829
3830
3831           gfc_gobble_whitespace ();
3832           if (gfc_match_eos () == MATCH_YES)
3833             goto done;
3834           if (gfc_peek_ascii_char () == '/')
3835             break;
3836           if (gfc_match_char (',') != MATCH_YES)
3837             goto syntax;
3838           gfc_gobble_whitespace ();
3839           if (gfc_peek_ascii_char () == '/')
3840             break;
3841         }
3842     }
3843
3844 done:
3845   return MATCH_YES;
3846
3847 syntax:
3848   gfc_syntax_error (ST_COMMON);
3849
3850 cleanup:
3851   if (old_blank_common)
3852     old_blank_common->common_next = NULL;
3853   else
3854     gfc_current_ns->blank_common.head = NULL;
3855   gfc_free_array_spec (as);
3856   return MATCH_ERROR;
3857 }
3858
3859
3860 /* Match a BLOCK DATA program unit.  */
3861
3862 match
3863 gfc_match_block_data (void)
3864 {
3865   char name[GFC_MAX_SYMBOL_LEN + 1];
3866   gfc_symbol *sym;
3867   match m;
3868
3869   if (gfc_match_eos () == MATCH_YES)
3870     {
3871       gfc_new_block = NULL;
3872       return MATCH_YES;
3873     }
3874
3875   m = gfc_match ("% %n%t", name);
3876   if (m != MATCH_YES)
3877     return MATCH_ERROR;
3878
3879   if (gfc_get_symbol (name, NULL, &sym))
3880     return MATCH_ERROR;
3881
3882   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
3883     return MATCH_ERROR;
3884
3885   gfc_new_block = sym;
3886
3887   return MATCH_YES;
3888 }
3889
3890
3891 /* Free a namelist structure.  */
3892
3893 void
3894 gfc_free_namelist (gfc_namelist *name)
3895 {
3896   gfc_namelist *n;
3897
3898   for (; name; name = n)
3899     {
3900       n = name->next;
3901       gfc_free (name);
3902     }
3903 }
3904
3905
3906 /* Match a NAMELIST statement.  */
3907
3908 match
3909 gfc_match_namelist (void)
3910 {
3911   gfc_symbol *group_name, *sym;
3912   gfc_namelist *nl;
3913   match m, m2;
3914
3915   m = gfc_match (" / %s /", &group_name);
3916   if (m == MATCH_NO)
3917     goto syntax;
3918   if (m == MATCH_ERROR)
3919     goto error;
3920
3921   for (;;)
3922     {
3923       if (group_name->ts.type != BT_UNKNOWN)
3924         {
3925           gfc_error ("Namelist group name '%s' at %C already has a basic "
3926                      "type of %s", group_name->name,
3927                      gfc_typename (&group_name->ts));
3928           return MATCH_ERROR;
3929         }
3930
3931       if (group_name->attr.flavor == FL_NAMELIST
3932           && group_name->attr.use_assoc
3933           && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
3934                              "at %C already is USE associated and can"
3935                              "not be respecified.", group_name->name)
3936              == FAILURE)
3937         return MATCH_ERROR;
3938
3939       if (group_name->attr.flavor != FL_NAMELIST
3940           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
3941                              group_name->name, NULL) == FAILURE)
3942         return MATCH_ERROR;
3943
3944       for (;;)
3945         {
3946           m = gfc_match_symbol (&sym, 1);
3947           if (m == MATCH_NO)
3948             goto syntax;
3949           if (m == MATCH_ERROR)
3950             goto error;
3951
3952           if (sym->attr.in_namelist == 0
3953               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
3954             goto error;
3955
3956           /* Use gfc_error_check here, rather than goto error, so that
3957              these are the only errors for the next two lines.  */
3958           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3959             {
3960               gfc_error ("Assumed size array '%s' in namelist '%s' at "
3961                          "%C is not allowed", sym->name, group_name->name);
3962               gfc_error_check ();
3963             }
3964
3965           if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl->length == NULL)
3966             {
3967               gfc_error ("Assumed character length '%s' in namelist '%s' at "
3968                          "%C is not allowed", sym->name, group_name->name);
3969               gfc_error_check ();
3970             }
3971
3972           nl = gfc_get_namelist ();
3973           nl->sym = sym;
3974           sym->refs++;
3975
3976           if (group_name->namelist == NULL)
3977             group_name->namelist = group_name->namelist_tail = nl;
3978           else
3979             {
3980               group_name->namelist_tail->next = nl;
3981               group_name->namelist_tail = nl;
3982             }
3983
3984           if (gfc_match_eos () == MATCH_YES)
3985             goto done;
3986
3987           m = gfc_match_char (',');
3988
3989           if (gfc_match_char ('/') == MATCH_YES)
3990             {
3991               m2 = gfc_match (" %s /", &group_name);
3992               if (m2 == MATCH_YES)
3993                 break;
3994               if (m2 == MATCH_ERROR)
3995                 goto error;
3996               goto syntax;
3997             }
3998
3999           if (m != MATCH_YES)
4000             goto syntax;
4001         }
4002     }
4003
4004 done:
4005   return MATCH_YES;
4006
4007 syntax:
4008   gfc_syntax_error (ST_NAMELIST);
4009
4010 error:
4011   return MATCH_ERROR;
4012 }
4013
4014
4015 /* Match a MODULE statement.  */
4016
4017 match
4018 gfc_match_module (void)
4019 {
4020   match m;
4021
4022   m = gfc_match (" %s%t", &gfc_new_block);
4023   if (m != MATCH_YES)
4024     return m;
4025
4026   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
4027                       gfc_new_block->name, NULL) == FAILURE)
4028     return MATCH_ERROR;
4029
4030   return MATCH_YES;
4031 }
4032
4033
4034 /* Free equivalence sets and lists.  Recursively is the easiest way to
4035    do this.  */
4036
4037 void
4038 gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
4039 {
4040   if (eq == stop)
4041     return;
4042
4043   gfc_free_equiv (eq->eq);
4044   gfc_free_equiv_until (eq->next, stop);
4045   gfc_free_expr (eq->expr);
4046   gfc_free (eq);
4047 }
4048
4049
4050 void
4051 gfc_free_equiv (gfc_equiv *eq)
4052 {
4053   gfc_free_equiv_until (eq, NULL);
4054 }
4055
4056
4057 /* Match an EQUIVALENCE statement.  */
4058
4059 match
4060 gfc_match_equivalence (void)
4061 {
4062   gfc_equiv *eq, *set, *tail;
4063   gfc_ref *ref;
4064   gfc_symbol *sym;
4065   match m;
4066   gfc_common_head *common_head = NULL;
4067   bool common_flag;
4068   int cnt;
4069
4070   tail = NULL;
4071
4072   for (;;)
4073     {
4074       eq = gfc_get_equiv ();
4075       if (tail == NULL)
4076         tail = eq;
4077
4078       eq->next = gfc_current_ns->equiv;
4079       gfc_current_ns->equiv = eq;
4080
4081       if (gfc_match_char ('(') != MATCH_YES)
4082         goto syntax;
4083
4084       set = eq;
4085       common_flag = FALSE;
4086       cnt = 0;
4087
4088       for (;;)
4089         {
4090           m = gfc_match_equiv_variable (&set->expr);
4091           if (m == MATCH_ERROR)
4092             goto cleanup;
4093           if (m == MATCH_NO)
4094             goto syntax;
4095
4096           /*  count the number of objects.  */
4097           cnt++;
4098
4099           if (gfc_match_char ('%') == MATCH_YES)
4100             {
4101               gfc_error ("Derived type component %C is not a "
4102                          "permitted EQUIVALENCE member");
4103               goto cleanup;
4104             }
4105
4106           for (ref = set->expr->ref; ref; ref = ref->next)
4107             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
4108               {
4109                 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4110                            "be an array section");
4111                 goto cleanup;
4112               }
4113
4114           sym = set->expr->symtree->n.sym;
4115
4116           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
4117             goto cleanup;
4118
4119           if (sym->attr.in_common)
4120             {
4121               common_flag = TRUE;
4122               common_head = sym->common_head;
4123             }
4124
4125           if (gfc_match_char (')') == MATCH_YES)
4126             break;
4127
4128           if (gfc_match_char (',') != MATCH_YES)
4129             goto syntax;
4130
4131           set->eq = gfc_get_equiv ();
4132           set = set->eq;
4133         }
4134
4135       if (cnt < 2)
4136         {
4137           gfc_error ("EQUIVALENCE at %C requires two or more objects");
4138           goto cleanup;
4139         }
4140
4141       /* If one of the members of an equivalence is in common, then
4142          mark them all as being in common.  Before doing this, check
4143          that members of the equivalence group are not in different
4144          common blocks.  */
4145       if (common_flag)
4146         for (set = eq; set; set = set->eq)
4147           {
4148             sym = set->expr->symtree->n.sym;
4149             if (sym->common_head && sym->common_head != common_head)
4150               {
4151                 gfc_error ("Attempt to indirectly overlap COMMON "
4152                            "blocks %s and %s by EQUIVALENCE at %C",
4153                            sym->common_head->name, common_head->name);
4154                 goto cleanup;
4155               }
4156             sym->attr.in_common = 1;
4157             sym->common_head = common_head;
4158           }
4159
4160       if (gfc_match_eos () == MATCH_YES)
4161         break;
4162       if (gfc_match_char (',') != MATCH_YES)
4163         {
4164           gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4165           goto cleanup;
4166         }
4167     }
4168
4169   return MATCH_YES;
4170
4171 syntax:
4172   gfc_syntax_error (ST_EQUIVALENCE);
4173
4174 cleanup:
4175   eq = tail->next;
4176   tail->next = NULL;
4177
4178   gfc_free_equiv (gfc_current_ns->equiv);
4179   gfc_current_ns->equiv = eq;
4180
4181   return MATCH_ERROR;
4182 }
4183
4184
4185 /* Check that a statement function is not recursive. This is done by looking
4186    for the statement function symbol(sym) by looking recursively through its
4187    expression(e).  If a reference to sym is found, true is returned.
4188    12.5.4 requires that any variable of function that is implicitly typed
4189    shall have that type confirmed by any subsequent type declaration.  The
4190    implicit typing is conveniently done here.  */
4191 static bool
4192 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
4193
4194 static bool
4195 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
4196 {
4197
4198   if (e == NULL)
4199     return false;
4200
4201   switch (e->expr_type)
4202     {
4203     case EXPR_FUNCTION:
4204       if (e->symtree == NULL)
4205         return false;
4206
4207       /* Check the name before testing for nested recursion!  */
4208       if (sym->name == e->symtree->n.sym->name)
4209         return true;
4210
4211       /* Catch recursion via other statement functions.  */
4212       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
4213           && e->symtree->n.sym->value
4214           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
4215         return true;
4216
4217       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4218         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4219
4220       break;
4221
4222     case EXPR_VARIABLE:
4223       if (e->symtree && sym->name == e->symtree->n.sym->name)
4224         return true;
4225
4226       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4227         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4228       break;
4229
4230     default:
4231       break;
4232     }
4233
4234   return false;
4235 }
4236
4237
4238 static bool
4239 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
4240 {
4241   return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
4242 }
4243
4244
4245 /* Match a statement function declaration.  It is so easy to match
4246    non-statement function statements with a MATCH_ERROR as opposed to
4247    MATCH_NO that we suppress error message in most cases.  */
4248
4249 match
4250 gfc_match_st_function (void)
4251 {
4252   gfc_error_buf old_error;
4253   gfc_symbol *sym;
4254   gfc_expr *expr;
4255   match m;
4256
4257   m = gfc_match_symbol (&sym, 0);
4258   if (m != MATCH_YES)
4259     return m;
4260
4261   gfc_push_error (&old_error);
4262
4263   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
4264                          sym->name, NULL) == FAILURE)
4265     goto undo_error;
4266
4267   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
4268     goto undo_error;
4269
4270   m = gfc_match (" = %e%t", &expr);
4271   if (m == MATCH_NO)
4272     goto undo_error;
4273
4274   gfc_free_error (&old_error);
4275   if (m == MATCH_ERROR)
4276     return m;
4277
4278   if (recursive_stmt_fcn (expr, sym))
4279     {
4280       gfc_error ("Statement function at %L is recursive", &expr->where);
4281       return MATCH_ERROR;
4282     }
4283
4284   sym->value = expr;
4285
4286   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
4287                       "Statement function at %C") == FAILURE)
4288     return MATCH_ERROR;
4289
4290   return MATCH_YES;
4291
4292 undo_error:
4293   gfc_pop_error (&old_error);
4294   return MATCH_NO;
4295 }
4296
4297
4298 /***************** SELECT CASE subroutines ******************/
4299
4300 /* Free a single case structure.  */
4301
4302 static void
4303 free_case (gfc_case *p)
4304 {
4305   if (p->low == p->high)
4306     p->high = NULL;
4307   gfc_free_expr (p->low);
4308   gfc_free_expr (p->high);
4309   gfc_free (p);
4310 }
4311
4312
4313 /* Free a list of case structures.  */
4314
4315 void
4316 gfc_free_case_list (gfc_case *p)
4317 {
4318   gfc_case *q;
4319
4320   for (; p; p = q)
4321     {
4322       q = p->next;
4323       free_case (p);
4324     }
4325 }
4326
4327
4328 /* Match a single case selector.  */
4329
4330 static match
4331 match_case_selector (gfc_case **cp)
4332 {
4333   gfc_case *c;
4334   match m;
4335
4336   c = gfc_get_case ();
4337   c->where = gfc_current_locus;
4338
4339   if (gfc_match_char (':') == MATCH_YES)
4340     {
4341       m = gfc_match_init_expr (&c->high);
4342       if (m == MATCH_NO)
4343         goto need_expr;
4344       if (m == MATCH_ERROR)
4345         goto cleanup;
4346     }
4347   else
4348     {
4349       m = gfc_match_init_expr (&c->low);
4350       if (m == MATCH_ERROR)
4351         goto cleanup;
4352       if (m == MATCH_NO)
4353         goto need_expr;
4354
4355       /* If we're not looking at a ':' now, make a range out of a single
4356          target.  Else get the upper bound for the case range.  */
4357       if (gfc_match_char (':') != MATCH_YES)
4358         c->high = c->low;
4359       else
4360         {
4361           m = gfc_match_init_expr (&c->high);
4362           if (m == MATCH_ERROR)
4363             goto cleanup;
4364           /* MATCH_NO is fine.  It's OK if nothing is there!  */
4365         }
4366     }
4367
4368   *cp = c;
4369   return MATCH_YES;
4370
4371 need_expr:
4372   gfc_error ("Expected initialization expression in CASE at %C");
4373
4374 cleanup:
4375   free_case (c);
4376   return MATCH_ERROR;
4377 }
4378
4379
4380 /* Match the end of a case statement.  */
4381
4382 static match
4383 match_case_eos (void)
4384 {
4385   char name[GFC_MAX_SYMBOL_LEN + 1];
4386   match m;
4387
4388   if (gfc_match_eos () == MATCH_YES)
4389     return MATCH_YES;
4390
4391   /* If the case construct doesn't have a case-construct-name, we
4392      should have matched the EOS.  */
4393   if (!gfc_current_block ())
4394     return MATCH_NO;
4395
4396   gfc_gobble_whitespace ();
4397
4398   m = gfc_match_name (name);
4399   if (m != MATCH_YES)
4400     return m;
4401
4402   if (strcmp (name, gfc_current_block ()->name) != 0)
4403     {
4404       gfc_error ("Expected block name '%s' of SELECT construct at %C",
4405                  gfc_current_block ()->name);
4406       return MATCH_ERROR;
4407     }
4408
4409   return gfc_match_eos ();
4410 }
4411
4412
4413 /* Match a SELECT statement.  */
4414
4415 match
4416 gfc_match_select (void)
4417 {
4418   gfc_expr *expr;
4419   match m;
4420
4421   m = gfc_match_label ();
4422   if (m == MATCH_ERROR)
4423     return m;
4424
4425   m = gfc_match (" select case ( %e )%t", &expr);
4426   if (m != MATCH_YES)
4427     return m;
4428
4429   new_st.op = EXEC_SELECT;
4430   new_st.expr1 = expr;
4431
4432   return MATCH_YES;
4433 }
4434
4435
4436 /* Push the current selector onto the SELECT TYPE stack.  */
4437
4438 static void
4439 select_type_push (gfc_symbol *sel)
4440 {
4441   gfc_select_type_stack *top = gfc_get_select_type_stack ();
4442   top->selector = sel;
4443   top->tmp = NULL;
4444   top->prev = select_type_stack;
4445
4446   select_type_stack = top;
4447 }
4448
4449
4450 /* Set the temporary for the current SELECT TYPE selector.  */
4451
4452 static void
4453 select_type_set_tmp (gfc_typespec *ts)
4454 {
4455   char name[GFC_MAX_SYMBOL_LEN];
4456   gfc_symtree *tmp;
4457
4458   if (!gfc_type_is_extensible (ts->u.derived))
4459     return;
4460
4461   if (ts->type == BT_CLASS)
4462     sprintf (name, "tmp$class$%s", ts->u.derived->name);
4463   else
4464     sprintf (name, "tmp$type$%s", ts->u.derived->name);
4465   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
4466   gfc_add_type (tmp->n.sym, ts, NULL);
4467   gfc_set_sym_referenced (tmp->n.sym);
4468   gfc_add_pointer (&tmp->n.sym->attr, NULL);
4469   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
4470   if (ts->type == BT_CLASS)
4471     {
4472       gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
4473                               &tmp->n.sym->as, false);
4474       tmp->n.sym->attr.class_ok = 1;
4475     }
4476
4477   select_type_stack->tmp = tmp;
4478 }
4479
4480
4481 /* Match a SELECT TYPE statement.  */
4482
4483 match
4484 gfc_match_select_type (void)
4485 {
4486   gfc_expr *expr1, *expr2 = NULL;
4487   match m;
4488   char name[GFC_MAX_SYMBOL_LEN];
4489
4490   m = gfc_match_label ();
4491   if (m == MATCH_ERROR)
4492     return m;
4493
4494   m = gfc_match (" select type ( ");
4495   if (m != MATCH_YES)
4496     return m;
4497
4498   gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
4499
4500   m = gfc_match (" %n => %e", name, &expr2);
4501   if (m == MATCH_YES)
4502     {
4503       expr1 = gfc_get_expr();
4504       expr1->expr_type = EXPR_VARIABLE;
4505       if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
4506         {
4507           m = MATCH_ERROR;
4508           goto cleanup;
4509         }
4510       if (expr2->ts.type == BT_UNKNOWN)
4511         expr1->symtree->n.sym->attr.untyped = 1;
4512       else
4513         expr1->symtree->n.sym->ts = expr2->ts;
4514       expr1->symtree->n.sym->attr.referenced = 1;
4515       expr1->symtree->n.sym->attr.class_ok = 1;
4516     }
4517   else
4518     {
4519       m = gfc_match (" %e ", &expr1);
4520       if (m != MATCH_YES)
4521         goto cleanup;
4522     }
4523
4524   m = gfc_match (" )%t");
4525   if (m != MATCH_YES)
4526     goto cleanup;
4527
4528   /* Check for F03:C811.  */
4529   if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
4530     {
4531       gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
4532                  "use associate-name=>");
4533       m = MATCH_ERROR;
4534       goto cleanup;
4535     }
4536
4537   new_st.op = EXEC_SELECT_TYPE;
4538   new_st.expr1 = expr1;
4539   new_st.expr2 = expr2;
4540   new_st.ext.block.ns = gfc_current_ns;
4541
4542   select_type_push (expr1->symtree->n.sym);
4543
4544   return MATCH_YES;
4545
4546 cleanup:
4547   gfc_current_ns = gfc_current_ns->parent;
4548   return m;
4549 }
4550
4551
4552 /* Match a CASE statement.  */
4553
4554 match
4555 gfc_match_case (void)
4556 {
4557   gfc_case *c, *head, *tail;
4558   match m;
4559
4560   head = tail = NULL;
4561
4562   if (gfc_current_state () != COMP_SELECT)
4563     {
4564       gfc_error ("Unexpected CASE statement at %C");
4565       return MATCH_ERROR;
4566     }
4567
4568   if (gfc_match ("% default") == MATCH_YES)
4569     {
4570       m = match_case_eos ();
4571       if (m == MATCH_NO)
4572         goto syntax;
4573       if (m == MATCH_ERROR)
4574         goto cleanup;
4575
4576       new_st.op = EXEC_SELECT;
4577       c = gfc_get_case ();
4578       c->where = gfc_current_locus;
4579       new_st.ext.case_list = c;
4580       return MATCH_YES;
4581     }
4582
4583   if (gfc_match_char ('(') != MATCH_YES)
4584     goto syntax;
4585
4586   for (;;)
4587     {
4588       if (match_case_selector (&c) == MATCH_ERROR)
4589         goto cleanup;
4590
4591       if (head == NULL)
4592         head = c;
4593       else
4594         tail->next = c;
4595
4596       tail = c;
4597
4598       if (gfc_match_char (')') == MATCH_YES)
4599         break;
4600       if (gfc_match_char (',') != MATCH_YES)
4601         goto syntax;
4602     }
4603
4604   m = match_case_eos ();
4605   if (m == MATCH_NO)
4606     goto syntax;
4607   if (m == MATCH_ERROR)
4608     goto cleanup;
4609
4610   new_st.op = EXEC_SELECT;
4611   new_st.ext.case_list = head;
4612
4613   return MATCH_YES;
4614
4615 syntax:
4616   gfc_error ("Syntax error in CASE specification at %C");
4617
4618 cleanup:
4619   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
4620   return MATCH_ERROR;
4621 }
4622
4623
4624 /* Match a TYPE IS statement.  */
4625
4626 match
4627 gfc_match_type_is (void)
4628 {
4629   gfc_case *c = NULL;
4630   match m;
4631
4632   if (gfc_current_state () != COMP_SELECT_TYPE)
4633     {
4634       gfc_error ("Unexpected TYPE IS statement at %C");
4635       return MATCH_ERROR;
4636     }
4637
4638   if (gfc_match_char ('(') != MATCH_YES)
4639     goto syntax;
4640
4641   c = gfc_get_case ();
4642   c->where = gfc_current_locus;
4643
4644   /* TODO: Once unlimited polymorphism is implemented, we will need to call
4645      match_type_spec here.  */
4646   if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
4647     goto cleanup;
4648
4649   if (gfc_match_char (')') != MATCH_YES)
4650     goto syntax;
4651
4652   m = match_case_eos ();
4653   if (m == MATCH_NO)
4654     goto syntax;
4655   if (m == MATCH_ERROR)
4656     goto cleanup;
4657
4658   new_st.op = EXEC_SELECT_TYPE;
4659   new_st.ext.case_list = c;
4660
4661   /* Create temporary variable.  */
4662   select_type_set_tmp (&c->ts);
4663
4664   return MATCH_YES;
4665
4666 syntax:
4667   gfc_error ("Syntax error in TYPE IS specification at %C");
4668
4669 cleanup:
4670   if (c != NULL)
4671     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
4672   return MATCH_ERROR;
4673 }
4674
4675
4676 /* Match a CLASS IS or CLASS DEFAULT statement.  */
4677
4678 match
4679 gfc_match_class_is (void)
4680 {
4681   gfc_case *c = NULL;
4682   match m;
4683
4684   if (gfc_current_state () != COMP_SELECT_TYPE)
4685     return MATCH_NO;
4686
4687   if (gfc_match ("% default") == MATCH_YES)
4688     {
4689       m = match_case_eos ();
4690       if (m == MATCH_NO)
4691         goto syntax;
4692       if (m == MATCH_ERROR)
4693         goto cleanup;
4694
4695       new_st.op = EXEC_SELECT_TYPE;
4696       c = gfc_get_case ();
4697       c->where = gfc_current_locus;
4698       c->ts.type = BT_UNKNOWN;
4699       new_st.ext.case_list = c;
4700       return MATCH_YES;
4701     }
4702
4703   m = gfc_match ("% is");
4704   if (m == MATCH_NO)
4705     goto syntax;
4706   if (m == MATCH_ERROR)
4707     goto cleanup;
4708
4709   if (gfc_match_char ('(') != MATCH_YES)
4710     goto syntax;
4711
4712   c = gfc_get_case ();
4713   c->where = gfc_current_locus;
4714
4715   if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
4716     goto cleanup;
4717
4718   if (c->ts.type == BT_DERIVED)
4719     c->ts.type = BT_CLASS;
4720
4721   if (gfc_match_char (')') != MATCH_YES)
4722     goto syntax;
4723
4724   m = match_case_eos ();
4725   if (m == MATCH_NO)
4726     goto syntax;
4727   if (m == MATCH_ERROR)
4728     goto cleanup;
4729
4730   new_st.op = EXEC_SELECT_TYPE;
4731   new_st.ext.case_list = c;
4732
4733   /* Create temporary variable.  */
4734   select_type_set_tmp (&c->ts);
4735
4736   return MATCH_YES;
4737
4738 syntax:
4739   gfc_error ("Syntax error in CLASS IS specification at %C");
4740
4741 cleanup:
4742   if (c != NULL)
4743     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
4744   return MATCH_ERROR;
4745 }
4746
4747
4748 /********************* WHERE subroutines ********************/
4749
4750 /* Match the rest of a simple WHERE statement that follows an IF statement.
4751  */
4752
4753 static match
4754 match_simple_where (void)
4755 {
4756   gfc_expr *expr;
4757   gfc_code *c;
4758   match m;
4759
4760   m = gfc_match (" ( %e )", &expr);
4761   if (m != MATCH_YES)
4762     return m;
4763
4764   m = gfc_match_assignment ();
4765   if (m == MATCH_NO)
4766     goto syntax;
4767   if (m == MATCH_ERROR)
4768     goto cleanup;
4769
4770   if (gfc_match_eos () != MATCH_YES)
4771     goto syntax;
4772
4773   c = gfc_get_code ();
4774
4775   c->op = EXEC_WHERE;
4776   c->expr1 = expr;
4777   c->next = gfc_get_code ();
4778
4779   *c->next = new_st;
4780   gfc_clear_new_st ();
4781
4782   new_st.op = EXEC_WHERE;
4783   new_st.block = c;
4784
4785   return MATCH_YES;
4786
4787 syntax:
4788   gfc_syntax_error (ST_WHERE);
4789
4790 cleanup:
4791   gfc_free_expr (expr);
4792   return MATCH_ERROR;
4793 }
4794
4795
4796 /* Match a WHERE statement.  */
4797
4798 match
4799 gfc_match_where (gfc_statement *st)
4800 {
4801   gfc_expr *expr;
4802   match m0, m;
4803   gfc_code *c;
4804
4805   m0 = gfc_match_label ();
4806   if (m0 == MATCH_ERROR)
4807     return m0;
4808
4809   m = gfc_match (" where ( %e )", &expr);
4810   if (m != MATCH_YES)
4811     return m;
4812
4813   if (gfc_match_eos () == MATCH_YES)
4814     {
4815       *st = ST_WHERE_BLOCK;
4816       new_st.op = EXEC_WHERE;
4817       new_st.expr1 = expr;
4818       return MATCH_YES;
4819     }
4820
4821   m = gfc_match_assignment ();
4822   if (m == MATCH_NO)
4823     gfc_syntax_error (ST_WHERE);
4824
4825   if (m != MATCH_YES)
4826     {
4827       gfc_free_expr (expr);
4828       return MATCH_ERROR;
4829     }
4830
4831   /* We've got a simple WHERE statement.  */
4832   *st = ST_WHERE;
4833   c = gfc_get_code ();
4834
4835   c->op = EXEC_WHERE;
4836   c->expr1 = expr;
4837   c->next = gfc_get_code ();
4838
4839   *c->next = new_st;
4840   gfc_clear_new_st ();
4841
4842   new_st.op = EXEC_WHERE;
4843   new_st.block = c;
4844
4845   return MATCH_YES;
4846 }
4847
4848
4849 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
4850    new_st if successful.  */
4851
4852 match
4853 gfc_match_elsewhere (void)
4854 {
4855   char name[GFC_MAX_SYMBOL_LEN + 1];
4856   gfc_expr *expr;
4857   match m;
4858
4859   if (gfc_current_state () != COMP_WHERE)
4860     {
4861       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
4862       return MATCH_ERROR;
4863     }
4864
4865   expr = NULL;
4866
4867   if (gfc_match_char ('(') == MATCH_YES)
4868     {
4869       m = gfc_match_expr (&expr);
4870       if (m == MATCH_NO)
4871         goto syntax;
4872       if (m == MATCH_ERROR)
4873         return MATCH_ERROR;
4874
4875       if (gfc_match_char (')') != MATCH_YES)
4876         goto syntax;
4877     }
4878
4879   if (gfc_match_eos () != MATCH_YES)
4880     {
4881       /* Only makes sense if we have a where-construct-name.  */
4882       if (!gfc_current_block ())
4883         {
4884           m = MATCH_ERROR;
4885           goto cleanup;
4886         }
4887       /* Better be a name at this point.  */
4888       m = gfc_match_name (name);
4889       if (m == MATCH_NO)
4890         goto syntax;
4891       if (m == MATCH_ERROR)
4892         goto cleanup;
4893
4894       if (gfc_match_eos () != MATCH_YES)
4895         goto syntax;
4896
4897       if (strcmp (name, gfc_current_block ()->name) != 0)
4898         {
4899           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
4900                      name, gfc_current_block ()->name);
4901           goto cleanup;
4902         }
4903     }
4904
4905   new_st.op = EXEC_WHERE;
4906   new_st.expr1 = expr;
4907   return MATCH_YES;
4908
4909 syntax:
4910   gfc_syntax_error (ST_ELSEWHERE);
4911
4912 cleanup:
4913   gfc_free_expr (expr);
4914   return MATCH_ERROR;
4915 }
4916
4917
4918 /******************** FORALL subroutines ********************/
4919
4920 /* Free a list of FORALL iterators.  */
4921
4922 void
4923 gfc_free_forall_iterator (gfc_forall_iterator *iter)
4924 {
4925   gfc_forall_iterator *next;
4926
4927   while (iter)
4928     {
4929       next = iter->next;
4930       gfc_free_expr (iter->var);
4931       gfc_free_expr (iter->start);
4932       gfc_free_expr (iter->end);
4933       gfc_free_expr (iter->stride);
4934       gfc_free (iter);
4935       iter = next;
4936     }
4937 }
4938
4939
4940 /* Match an iterator as part of a FORALL statement.  The format is:
4941
4942      <var> = <start>:<end>[:<stride>]
4943
4944    On MATCH_NO, the caller tests for the possibility that there is a
4945    scalar mask expression.  */
4946
4947 static match
4948 match_forall_iterator (gfc_forall_iterator **result)
4949 {
4950   gfc_forall_iterator *iter;
4951   locus where;
4952   match m;
4953
4954   where = gfc_current_locus;
4955   iter = XCNEW (gfc_forall_iterator);
4956
4957   m = gfc_match_expr (&iter->var);
4958   if (m != MATCH_YES)
4959     goto cleanup;
4960
4961   if (gfc_match_char ('=') != MATCH_YES
4962       || iter->var->expr_type != EXPR_VARIABLE)
4963     {
4964       m = MATCH_NO;
4965       goto cleanup;
4966     }
4967
4968   m = gfc_match_expr (&iter->start);
4969   if (m != MATCH_YES)
4970     goto cleanup;
4971
4972   if (gfc_match_char (':') != MATCH_YES)
4973     goto syntax;
4974
4975   m = gfc_match_expr (&iter->end);
4976   if (m == MATCH_NO)
4977     goto syntax;
4978   if (m == MATCH_ERROR)
4979     goto cleanup;
4980
4981   if (gfc_match_char (':') == MATCH_NO)
4982     iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4983   else
4984     {
4985       m = gfc_match_expr (&iter->stride);
4986       if (m == MATCH_NO)
4987         goto syntax;
4988       if (m == MATCH_ERROR)
4989         goto cleanup;
4990     }
4991
4992   /* Mark the iteration variable's symbol as used as a FORALL index.  */
4993   iter->var->symtree->n.sym->forall_index = true;
4994
4995   *result = iter;
4996   return MATCH_YES;
4997
4998 syntax:
4999   gfc_error ("Syntax error in FORALL iterator at %C");
5000   m = MATCH_ERROR;
5001
5002 cleanup:
5003
5004   gfc_current_locus = where;
5005   gfc_free_forall_iterator (iter);
5006   return m;
5007 }
5008
5009
5010 /* Match the header of a FORALL statement.  */
5011
5012 static match
5013 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
5014 {
5015   gfc_forall_iterator *head, *tail, *new_iter;
5016   gfc_expr *msk;
5017   match m;
5018
5019   gfc_gobble_whitespace ();
5020
5021   head = tail = NULL;
5022   msk = NULL;
5023
5024   if (gfc_match_char ('(') != MATCH_YES)
5025     return MATCH_NO;
5026
5027   m = match_forall_iterator (&new_iter);
5028   if (m == MATCH_ERROR)
5029     goto cleanup;
5030   if (m == MATCH_NO)
5031     goto syntax;
5032
5033   head = tail = new_iter;
5034
5035   for (;;)
5036     {
5037       if (gfc_match_char (',') != MATCH_YES)
5038         break;
5039
5040       m = match_forall_iterator (&new_iter);
5041       if (m == MATCH_ERROR)
5042         goto cleanup;
5043
5044       if (m == MATCH_YES)
5045         {
5046           tail->next = new_iter;
5047           tail = new_iter;
5048           continue;
5049         }
5050
5051       /* Have to have a mask expression.  */
5052
5053       m = gfc_match_expr (&msk);
5054       if (m == MATCH_NO)
5055         goto syntax;
5056       if (m == MATCH_ERROR)
5057         goto cleanup;
5058
5059       break;
5060     }
5061
5062   if (gfc_match_char (')') == MATCH_NO)
5063     goto syntax;
5064
5065   *phead = head;
5066   *mask = msk;
5067   return MATCH_YES;
5068
5069 syntax:
5070   gfc_syntax_error (ST_FORALL);
5071
5072 cleanup:
5073   gfc_free_expr (msk);
5074   gfc_free_forall_iterator (head);
5075
5076   return MATCH_ERROR;
5077 }
5078
5079 /* Match the rest of a simple FORALL statement that follows an
5080    IF statement.  */
5081
5082 static match
5083 match_simple_forall (void)
5084 {
5085   gfc_forall_iterator *head;
5086   gfc_expr *mask;
5087   gfc_code *c;
5088   match m;
5089
5090   mask = NULL;
5091   head = NULL;
5092   c = NULL;
5093
5094   m = match_forall_header (&head, &mask);
5095
5096   if (m == MATCH_NO)
5097     goto syntax;
5098   if (m != MATCH_YES)
5099     goto cleanup;
5100
5101   m = gfc_match_assignment ();
5102
5103   if (m == MATCH_ERROR)
5104     goto cleanup;
5105   if (m == MATCH_NO)
5106     {
5107       m = gfc_match_pointer_assignment ();
5108       if (m == MATCH_ERROR)
5109         goto cleanup;
5110       if (m == MATCH_NO)
5111         goto syntax;
5112     }
5113
5114   c = gfc_get_code ();
5115   *c = new_st;
5116   c->loc = gfc_current_locus;
5117
5118   if (gfc_match_eos () != MATCH_YES)
5119     goto syntax;
5120
5121   gfc_clear_new_st ();
5122   new_st.op = EXEC_FORALL;
5123   new_st.expr1 = mask;
5124   new_st.ext.forall_iterator = head;
5125   new_st.block = gfc_get_code ();
5126
5127   new_st.block->op = EXEC_FORALL;
5128   new_st.block->next = c;
5129
5130   return MATCH_YES;
5131
5132 syntax:
5133   gfc_syntax_error (ST_FORALL);
5134
5135 cleanup:
5136   gfc_free_forall_iterator (head);
5137   gfc_free_expr (mask);
5138
5139   return MATCH_ERROR;
5140 }
5141
5142
5143 /* Match a FORALL statement.  */
5144
5145 match
5146 gfc_match_forall (gfc_statement *st)
5147 {
5148   gfc_forall_iterator *head;
5149   gfc_expr *mask;
5150   gfc_code *c;
5151   match m0, m;
5152
5153   head = NULL;
5154   mask = NULL;
5155   c = NULL;
5156
5157   m0 = gfc_match_label ();
5158   if (m0 == MATCH_ERROR)
5159     return MATCH_ERROR;
5160
5161   m = gfc_match (" forall");
5162   if (m != MATCH_YES)
5163     return m;
5164
5165   m = match_forall_header (&head, &mask);
5166   if (m == MATCH_ERROR)
5167     goto cleanup;
5168   if (m == MATCH_NO)
5169     goto syntax;
5170
5171   if (gfc_match_eos () == MATCH_YES)
5172     {
5173       *st = ST_FORALL_BLOCK;
5174       new_st.op = EXEC_FORALL;
5175       new_st.expr1 = mask;
5176       new_st.ext.forall_iterator = head;
5177       return MATCH_YES;
5178     }
5179
5180   m = gfc_match_assignment ();
5181   if (m == MATCH_ERROR)
5182     goto cleanup;
5183   if (m == MATCH_NO)
5184     {
5185       m = gfc_match_pointer_assignment ();
5186       if (m == MATCH_ERROR)
5187         goto cleanup;
5188       if (m == MATCH_NO)
5189         goto syntax;
5190     }
5191
5192   c = gfc_get_code ();
5193   *c = new_st;
5194   c->loc = gfc_current_locus;
5195
5196   gfc_clear_new_st ();
5197   new_st.op = EXEC_FORALL;
5198   new_st.expr1 = mask;
5199   new_st.ext.forall_iterator = head;
5200   new_st.block = gfc_get_code ();
5201   new_st.block->op = EXEC_FORALL;
5202   new_st.block->next = c;
5203
5204   *st = ST_FORALL;
5205   return MATCH_YES;
5206
5207 syntax:
5208   gfc_syntax_error (ST_FORALL);
5209
5210 cleanup:
5211   gfc_free_forall_iterator (head);
5212   gfc_free_expr (mask);
5213   gfc_free_statements (c);
5214   return MATCH_NO;
5215 }