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