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