gcc/fortran/match.c

   1 /* Matching subroutines in all sizes, shapes and colors.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   3    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
  31 /* For debugging and diagnostic purposes.  Return the textual representation
  32    of the intrinsic operator OP.  */
  33 const char *
  34 gfc_op2string (gfc_intrinsic_op op)
  35 {
  36   switch (op)
  37     {
  38     case INTRINSIC_UPLUS:
  39     case INTRINSIC_PLUS:
  40       return "+";
  41
  42     case INTRINSIC_UMINUS:
  43     case INTRINSIC_MINUS:
  44       return "-";
  45
  46     case INTRINSIC_POWER:
  47       return "**";
  48     case INTRINSIC_CONCAT:
  49       return "//";
  50     case INTRINSIC_TIMES:
  51       return "*";
  52     case INTRINSIC_DIVIDE:
  53       return "/";
  54
  55     case INTRINSIC_AND:
  56       return ".and.";
  57     case INTRINSIC_OR:
  58       return ".or.";
  59     case INTRINSIC_EQV:
  60       return ".eqv.";
  61     case INTRINSIC_NEQV:
  62       return ".neqv.";
  63
  64     case INTRINSIC_EQ_OS:
  65       return ".eq.";
  66     case INTRINSIC_EQ:
  67       return "==";
  68     case INTRINSIC_NE_OS:
  69       return ".ne.";
  70     case INTRINSIC_NE:
  71       return "/=";
  72     case INTRINSIC_GE_OS:
  73       return ".ge.";
  74     case INTRINSIC_GE:
  75       return ">=";
  76     case INTRINSIC_LE_OS:
  77       return ".le.";
  78     case INTRINSIC_LE:
  79       return "<=";
  80     case INTRINSIC_LT_OS:
  81       return ".lt.";
  82     case INTRINSIC_LT:
  83       return "<";
  84     case INTRINSIC_GT_OS:
  85       return ".gt.";
  86     case INTRINSIC_GT:
  87       return ">";
  88     case INTRINSIC_NOT:
  89       return ".not.";
  90
  91     case INTRINSIC_ASSIGN:
  92       return "=";
  93
  94     case INTRINSIC_PARENTHESES:
  95       return "parens";
  96
  97     default:
  98       break;
  99     }
 100
 101   gfc_internal_error ("gfc_op2string(): Bad code");
 102   /* Not reached.  */
 103 }
 104
 105
 106 /******************** Generic matching subroutines ************************/
 107
 108 /* This function scans the current statement counting the opened and closed
 109    parenthesis to make sure they are balanced.  */
 110
 111 match
 112 gfc_match_parens (void)
 113 {
 114   locus old_loc, where;
 115   int count, instring;
 116   gfc_char_t c, quote;
 117
 118   old_loc = gfc_current_locus;
 119   count = 0;
 120   instring = 0;
 121   quote = ' ';
 122
 123   for (;;)
 124     {
 125       c = gfc_next_char_literal (instring);
 126       if (c == '\n')
 127         break;
 128       if (quote == ' ' && ((c == '\'') || (c == '"')))
 129         {
 130           quote = c;
 131           instring = 1;
 132           continue;
 133         }
 134       if (quote != ' ' && c == quote)
 135         {
 136           quote = ' ';
 137           instring = 0;
 138           continue;
 139         }
 140
 141       if (c == '(' && quote == ' ')
 142         {
 143           count++;
 144           where = gfc_current_locus;
 145         }
 146       if (c == ')' && quote == ' ')
 147         {
 148           count--;
 149           where = gfc_current_locus;
 150         }
 151     }
 152
 153   gfc_current_locus = old_loc;
 154
 155   if (count > 0)
 156     {
 157       gfc_error ("Missing ')' in statement at or before %L", &where);
 158       return MATCH_ERROR;
 159     }
 160   if (count < 0)
 161     {
 162       gfc_error ("Missing '(' in statement at or before %L", &where);
 163       return MATCH_ERROR;
 164     }
 165
 166   return MATCH_YES;
 167 }
 168
 169
 170 /* See if the next character is a special character that has
 171    escaped by a \ via the -fbackslash option.  */
 172
 173 match
 174 gfc_match_special_char (gfc_char_t *res)
 175 {
 176   int len, i;
 177   gfc_char_t c, n;
 178   match m;
 179
 180   m = MATCH_YES;
 181
 182   switch ((c = gfc_next_char_literal (1)))
 183     {
 184     case 'a':
 185       *res = '\a';
 186       break;
 187     case 'b':
 188       *res = '\b';
 189       break;
 190     case 't':
 191       *res = '\t';
 192       break;
 193     case 'f':
 194       *res = '\f';
 195       break;
 196     case 'n':
 197       *res = '\n';
 198       break;
 199     case 'r':
 200       *res = '\r';
 201       break;
 202     case 'v':
 203       *res = '\v';
 204       break;
 205     case '\\':
 206       *res = '\\';
 207       break;
 208     case '0':
 209       *res = '\0';
 210       break;
 211
 212     case 'x':
 213     case 'u':
 214     case 'U':
 215       /* Hexadecimal form of wide characters.  */
 216       len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
 217       n = 0;
 218       for (i = 0; i < len; i++)
 219         {
 220           char buf[2] = { '\0', '\0' };
 221
 222           c = gfc_next_char_literal (1);
 223           if (!gfc_wide_fits_in_byte (c)
 224               || !gfc_check_digit ((unsigned char) c, 16))
 225             return MATCH_NO;
 226
 227           buf[0] = (unsigned char) c;
 228           n = n << 4;
 229           n += strtol (buf, NULL, 16);
 230         }
 231       *res = n;
 232       break;
 233
 234     default:
 235       /* Unknown backslash codes are simply not expanded.  */
 236       m = MATCH_NO;
 237       break;
 238     }
 239
 240   return m;
 241 }
 242
 243
 244 /* In free form, match at least one space.  Always matches in fixed
 245    form.  */
 246
 247 match
 248 gfc_match_space (void)
 249 {
 250   locus old_loc;
 251   char c;
 252
 253   if (gfc_current_form == FORM_FIXED)
 254     return MATCH_YES;
 255
 256   old_loc = gfc_current_locus;
 257
 258   c = gfc_next_ascii_char ();
 259   if (!gfc_is_whitespace (c))
 260     {
 261       gfc_current_locus = old_loc;
 262       return MATCH_NO;
 263     }
 264
 265   gfc_gobble_whitespace ();
 266
 267   return MATCH_YES;
 268 }
 269
 270
 271 /* Match an end of statement.  End of statement is optional
 272    whitespace, followed by a ';' or '\n' or comment '!'.  If a
 273    semicolon is found, we continue to eat whitespace and semicolons.  */
 274
 275 match
 276 gfc_match_eos (void)
 277 {
 278   locus old_loc;
 279   int flag;
 280   char c;
 281
 282   flag = 0;
 283
 284   for (;;)
 285     {
 286       old_loc = gfc_current_locus;
 287       gfc_gobble_whitespace ();
 288
 289       c = gfc_next_ascii_char ();
 290       switch (c)
 291         {
 292         case '!':
 293           do
 294             {
 295               c = gfc_next_ascii_char ();
 296             }
 297           while (c != '\n');
 298
 299           /* Fall through.  */
 300
 301         case '\n':
 302           return MATCH_YES;
 303
 304         case ';':
 305           flag = 1;
 306           continue;
 307         }
 308
 309       break;
 310     }
 311
 312   gfc_current_locus = old_loc;
 313   return (flag) ? MATCH_YES : MATCH_NO;
 314 }
 315
 316
 317 /* Match a literal integer on the input, setting the value on
 318    MATCH_YES.  Literal ints occur in kind-parameters as well as
 319    old-style character length specifications.  If cnt is non-NULL it
 320    will be set to the number of digits.  */
 321
 322 match
 323 gfc_match_small_literal_int (int *value, int *cnt)
 324 {
 325   locus old_loc;
 326   char c;
 327   int i, j;
 328
 329   old_loc = gfc_current_locus;
 330
 331   *value = -1;
 332   gfc_gobble_whitespace ();
 333   c = gfc_next_ascii_char ();
 334   if (cnt)
 335     *cnt = 0;
 336
 337   if (!ISDIGIT (c))
 338     {
 339       gfc_current_locus = old_loc;
 340       return MATCH_NO;
 341     }
 342
 343   i = c - '0';
 344   j = 1;
 345
 346   for (;;)
 347     {
 348       old_loc = gfc_current_locus;
 349       c = gfc_next_ascii_char ();
 350
 351       if (!ISDIGIT (c))
 352         break;
 353
 354       i = 10 * i + c - '0';
 355       j++;
 356
 357       if (i > 99999999)
 358         {
 359           gfc_error ("Integer too large at %C");
 360           return MATCH_ERROR;
 361         }
 362     }
 363
 364   gfc_current_locus = old_loc;
 365
 366   *value = i;
 367   if (cnt)
 368     *cnt = j;
 369   return MATCH_YES;
 370 }
 371
 372
 373 /* Match a small, constant integer expression, like in a kind
 374    statement.  On MATCH_YES, 'value' is set.  */
 375
 376 match
 377 gfc_match_small_int (int *value)
 378 {
 379   gfc_expr *expr;
 380   const char *p;
 381   match m;
 382   int i;
 383
 384   m = gfc_match_expr (&expr);
 385   if (m != MATCH_YES)
 386     return m;
 387
 388   p = gfc_extract_int (expr, &i);
 389   gfc_free_expr (expr);
 390
 391   if (p != NULL)
 392     {
 393       gfc_error (p);
 394       m = MATCH_ERROR;
 395     }
 396
 397   *value = i;
 398   return m;
 399 }
 400
 401
 402 /* This function is the same as the gfc_match_small_int, except that
 403    we're keeping the pointer to the expr.  This function could just be
 404    removed and the previously mentioned one modified, though all calls
 405    to it would have to be modified then (and there were a number of
 406    them).  Return MATCH_ERROR if fail to extract the int; otherwise,
 407    return the result of gfc_match_expr().  The expr (if any) that was
 408    matched is returned in the parameter expr.  */
 409
 410 match
 411 gfc_match_small_int_expr (int *value, gfc_expr **expr)
 412 {
 413   const char *p;
 414   match m;
 415   int i;
 416
 417   m = gfc_match_expr (expr);
 418   if (m != MATCH_YES)
 419     return m;
 420
 421   p = gfc_extract_int (*expr, &i);
 422
 423   if (p != NULL)
 424     {
 425       gfc_error (p);
 426       m = MATCH_ERROR;
 427     }
 428
 429   *value = i;
 430   return m;
 431 }
 432
 433
 434 /* Matches a statement label.  Uses gfc_match_small_literal_int() to
 435    do most of the work.  */
 436
 437 match
 438 gfc_match_st_label (gfc_st_label **label)
 439 {
 440   locus old_loc;
 441   match m;
 442   int i, cnt;
 443
 444   old_loc = gfc_current_locus;
 445
 446   m = gfc_match_small_literal_int (&i, &cnt);
 447   if (m != MATCH_YES)
 448     return m;
 449
 450   if (cnt > 5)
 451     {
 452       gfc_error ("Too many digits in statement label at %C");
 453       goto cleanup;
 454     }
 455
 456   if (i == 0)
 457     {
 458       gfc_error ("Statement label at %C is zero");
 459       goto cleanup;
 460     }
 461
 462   *label = gfc_get_st_label (i);
 463   return MATCH_YES;
 464
 465 cleanup:
 466
 467   gfc_current_locus = old_loc;
 468   return MATCH_ERROR;
 469 }
 470
 471
 472 /* Match and validate a label associated with a named IF, DO or SELECT
 473    statement.  If the symbol does not have the label attribute, we add
 474    it.  We also make sure the symbol does not refer to another
 475    (active) block.  A matched label is pointed to by gfc_new_block.  */
 476
 477 match
 478 gfc_match_label (void)
 479 {
 480   char name[GFC_MAX_SYMBOL_LEN + 1];
 481   match m;
 482
 483   gfc_new_block = NULL;
 484
 485   m = gfc_match (" %n :", name);
 486   if (m != MATCH_YES)
 487     return m;
 488
 489   if (gfc_get_symbol (name, NULL, &gfc_new_block))
 490     {
 491       gfc_error ("Label name '%s' at %C is ambiguous", name);
 492       return MATCH_ERROR;
 493     }
 494
 495   if (gfc_new_block->attr.flavor == FL_LABEL)
 496     {
 497       gfc_error ("Duplicate construct label '%s' at %C", name);
 498       return MATCH_ERROR;
 499     }
 500
 501   if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
 502                       gfc_new_block->name, NULL) == FAILURE)
 503     return MATCH_ERROR;
 504
 505   return MATCH_YES;
 506 }
 507
 508
 509 /* See if the current input looks like a name of some sort.  Modifies
 510    the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
 511    Note that options.c restricts max_identifier_length to not more
 512    than GFC_MAX_SYMBOL_LEN.  */
 513
 514 match
 515 gfc_match_name (char *buffer)
 516 {
 517   locus old_loc;
 518   int i;
 519   char c;
 520
 521   old_loc = gfc_current_locus;
 522   gfc_gobble_whitespace ();
 523
 524   c = gfc_next_ascii_char ();
 525   if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
 526     {
 527       if (gfc_error_flag_test() == 0 && c != '(')
 528         gfc_error ("Invalid character in name at %C");
 529       gfc_current_locus = old_loc;
 530       return MATCH_NO;
 531     }
 532
 533   i = 0;
 534
 535   do
 536     {
 537       buffer[i++] = c;
 538
 539       if (i > gfc_option.max_identifier_length)
 540         {
 541           gfc_error ("Name at %C is too long");
 542           return MATCH_ERROR;
 543         }
 544
 545       old_loc = gfc_current_locus;
 546       c = gfc_next_ascii_char ();
 547     }
 548   while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
 549
 550   if (c == '$' && !gfc_option.flag_dollar_ok)
 551     {
 552       gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it "
 553                  "as an extension");
 554       return MATCH_ERROR;
 555     }
 556
 557   buffer[i] = '\0';
 558   gfc_current_locus = old_loc;
 559
 560   return MATCH_YES;
 561 }
 562
 563
 564 /* Match a valid name for C, which is almost the same as for Fortran,
 565    except that you can start with an underscore, etc..  It could have
 566    been done by modifying the gfc_match_name, but this way other
 567    things C allows can be added, such as no limits on the length.
 568    Right now, the length is limited to the same thing as Fortran..
 569    Also, by rewriting it, we use the gfc_next_char_C() to prevent the
 570    input characters from being automatically lower cased, since C is
 571    case sensitive.  The parameter, buffer, is used to return the name
 572    that is matched.  Return MATCH_ERROR if the name is too long
 573    (though this is a self-imposed limit), MATCH_NO if what we're
 574    seeing isn't a name, and MATCH_YES if we successfully match a C
 575    name.  */
 576
 577 match
 578 gfc_match_name_C (char *buffer)
 579 {
 580   locus old_loc;
 581   int i = 0;
 582   gfc_char_t c;
 583
 584   old_loc = gfc_current_locus;
 585   gfc_gobble_whitespace ();
 586
 587   /* Get the next char (first possible char of name) and see if
 588      it's valid for C (either a letter or an underscore).  */
 589   c = gfc_next_char_literal (1);
 590
 591   /* If the user put nothing expect spaces between the quotes, it is valid
 592      and simply means there is no name= specifier and the name is the fortran
 593      symbol name, all lowercase.  */
 594   if (c == '"' || c == '\'')
 595     {
 596       buffer[0] = '\0';
 597       gfc_current_locus = old_loc;
 598       return MATCH_YES;
 599     }
 600
 601   if (!ISALPHA (c) && c != '_')
 602     {
 603       gfc_error ("Invalid C name in NAME= specifier at %C");
 604       return MATCH_ERROR;
 605     }
 606
 607   /* Continue to read valid variable name characters.  */
 608   do
 609     {
 610       gcc_assert (gfc_wide_fits_in_byte (c));
 611
 612       buffer[i++] = (unsigned char) c;
 613
 614     /* C does not define a maximum length of variable names, to my
 615        knowledge, but the compiler typically places a limit on them.
 616        For now, i'll use the same as the fortran limit for simplicity,
 617        but this may need to be changed to a dynamic buffer that can
 618        be realloc'ed here if necessary, or more likely, a larger
 619        upper-bound set.  */
 620       if (i > gfc_option.max_identifier_length)
 621         {
 622           gfc_error ("Name at %C is too long");
 623           return MATCH_ERROR;
 624         }
 625
 626       old_loc = gfc_current_locus;
 627
 628       /* Get next char; param means we're in a string.  */
 629       c = gfc_next_char_literal (1);
 630     } while (ISALNUM (c) || c == '_');
 631
 632   buffer[i] = '\0';
 633   gfc_current_locus = old_loc;
 634
 635   /* See if we stopped because of whitespace.  */
 636   if (c == ' ')
 637     {
 638       gfc_gobble_whitespace ();
 639       c = gfc_peek_ascii_char ();
 640       if (c != '"' && c != '\'')
 641         {
 642           gfc_error ("Embedded space in NAME= specifier at %C");
 643           return MATCH_ERROR;
 644         }
 645     }
 646
 647   /* If we stopped because we had an invalid character for a C name, report
 648      that to the user by returning MATCH_NO.  */
 649   if (c != '"' && c != '\'')
 650     {
 651       gfc_error ("Invalid C name in NAME= specifier at %C");
 652       return MATCH_ERROR;
 653     }
 654
 655   return MATCH_YES;
 656 }
 657
 658
 659 /* Match a symbol on the input.  Modifies the pointer to the symbol
 660    pointer if successful.  */
 661
 662 match
 663 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
 664 {
 665   char buffer[GFC_MAX_SYMBOL_LEN + 1];
 666   match m;
 667
 668   m = gfc_match_name (buffer);
 669   if (m != MATCH_YES)
 670     return m;
 671
 672   if (host_assoc)
 673     return (gfc_get_ha_sym_tree (buffer, matched_symbol))
 674             ? MATCH_ERROR : MATCH_YES;
 675
 676   if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
 677     return MATCH_ERROR;
 678
 679   return MATCH_YES;
 680 }
 681
 682
 683 match
 684 gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
 685 {
 686   gfc_symtree *st;
 687   match m;
 688
 689   m = gfc_match_sym_tree (&st, host_assoc);
 690
 691   if (m == MATCH_YES)
 692     {
 693       if (st)
 694         *matched_symbol = st->n.sym;
 695       else
 696         *matched_symbol = NULL;
 697     }
 698   else
 699     *matched_symbol = NULL;
 700   return m;
 701 }
 702
 703
 704 /* Match an intrinsic operator.  Returns an INTRINSIC enum. While matching,
 705    we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
 706    in matchexp.c.  */
 707
 708 match
 709 gfc_match_intrinsic_op (gfc_intrinsic_op *result)
 710 {
 711   locus orig_loc = gfc_current_locus;
 712   char ch;
 713
 714   gfc_gobble_whitespace ();
 715   ch = gfc_next_ascii_char ();
 716   switch (ch)
 717     {
 718     case '+':
 719       /* Matched "+".  */
 720       *result = INTRINSIC_PLUS;
 721       return MATCH_YES;
 722
 723     case '-':
 724       /* Matched "-".  */
 725       *result = INTRINSIC_MINUS;
 726       return MATCH_YES;
 727
 728     case '=':
 729       if (gfc_next_ascii_char () == '=')
 730         {
 731           /* Matched "==".  */
 732           *result = INTRINSIC_EQ;
 733           return MATCH_YES;
 734         }
 735       break;
 736
 737     case '<':
 738       if (gfc_peek_ascii_char () == '=')
 739         {
 740           /* Matched "<=".  */
 741           gfc_next_ascii_char ();
 742           *result = INTRINSIC_LE;
 743           return MATCH_YES;
 744         }
 745       /* Matched "<".  */
 746       *result = INTRINSIC_LT;
 747       return MATCH_YES;
 748
 749     case '>':
 750       if (gfc_peek_ascii_char () == '=')
 751         {
 752           /* Matched ">=".  */
 753           gfc_next_ascii_char ();
 754           *result = INTRINSIC_GE;
 755           return MATCH_YES;
 756         }
 757       /* Matched ">".  */
 758       *result = INTRINSIC_GT;
 759       return MATCH_YES;
 760
 761     case '*':
 762       if (gfc_peek_ascii_char () == '*')
 763         {
 764           /* Matched "**".  */
 765           gfc_next_ascii_char ();
 766           *result = INTRINSIC_POWER;
 767           return MATCH_YES;
 768         }
 769       /* Matched "*".  */
 770       *result = INTRINSIC_TIMES;
 771       return MATCH_YES;
 772
 773     case '/':
 774       ch = gfc_peek_ascii_char ();
 775       if (ch == '=')
 776         {
 777           /* Matched "/=".  */
 778           gfc_next_ascii_char ();
 779           *result = INTRINSIC_NE;
 780           return MATCH_YES;
 781         }
 782       else if (ch == '/')
 783         {
 784           /* Matched "//".  */
 785           gfc_next_ascii_char ();
 786           *result = INTRINSIC_CONCAT;
 787           return MATCH_YES;
 788         }
 789       /* Matched "/".  */
 790       *result = INTRINSIC_DIVIDE;
 791       return MATCH_YES;
 792
 793     case '.':
 794       ch = gfc_next_ascii_char ();
 795       switch (ch)
 796         {
 797         case 'a':
 798           if (gfc_next_ascii_char () == 'n'
 799               && gfc_next_ascii_char () == 'd'
 800               && gfc_next_ascii_char () == '.')
 801             {
 802               /* Matched ".and.".  */
 803               *result = INTRINSIC_AND;
 804               return MATCH_YES;
 805             }
 806           break;
 807
 808         case 'e':
 809           if (gfc_next_ascii_char () == 'q')
 810             {
 811               ch = gfc_next_ascii_char ();
 812               if (ch == '.')
 813                 {
 814                   /* Matched ".eq.".  */
 815                   *result = INTRINSIC_EQ_OS;
 816                   return MATCH_YES;
 817                 }
 818               else if (ch == 'v')
 819                 {
 820                   if (gfc_next_ascii_char () == '.')
 821                     {
 822                       /* Matched ".eqv.".  */
 823                       *result = INTRINSIC_EQV;
 824                       return MATCH_YES;
 825                     }
 826                 }
 827             }
 828           break;
 829
 830         case 'g':
 831           ch = gfc_next_ascii_char ();
 832           if (ch == 'e')
 833             {
 834               if (gfc_next_ascii_char () == '.')
 835                 {
 836                   /* Matched ".ge.".  */
 837                   *result = INTRINSIC_GE_OS;
 838                   return MATCH_YES;
 839                 }
 840             }
 841           else if (ch == 't')
 842             {
 843               if (gfc_next_ascii_char () == '.')
 844                 {
 845                   /* Matched ".gt.".  */
 846                   *result = INTRINSIC_GT_OS;
 847                   return MATCH_YES;
 848                 }
 849             }
 850           break;
 851
 852         case 'l':
 853           ch = gfc_next_ascii_char ();
 854           if (ch == 'e')
 855             {
 856               if (gfc_next_ascii_char () == '.')
 857                 {
 858                   /* Matched ".le.".  */
 859                   *result = INTRINSIC_LE_OS;
 860                   return MATCH_YES;
 861                 }
 862             }
 863           else if (ch == 't')
 864             {
 865               if (gfc_next_ascii_char () == '.')
 866                 {
 867                   /* Matched ".lt.".  */
 868                   *result = INTRINSIC_LT_OS;
 869                   return MATCH_YES;
 870                 }
 871             }
 872           break;
 873
 874         case 'n':
 875           ch = gfc_next_ascii_char ();
 876           if (ch == 'e')
 877             {
 878               ch = gfc_next_ascii_char ();
 879               if (ch == '.')
 880                 {
 881                   /* Matched ".ne.".  */
 882                   *result = INTRINSIC_NE_OS;
 883                   return MATCH_YES;
 884                 }
 885               else if (ch == 'q')
 886                 {
 887                   if (gfc_next_ascii_char () == 'v'
 888                       && gfc_next_ascii_char () == '.')
 889                     {
 890                       /* Matched ".neqv.".  */
 891                       *result = INTRINSIC_NEQV;
 892                       return MATCH_YES;
 893                     }
 894                 }
 895             }
 896           else if (ch == 'o')
 897             {
 898               if (gfc_next_ascii_char () == 't'
 899                   && gfc_next_ascii_char () == '.')
 900                 {
 901                   /* Matched ".not.".  */
 902                   *result = INTRINSIC_NOT;
 903                   return MATCH_YES;
 904                 }
 905             }
 906           break;
 907
 908         case 'o':
 909           if (gfc_next_ascii_char () == 'r'
 910               && gfc_next_ascii_char () == '.')
 911             {
 912               /* Matched ".or.".  */
 913               *result = INTRINSIC_OR;
 914               return MATCH_YES;
 915             }
 916           break;
 917
 918         default:
 919           break;
 920         }
 921       break;
 922
 923     default:
 924       break;
 925     }
 926
 927   gfc_current_locus = orig_loc;
 928   return MATCH_NO;
 929 }
 930
 931
 932 /* Match a loop control phrase:
 933
 934     <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
 935
 936    If the final integer expression is not present, a constant unity
 937    expression is returned.  We don't return MATCH_ERROR until after
 938    the equals sign is seen.  */
 939
 940 match
 941 gfc_match_iterator (gfc_iterator *iter, int init_flag)
 942 {
 943   char name[GFC_MAX_SYMBOL_LEN + 1];
 944   gfc_expr *var, *e1, *e2, *e3;
 945   locus start;
 946   match m;
 947
 948   /* Match the start of an iterator without affecting the symbol table.  */
 949
 950   start = gfc_current_locus;
 951   m = gfc_match (" %n =", name);
 952   gfc_current_locus = start;
 953
 954   if (m != MATCH_YES)
 955     return MATCH_NO;
 956
 957   m = gfc_match_variable (&var, 0);
 958   if (m != MATCH_YES)
 959     return MATCH_NO;
 960
 961   gfc_match_char ('=');
 962
 963   e1 = e2 = e3 = NULL;
 964
 965   if (var->ref != NULL)
 966     {
 967       gfc_error ("Loop variable at %C cannot be a sub-component");
 968       goto cleanup;
 969     }
 970
 971   if (var->symtree->n.sym->attr.intent == INTENT_IN)
 972     {
 973       gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
 974                  var->symtree->n.sym->name);
 975       goto cleanup;
 976     }
 977
 978   var->symtree->n.sym->attr.implied_index = 1;
 979
 980   m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
 981   if (m == MATCH_NO)
 982     goto syntax;
 983   if (m == MATCH_ERROR)
 984     goto cleanup;
 985
 986   if (gfc_match_char (',') != MATCH_YES)
 987     goto syntax;
 988
 989   m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
 990   if (m == MATCH_NO)
 991     goto syntax;
 992   if (m == MATCH_ERROR)
 993     goto cleanup;
 994
 995   if (gfc_match_char (',') != MATCH_YES)
 996     {
 997       e3 = gfc_int_expr (1);
 998       goto done;
 999     }
1000
1001   m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
1002   if (m == MATCH_ERROR)
1003     goto cleanup;
1004   if (m == MATCH_NO)
1005     {
1006       gfc_error ("Expected a step value in iterator at %C");
1007       goto cleanup;
1008     }
1009
1010 done:
1011   iter->var = var;
1012   iter->start = e1;
1013   iter->end = e2;
1014   iter->step = e3;
1015   return MATCH_YES;
1016
1017 syntax:
1018   gfc_error ("Syntax error in iterator at %C");
1019
1020 cleanup:
1021   gfc_free_expr (e1);
1022   gfc_free_expr (e2);
1023   gfc_free_expr (e3);
1024
1025   return MATCH_ERROR;
1026 }
1027
1028
1029 /* Tries to match the next non-whitespace character on the input.
1030    This subroutine does not return MATCH_ERROR.  */
1031
1032 match
1033 gfc_match_char (char c)
1034 {
1035   locus where;
1036
1037   where = gfc_current_locus;
1038   gfc_gobble_whitespace ();
1039
1040   if (gfc_next_ascii_char () == c)
1041     return MATCH_YES;
1042
1043   gfc_current_locus = where;
1044   return MATCH_NO;
1045 }
1046
1047
1048 /* General purpose matching subroutine.  The target string is a
1049    scanf-like format string in which spaces correspond to arbitrary
1050    whitespace (including no whitespace), characters correspond to
1051    themselves.  The %-codes are:
1052
1053    %%  Literal percent sign
1054    %e  Expression, pointer to a pointer is set
1055    %s  Symbol, pointer to the symbol is set
1056    %n  Name, character buffer is set to name
1057    %t  Matches end of statement.
1058    %o  Matches an intrinsic operator, returned as an INTRINSIC enum.
1059    %l  Matches a statement label
1060    %v  Matches a variable expression (an lvalue)
1061    %   Matches a required space (in free form) and optional spaces.  */
1062
1063 match
1064 gfc_match (const char *target, ...)
1065 {
1066   gfc_st_label **label;
1067   int matches, *ip;
1068   locus old_loc;
1069   va_list argp;
1070   char c, *np;
1071   match m, n;
1072   void **vp;
1073   const char *p;
1074
1075   old_loc = gfc_current_locus;
1076   va_start (argp, target);
1077   m = MATCH_NO;
1078   matches = 0;
1079   p = target;
1080
1081 loop:
1082   c = *p++;
1083   switch (c)
1084     {
1085     case ' ':
1086       gfc_gobble_whitespace ();
1087       goto loop;
1088     case '\0':
1089       m = MATCH_YES;
1090       break;
1091
1092     case '%':
1093       c = *p++;
1094       switch (c)
1095         {
1096         case 'e':
1097           vp = va_arg (argp, void **);
1098           n = gfc_match_expr ((gfc_expr **) vp);
1099           if (n != MATCH_YES)
1100             {
1101               m = n;
1102               goto not_yes;
1103             }
1104
1105           matches++;
1106           goto loop;
1107
1108         case 'v':
1109           vp = va_arg (argp, void **);
1110           n = gfc_match_variable ((gfc_expr **) vp, 0);
1111           if (n != MATCH_YES)
1112             {
1113               m = n;
1114               goto not_yes;
1115             }
1116
1117           matches++;
1118           goto loop;
1119
1120         case 's':
1121           vp = va_arg (argp, void **);
1122           n = gfc_match_symbol ((gfc_symbol **) vp, 0);
1123           if (n != MATCH_YES)
1124             {
1125               m = n;
1126               goto not_yes;
1127             }
1128
1129           matches++;
1130           goto loop;
1131
1132         case 'n':
1133           np = va_arg (argp, char *);
1134           n = gfc_match_name (np);
1135           if (n != MATCH_YES)
1136             {
1137               m = n;
1138               goto not_yes;
1139             }
1140
1141           matches++;
1142           goto loop;
1143
1144         case 'l':
1145           label = va_arg (argp, gfc_st_label **);
1146           n = gfc_match_st_label (label);
1147           if (n != MATCH_YES)
1148             {
1149               m = n;
1150               goto not_yes;
1151             }
1152
1153           matches++;
1154           goto loop;
1155
1156         case 'o':
1157           ip = va_arg (argp, int *);
1158           n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
1159           if (n != MATCH_YES)
1160             {
1161               m = n;
1162               goto not_yes;
1163             }
1164
1165           matches++;
1166           goto loop;
1167
1168         case 't':
1169           if (gfc_match_eos () != MATCH_YES)
1170             {
1171               m = MATCH_NO;
1172               goto not_yes;
1173             }
1174           goto loop;
1175
1176         case ' ':
1177           if (gfc_match_space () == MATCH_YES)
1178             goto loop;
1179           m = MATCH_NO;
1180           goto not_yes;
1181
1182         case '%':
1183           break;        /* Fall through to character matcher.  */
1184
1185         default:
1186           gfc_internal_error ("gfc_match(): Bad match code %c", c);
1187         }
1188
1189     default:
1190       if (c == gfc_next_ascii_char ())
1191         goto loop;
1192       break;
1193     }
1194
1195 not_yes:
1196   va_end (argp);
1197
1198   if (m != MATCH_YES)
1199     {
1200       /* Clean up after a failed match.  */
1201       gfc_current_locus = old_loc;
1202       va_start (argp, target);
1203
1204       p = target;
1205       for (; matches > 0; matches--)
1206         {
1207           while (*p++ != '%');
1208
1209           switch (*p++)
1210             {
1211             case '%':
1212               matches++;
1213               break;            /* Skip.  */
1214
1215             /* Matches that don't have to be undone */
1216             case 'o':
1217             case 'l':
1218             case 'n':
1219             case 's':
1220               (void) va_arg (argp, void **);
1221               break;
1222
1223             case 'e':
1224             case 'v':
1225               vp = va_arg (argp, void **);
1226               gfc_free_expr ((struct gfc_expr *)*vp);
1227               *vp = NULL;
1228               break;
1229             }
1230         }
1231
1232       va_end (argp);
1233     }
1234
1235   return m;
1236 }
1237
1238
1239 /*********************** Statement level matching **********************/
1240
1241 /* Matches the start of a program unit, which is the program keyword
1242    followed by an obligatory symbol.  */
1243
1244 match
1245 gfc_match_program (void)
1246 {
1247   gfc_symbol *sym;
1248   match m;
1249
1250   m = gfc_match ("% %s%t", &sym);
1251
1252   if (m == MATCH_NO)
1253     {
1254       gfc_error ("Invalid form of PROGRAM statement at %C");
1255       m = MATCH_ERROR;
1256     }
1257
1258   if (m == MATCH_ERROR)
1259     return m;
1260
1261   if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
1262     return MATCH_ERROR;
1263
1264   gfc_new_block = sym;
1265
1266   return MATCH_YES;
1267 }
1268
1269
1270 /* Match a simple assignment statement.  */
1271
1272 match
1273 gfc_match_assignment (void)
1274 {
1275   gfc_expr *lvalue, *rvalue;
1276   locus old_loc;
1277   match m;
1278
1279   old_loc = gfc_current_locus;
1280
1281   lvalue = NULL;
1282   m = gfc_match (" %v =", &lvalue);
1283   if (m != MATCH_YES)
1284     {
1285       gfc_current_locus = old_loc;
1286       gfc_free_expr (lvalue);
1287       return MATCH_NO;
1288     }
1289
1290   if (lvalue->symtree->n.sym->attr.protected
1291       && lvalue->symtree->n.sym->attr.use_assoc)
1292     {
1293       gfc_current_locus = old_loc;
1294       gfc_free_expr (lvalue);
1295       gfc_error ("Setting value of PROTECTED variable at %C");
1296       return MATCH_ERROR;
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.expr = 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_matching_procptr_assignment = 1;
1344
1345   m = gfc_match (" %e%t", &rvalue);
1346   gfc_matching_procptr_assignment = 0;
1347   if (m != MATCH_YES)
1348     goto cleanup;
1349
1350   if (lvalue->symtree->n.sym->attr.protected
1351       && lvalue->symtree->n.sym->attr.use_assoc)
1352     {
1353       gfc_error ("Assigning to a PROTECTED pointer at %C");
1354       m = MATCH_ERROR;
1355       goto cleanup;
1356     }
1357
1358   new_st.op = EXEC_POINTER_ASSIGN;
1359   new_st.expr = lvalue;
1360   new_st.expr2 = rvalue;
1361
1362   return MATCH_YES;
1363
1364 cleanup:
1365   gfc_current_locus = old_loc;
1366   gfc_free_expr (lvalue);
1367   gfc_free_expr (rvalue);
1368   return m;
1369 }
1370
1371
1372 /* We try to match an easy arithmetic IF statement. This only happens
1373    when just after having encountered a simple IF statement. This code
1374    is really duplicate with parts of the gfc_match_if code, but this is
1375    *much* easier.  */
1376
1377 static match
1378 match_arithmetic_if (void)
1379 {
1380   gfc_st_label *l1, *l2, *l3;
1381   gfc_expr *expr;
1382   match m;
1383
1384   m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
1385   if (m != MATCH_YES)
1386     return m;
1387
1388   if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1389       || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1390       || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1391     {
1392       gfc_free_expr (expr);
1393       return MATCH_ERROR;
1394     }
1395
1396   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF statement "
1397                       "at %C") == FAILURE)
1398     return MATCH_ERROR;
1399
1400   new_st.op = EXEC_ARITHMETIC_IF;
1401   new_st.expr = expr;
1402   new_st.label = l1;
1403   new_st.label2 = l2;
1404   new_st.label3 = l3;
1405
1406   return MATCH_YES;
1407 }
1408
1409
1410 /* The IF statement is a bit of a pain.  First of all, there are three
1411    forms of it, the simple IF, the IF that starts a block and the
1412    arithmetic IF.
1413
1414    There is a problem with the simple IF and that is the fact that we
1415    only have a single level of undo information on symbols.  What this
1416    means is for a simple IF, we must re-match the whole IF statement
1417    multiple times in order to guarantee that the symbol table ends up
1418    in the proper state.  */
1419
1420 static match match_simple_forall (void);
1421 static match match_simple_where (void);
1422
1423 match
1424 gfc_match_if (gfc_statement *if_type)
1425 {
1426   gfc_expr *expr;
1427   gfc_st_label *l1, *l2, *l3;
1428   locus old_loc, old_loc2;
1429   gfc_code *p;
1430   match m, n;
1431
1432   n = gfc_match_label ();
1433   if (n == MATCH_ERROR)
1434     return n;
1435
1436   old_loc = gfc_current_locus;
1437
1438   m = gfc_match (" if ( %e", &expr);
1439   if (m != MATCH_YES)
1440     return m;
1441
1442   old_loc2 = gfc_current_locus;
1443   gfc_current_locus = old_loc;
1444
1445   if (gfc_match_parens () == MATCH_ERROR)
1446     return MATCH_ERROR;
1447
1448   gfc_current_locus = old_loc2;
1449
1450   if (gfc_match_char (')') != MATCH_YES)
1451     {
1452       gfc_error ("Syntax error in IF-expression at %C");
1453       gfc_free_expr (expr);
1454       return MATCH_ERROR;
1455     }
1456
1457   m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1458
1459   if (m == MATCH_YES)
1460     {
1461       if (n == MATCH_YES)
1462         {
1463           gfc_error ("Block label not appropriate for arithmetic IF "
1464                      "statement at %C");
1465           gfc_free_expr (expr);
1466           return MATCH_ERROR;
1467         }
1468
1469       if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1470           || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1471           || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1472         {
1473           gfc_free_expr (expr);
1474           return MATCH_ERROR;
1475         }
1476
1477       if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF "
1478                           "statement at %C") == FAILURE)
1479         return MATCH_ERROR;
1480
1481       new_st.op = EXEC_ARITHMETIC_IF;
1482       new_st.expr = expr;
1483       new_st.label = l1;
1484       new_st.label2 = l2;
1485       new_st.label3 = l3;
1486
1487       *if_type = ST_ARITHMETIC_IF;
1488       return MATCH_YES;
1489     }
1490
1491   if (gfc_match (" then%t") == MATCH_YES)
1492     {
1493       new_st.op = EXEC_IF;
1494       new_st.expr = expr;
1495       *if_type = ST_IF_BLOCK;
1496       return MATCH_YES;
1497     }
1498
1499   if (n == MATCH_YES)
1500     {
1501       gfc_error ("Block label is not appropriate for IF statement at %C");
1502       gfc_free_expr (expr);
1503       return MATCH_ERROR;
1504     }
1505
1506   /* At this point the only thing left is a simple IF statement.  At
1507      this point, n has to be MATCH_NO, so we don't have to worry about
1508      re-matching a block label.  From what we've got so far, try
1509      matching an assignment.  */
1510
1511   *if_type = ST_SIMPLE_IF;
1512
1513   m = gfc_match_assignment ();
1514   if (m == MATCH_YES)
1515     goto got_match;
1516
1517   gfc_free_expr (expr);
1518   gfc_undo_symbols ();
1519   gfc_current_locus = old_loc;
1520
1521   /* m can be MATCH_NO or MATCH_ERROR, here.  For MATCH_ERROR, a mangled
1522      assignment was found.  For MATCH_NO, continue to call the various
1523      matchers.  */
1524   if (m == MATCH_ERROR)
1525     return MATCH_ERROR;
1526
1527   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */
1528
1529   m = gfc_match_pointer_assignment ();
1530   if (m == MATCH_YES)
1531     goto got_match;
1532
1533   gfc_free_expr (expr);
1534   gfc_undo_symbols ();
1535   gfc_current_locus = old_loc;
1536
1537   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */
1538
1539   /* Look at the next keyword to see which matcher to call.  Matching
1540      the keyword doesn't affect the symbol table, so we don't have to
1541      restore between tries.  */
1542
1543 #define match(string, subr, statement) \
1544   if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1545
1546   gfc_clear_error ();
1547
1548   match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1549   match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1550   match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1551   match ("call", gfc_match_call, ST_CALL)
1552   match ("close", gfc_match_close, ST_CLOSE)
1553   match ("continue", gfc_match_continue, ST_CONTINUE)
1554   match ("cycle", gfc_match_cycle, ST_CYCLE)
1555   match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1556   match ("end file", gfc_match_endfile, ST_END_FILE)
1557   match ("exit", gfc_match_exit, ST_EXIT)
1558   match ("flush", gfc_match_flush, ST_FLUSH)
1559   match ("forall", match_simple_forall, ST_FORALL)
1560   match ("go to", gfc_match_goto, ST_GOTO)
1561   match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1562   match ("inquire", gfc_match_inquire, ST_INQUIRE)
1563   match ("nullify", gfc_match_nullify, ST_NULLIFY)
1564   match ("open", gfc_match_open, ST_OPEN)
1565   match ("pause", gfc_match_pause, ST_NONE)
1566   match ("print", gfc_match_print, ST_WRITE)
1567   match ("read", gfc_match_read, ST_READ)
1568   match ("return", gfc_match_return, ST_RETURN)
1569   match ("rewind", gfc_match_rewind, ST_REWIND)
1570   match ("stop", gfc_match_stop, ST_STOP)
1571   match ("wait", gfc_match_wait, ST_WAIT)
1572   match ("where", match_simple_where, ST_WHERE)
1573   match ("write", gfc_match_write, ST_WRITE)
1574
1575   /* The gfc_match_assignment() above may have returned a MATCH_NO
1576      where the assignment was to a named constant.  Check that
1577      special case here.  */
1578   m = gfc_match_assignment ();
1579   if (m == MATCH_NO)
1580    {
1581       gfc_error ("Cannot assign to a named constant at %C");
1582       gfc_free_expr (expr);
1583       gfc_undo_symbols ();
1584       gfc_current_locus = old_loc;
1585       return MATCH_ERROR;
1586    }
1587
1588   /* All else has failed, so give up.  See if any of the matchers has
1589      stored an error message of some sort.  */
1590   if (gfc_error_check () == 0)
1591     gfc_error ("Unclassifiable statement in IF-clause at %C");
1592
1593   gfc_free_expr (expr);
1594   return MATCH_ERROR;
1595
1596 got_match:
1597   if (m == MATCH_NO)
1598     gfc_error ("Syntax error in IF-clause at %C");
1599   if (m != MATCH_YES)
1600     {
1601       gfc_free_expr (expr);
1602       return MATCH_ERROR;
1603     }
1604
1605   /* At this point, we've matched the single IF and the action clause
1606      is in new_st.  Rearrange things so that the IF statement appears
1607      in new_st.  */
1608
1609   p = gfc_get_code ();
1610   p->next = gfc_get_code ();
1611   *p->next = new_st;
1612   p->next->loc = gfc_current_locus;
1613
1614   p->expr = expr;
1615   p->op = EXEC_IF;
1616
1617   gfc_clear_new_st ();
1618
1619   new_st.op = EXEC_IF;
1620   new_st.block = p;
1621
1622   return MATCH_YES;
1623 }
1624
1625 #undef match
1626
1627
1628 /* Match an ELSE statement.  */
1629
1630 match
1631 gfc_match_else (void)
1632 {
1633   char name[GFC_MAX_SYMBOL_LEN + 1];
1634
1635   if (gfc_match_eos () == MATCH_YES)
1636     return MATCH_YES;
1637
1638   if (gfc_match_name (name) != MATCH_YES
1639       || gfc_current_block () == NULL
1640       || gfc_match_eos () != MATCH_YES)
1641     {
1642       gfc_error ("Unexpected junk after ELSE statement at %C");
1643       return MATCH_ERROR;
1644     }
1645
1646   if (strcmp (name, gfc_current_block ()->name) != 0)
1647     {
1648       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1649                  name, gfc_current_block ()->name);
1650       return MATCH_ERROR;
1651     }
1652
1653   return MATCH_YES;
1654 }
1655
1656
1657 /* Match an ELSE IF statement.  */
1658
1659 match
1660 gfc_match_elseif (void)
1661 {
1662   char name[GFC_MAX_SYMBOL_LEN + 1];
1663   gfc_expr *expr;
1664   match m;
1665
1666   m = gfc_match (" ( %e ) then", &expr);
1667   if (m != MATCH_YES)
1668     return m;
1669
1670   if (gfc_match_eos () == MATCH_YES)
1671     goto done;
1672
1673   if (gfc_match_name (name) != MATCH_YES
1674       || gfc_current_block () == NULL
1675       || gfc_match_eos () != MATCH_YES)
1676     {
1677       gfc_error ("Unexpected junk after ELSE IF statement at %C");
1678       goto cleanup;
1679     }
1680
1681   if (strcmp (name, gfc_current_block ()->name) != 0)
1682     {
1683       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1684                  name, gfc_current_block ()->name);
1685       goto cleanup;
1686     }
1687
1688 done:
1689   new_st.op = EXEC_IF;
1690   new_st.expr = expr;
1691   return MATCH_YES;
1692
1693 cleanup:
1694   gfc_free_expr (expr);
1695   return MATCH_ERROR;
1696 }
1697
1698
1699 /* Free a gfc_iterator structure.  */
1700
1701 void
1702 gfc_free_iterator (gfc_iterator *iter, int flag)
1703 {
1704
1705   if (iter == NULL)
1706     return;
1707
1708   gfc_free_expr (iter->var);
1709   gfc_free_expr (iter->start);
1710   gfc_free_expr (iter->end);
1711   gfc_free_expr (iter->step);
1712
1713   if (flag)
1714     gfc_free (iter);
1715 }
1716
1717
1718 /* Match a DO statement.  */
1719
1720 match
1721 gfc_match_do (void)
1722 {
1723   gfc_iterator iter, *ip;
1724   locus old_loc;
1725   gfc_st_label *label;
1726   match m;
1727
1728   old_loc = gfc_current_locus;
1729
1730   label = NULL;
1731   iter.var = iter.start = iter.end = iter.step = NULL;
1732
1733   m = gfc_match_label ();
1734   if (m == MATCH_ERROR)
1735     return m;
1736
1737   if (gfc_match (" do") != MATCH_YES)
1738     return MATCH_NO;
1739
1740   m = gfc_match_st_label (&label);
1741   if (m == MATCH_ERROR)
1742     goto cleanup;
1743
1744   /* Match an infinite DO, make it like a DO WHILE(.TRUE.).  */
1745
1746   if (gfc_match_eos () == MATCH_YES)
1747     {
1748       iter.end = gfc_logical_expr (1, NULL);
1749       new_st.op = EXEC_DO_WHILE;
1750       goto done;
1751     }
1752
1753   /* Match an optional comma, if no comma is found, a space is obligatory.  */
1754   if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
1755     return MATCH_NO;
1756
1757   /* Check for balanced parens.  */
1758
1759   if (gfc_match_parens () == MATCH_ERROR)
1760     return MATCH_ERROR;
1761
1762   /* See if we have a DO WHILE.  */
1763   if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1764     {
1765       new_st.op = EXEC_DO_WHILE;
1766       goto done;
1767     }
1768
1769   /* The abortive DO WHILE may have done something to the symbol
1770      table, so we start over.  */
1771   gfc_undo_symbols ();
1772   gfc_current_locus = old_loc;
1773
1774   gfc_match_label ();           /* This won't error.  */
1775   gfc_match (" do ");           /* This will work.  */
1776
1777   gfc_match_st_label (&label);  /* Can't error out.  */
1778   gfc_match_char (',');         /* Optional comma.  */
1779
1780   m = gfc_match_iterator (&iter, 0);
1781   if (m == MATCH_NO)
1782     return MATCH_NO;
1783   if (m == MATCH_ERROR)
1784     goto cleanup;
1785
1786   iter.var->symtree->n.sym->attr.implied_index = 0;
1787   gfc_check_do_variable (iter.var->symtree);
1788
1789   if (gfc_match_eos () != MATCH_YES)
1790     {
1791       gfc_syntax_error (ST_DO);
1792       goto cleanup;
1793     }
1794
1795   new_st.op = EXEC_DO;
1796
1797 done:
1798   if (label != NULL
1799       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1800     goto cleanup;
1801
1802   new_st.label = label;
1803
1804   if (new_st.op == EXEC_DO_WHILE)
1805     new_st.expr = iter.end;
1806   else
1807     {
1808       new_st.ext.iterator = ip = gfc_get_iterator ();
1809       *ip = iter;
1810     }
1811
1812   return MATCH_YES;
1813
1814 cleanup:
1815   gfc_free_iterator (&iter, 0);
1816
1817   return MATCH_ERROR;
1818 }
1819
1820
1821 /* Match an EXIT or CYCLE statement.  */
1822
1823 static match
1824 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1825 {
1826   gfc_state_data *p, *o;
1827   gfc_symbol *sym;
1828   match m;
1829
1830   if (gfc_match_eos () == MATCH_YES)
1831     sym = NULL;
1832   else
1833     {
1834       m = gfc_match ("% %s%t", &sym);
1835       if (m == MATCH_ERROR)
1836         return MATCH_ERROR;
1837       if (m == MATCH_NO)
1838         {
1839           gfc_syntax_error (st);
1840           return MATCH_ERROR;
1841         }
1842
1843       if (sym->attr.flavor != FL_LABEL)
1844         {
1845           gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1846                      sym->name, gfc_ascii_statement (st));
1847           return MATCH_ERROR;
1848         }
1849     }
1850
1851   /* Find the loop mentioned specified by the label (or lack of a label).  */
1852   for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1853     if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1854       break;
1855     else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1856       o = p;
1857
1858   if (p == NULL)
1859     {
1860       if (sym == NULL)
1861         gfc_error ("%s statement at %C is not within a loop",
1862                    gfc_ascii_statement (st));
1863       else
1864         gfc_error ("%s statement at %C is not within loop '%s'",
1865                    gfc_ascii_statement (st), sym->name);
1866
1867       return MATCH_ERROR;
1868     }
1869
1870   if (o != NULL)
1871     {
1872       gfc_error ("%s statement at %C leaving OpenMP structured block",
1873                  gfc_ascii_statement (st));
1874       return MATCH_ERROR;
1875     }
1876   else if (st == ST_EXIT
1877            && p->previous != NULL
1878            && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1879            && (p->previous->head->op == EXEC_OMP_DO
1880                || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1881     {
1882       gcc_assert (p->previous->head->next != NULL);
1883       gcc_assert (p->previous->head->next->op == EXEC_DO
1884                   || p->previous->head->next->op == EXEC_DO_WHILE);
1885       gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1886       return MATCH_ERROR;
1887     }
1888
1889   /* Save the first statement in the loop - needed by the backend.  */
1890   new_st.ext.whichloop = p->head;
1891
1892   new_st.op = op;
1893
1894   return MATCH_YES;
1895 }
1896
1897
1898 /* Match the EXIT statement.  */
1899
1900 match
1901 gfc_match_exit (void)
1902 {
1903   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1904 }
1905
1906
1907 /* Match the CYCLE statement.  */
1908
1909 match
1910 gfc_match_cycle (void)
1911 {
1912   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1913 }
1914
1915
1916 /* Match a number or character constant after a STOP or PAUSE statement.  */
1917
1918 static match
1919 gfc_match_stopcode (gfc_statement st)
1920 {
1921   int stop_code;
1922   gfc_expr *e;
1923   match m;
1924   int cnt;
1925
1926   stop_code = -1;
1927   e = NULL;
1928
1929   if (gfc_match_eos () != MATCH_YES)
1930     {
1931       m = gfc_match_small_literal_int (&stop_code, &cnt);
1932       if (m == MATCH_ERROR)
1933         goto cleanup;
1934
1935       if (m == MATCH_YES && cnt > 5)
1936         {
1937           gfc_error ("Too many digits in STOP code at %C");
1938           goto cleanup;
1939         }
1940
1941       if (m == MATCH_NO)
1942         {
1943           /* Try a character constant.  */
1944           m = gfc_match_expr (&e);
1945           if (m == MATCH_ERROR)
1946             goto cleanup;
1947           if (m == MATCH_NO)
1948             goto syntax;
1949           if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1950             goto syntax;
1951         }
1952
1953       if (gfc_match_eos () != MATCH_YES)
1954         goto syntax;
1955     }
1956
1957   if (gfc_pure (NULL))
1958     {
1959       gfc_error ("%s statement not allowed in PURE procedure at %C",
1960                  gfc_ascii_statement (st));
1961       goto cleanup;
1962     }
1963
1964   new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1965   new_st.expr = e;
1966   new_st.ext.stop_code = stop_code;
1967
1968   return MATCH_YES;
1969
1970 syntax:
1971   gfc_syntax_error (st);
1972
1973 cleanup:
1974
1975   gfc_free_expr (e);
1976   return MATCH_ERROR;
1977 }
1978
1979
1980 /* Match the (deprecated) PAUSE statement.  */
1981
1982 match
1983 gfc_match_pause (void)
1984 {
1985   match m;
1986
1987   m = gfc_match_stopcode (ST_PAUSE);
1988   if (m == MATCH_YES)
1989     {
1990       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
1991           " at %C")
1992           == FAILURE)
1993         m = MATCH_ERROR;
1994     }
1995   return m;
1996 }
1997
1998
1999 /* Match the STOP statement.  */
2000
2001 match
2002 gfc_match_stop (void)
2003 {
2004   return gfc_match_stopcode (ST_STOP);
2005 }
2006
2007
2008 /* Match a CONTINUE statement.  */
2009
2010 match
2011 gfc_match_continue (void)
2012 {
2013   if (gfc_match_eos () != MATCH_YES)
2014     {
2015       gfc_syntax_error (ST_CONTINUE);
2016       return MATCH_ERROR;
2017     }
2018
2019   new_st.op = EXEC_CONTINUE;
2020   return MATCH_YES;
2021 }
2022
2023
2024 /* Match the (deprecated) ASSIGN statement.  */
2025
2026 match
2027 gfc_match_assign (void)
2028 {
2029   gfc_expr *expr;
2030   gfc_st_label *label;
2031
2032   if (gfc_match (" %l", &label) == MATCH_YES)
2033     {
2034       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
2035         return MATCH_ERROR;
2036       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
2037         {
2038           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
2039                               "statement at %C")
2040               == FAILURE)
2041             return MATCH_ERROR;
2042
2043           expr->symtree->n.sym->attr.assign = 1;
2044
2045           new_st.op = EXEC_LABEL_ASSIGN;
2046           new_st.label = label;
2047           new_st.expr = expr;
2048           return MATCH_YES;
2049         }
2050     }
2051   return MATCH_NO;
2052 }
2053
2054
2055 /* Match the GO TO statement.  As a computed GOTO statement is
2056    matched, it is transformed into an equivalent SELECT block.  No
2057    tree is necessary, and the resulting jumps-to-jumps are
2058    specifically optimized away by the back end.  */
2059
2060 match
2061 gfc_match_goto (void)
2062 {
2063   gfc_code *head, *tail;
2064   gfc_expr *expr;
2065   gfc_case *cp;
2066   gfc_st_label *label;
2067   int i;
2068   match m;
2069
2070   if (gfc_match (" %l%t", &label) == MATCH_YES)
2071     {
2072       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2073         return MATCH_ERROR;
2074
2075       new_st.op = EXEC_GOTO;
2076       new_st.label = label;
2077       return MATCH_YES;
2078     }
2079
2080   /* The assigned GO TO statement.  */
2081
2082   if (gfc_match_variable (&expr, 0) == MATCH_YES)
2083     {
2084       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
2085                           "statement at %C")
2086           == FAILURE)
2087         return MATCH_ERROR;
2088
2089       new_st.op = EXEC_GOTO;
2090       new_st.expr = expr;
2091
2092       if (gfc_match_eos () == MATCH_YES)
2093         return MATCH_YES;
2094
2095       /* Match label list.  */
2096       gfc_match_char (',');
2097       if (gfc_match_char ('(') != MATCH_YES)
2098         {
2099           gfc_syntax_error (ST_GOTO);
2100           return MATCH_ERROR;
2101         }
2102       head = tail = NULL;
2103
2104       do
2105         {
2106           m = gfc_match_st_label (&label);
2107           if (m != MATCH_YES)
2108             goto syntax;
2109
2110           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2111             goto cleanup;
2112
2113           if (head == NULL)
2114             head = tail = gfc_get_code ();
2115           else
2116             {
2117               tail->block = gfc_get_code ();
2118               tail = tail->block;
2119             }
2120
2121           tail->label = label;
2122           tail->op = EXEC_GOTO;
2123         }
2124       while (gfc_match_char (',') == MATCH_YES);
2125
2126       if (gfc_match (")%t") != MATCH_YES)
2127         goto syntax;
2128
2129       if (head == NULL)
2130         {
2131            gfc_error ("Statement label list in GOTO at %C cannot be empty");
2132            goto syntax;
2133         }
2134       new_st.block = head;
2135
2136       return MATCH_YES;
2137     }
2138
2139   /* Last chance is a computed GO TO statement.  */
2140   if (gfc_match_char ('(') != MATCH_YES)
2141     {
2142       gfc_syntax_error (ST_GOTO);
2143       return MATCH_ERROR;
2144     }
2145
2146   head = tail = NULL;
2147   i = 1;
2148
2149   do
2150     {
2151       m = gfc_match_st_label (&label);
2152       if (m != MATCH_YES)
2153         goto syntax;
2154
2155       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2156         goto cleanup;
2157
2158       if (head == NULL)
2159         head = tail = gfc_get_code ();
2160       else
2161         {
2162           tail->block = gfc_get_code ();
2163           tail = tail->block;
2164         }
2165
2166       cp = gfc_get_case ();
2167       cp->low = cp->high = gfc_int_expr (i++);
2168
2169       tail->op = EXEC_SELECT;
2170       tail->ext.case_list = cp;
2171
2172       tail->next = gfc_get_code ();
2173       tail->next->op = EXEC_GOTO;
2174       tail->next->label = label;
2175     }
2176   while (gfc_match_char (',') == MATCH_YES);
2177
2178   if (gfc_match_char (')') != MATCH_YES)
2179     goto syntax;
2180
2181   if (head == NULL)
2182     {
2183       gfc_error ("Statement label list in GOTO at %C cannot be empty");
2184       goto syntax;
2185     }
2186
2187   /* Get the rest of the statement.  */
2188   gfc_match_char (',');
2189
2190   if (gfc_match (" %e%t", &expr) != MATCH_YES)
2191     goto syntax;
2192
2193   /* At this point, a computed GOTO has been fully matched and an
2194      equivalent SELECT statement constructed.  */
2195
2196   new_st.op = EXEC_SELECT;
2197   new_st.expr = NULL;
2198
2199   /* Hack: For a "real" SELECT, the expression is in expr. We put
2200      it in expr2 so we can distinguish then and produce the correct
2201      diagnostics.  */
2202   new_st.expr2 = expr;
2203   new_st.block = head;
2204   return MATCH_YES;
2205
2206 syntax:
2207   gfc_syntax_error (ST_GOTO);
2208 cleanup:
2209   gfc_free_statements (head);
2210   return MATCH_ERROR;
2211 }
2212
2213
2214 /* Frees a list of gfc_alloc structures.  */
2215
2216 void
2217 gfc_free_alloc_list (gfc_alloc *p)
2218 {
2219   gfc_alloc *q;
2220
2221   for (; p; p = q)
2222     {
2223       q = p->next;
2224       gfc_free_expr (p->expr);
2225       gfc_free (p);
2226     }
2227 }
2228
2229
2230 /* Match an ALLOCATE statement.  */
2231
2232 match
2233 gfc_match_allocate (void)
2234 {
2235   gfc_alloc *head, *tail;
2236   gfc_expr *stat;
2237   match m;
2238
2239   head = tail = NULL;
2240   stat = NULL;
2241
2242   if (gfc_match_char ('(') != MATCH_YES)
2243     goto syntax;
2244
2245   for (;;)
2246     {
2247       if (head == NULL)
2248         head = tail = gfc_get_alloc ();
2249       else
2250         {
2251           tail->next = gfc_get_alloc ();
2252           tail = tail->next;
2253         }
2254
2255       m = gfc_match_variable (&tail->expr, 0);
2256       if (m == MATCH_NO)
2257         goto syntax;
2258       if (m == MATCH_ERROR)
2259         goto cleanup;
2260
2261       if (gfc_check_do_variable (tail->expr->symtree))
2262         goto cleanup;
2263
2264       if (gfc_pure (NULL)
2265           && gfc_impure_variable (tail->expr->symtree->n.sym))
2266         {
2267           gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
2268                      "PURE procedure");
2269           goto cleanup;
2270         }
2271
2272       if (tail->expr->ts.type == BT_DERIVED)
2273         tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
2274
2275       if (gfc_match_char (',') != MATCH_YES)
2276         break;
2277
2278       m = gfc_match (" stat = %v", &stat);
2279       if (m == MATCH_ERROR)
2280         goto cleanup;
2281       if (m == MATCH_YES)
2282         break;
2283     }
2284
2285   if (stat != NULL)
2286     gfc_check_do_variable(stat->symtree);
2287
2288   if (gfc_match (" )%t") != MATCH_YES)
2289     goto syntax;
2290
2291   new_st.op = EXEC_ALLOCATE;
2292   new_st.expr = stat;
2293   new_st.ext.alloc_list = head;
2294
2295   return MATCH_YES;
2296
2297 syntax:
2298   gfc_syntax_error (ST_ALLOCATE);
2299
2300 cleanup:
2301   gfc_free_expr (stat);
2302   gfc_free_alloc_list (head);
2303   return MATCH_ERROR;
2304 }
2305
2306
2307 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2308    a set of pointer assignments to intrinsic NULL().  */
2309
2310 match
2311 gfc_match_nullify (void)
2312 {
2313   gfc_code *tail;
2314   gfc_expr *e, *p;
2315   match m;
2316
2317   tail = NULL;
2318
2319   if (gfc_match_char ('(') != MATCH_YES)
2320     goto syntax;
2321
2322   for (;;)
2323     {
2324       m = gfc_match_variable (&p, 0);
2325       if (m == MATCH_ERROR)
2326         goto cleanup;
2327       if (m == MATCH_NO)
2328         goto syntax;
2329
2330       if (gfc_check_do_variable (p->symtree))
2331         goto cleanup;
2332
2333       if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
2334         {
2335           gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2336           goto cleanup;
2337         }
2338
2339       /* build ' => NULL() '.  */
2340       e = gfc_get_expr ();
2341       e->where = gfc_current_locus;
2342       e->expr_type = EXPR_NULL;
2343       e->ts.type = BT_UNKNOWN;
2344
2345       /* Chain to list.  */
2346       if (tail == NULL)
2347         tail = &new_st;
2348       else
2349         {
2350           tail->next = gfc_get_code ();
2351           tail = tail->next;
2352         }
2353
2354       tail->op = EXEC_POINTER_ASSIGN;
2355       tail->expr = p;
2356       tail->expr2 = e;
2357
2358       if (gfc_match (" )%t") == MATCH_YES)
2359         break;
2360       if (gfc_match_char (',') != MATCH_YES)
2361         goto syntax;
2362     }
2363
2364   return MATCH_YES;
2365
2366 syntax:
2367   gfc_syntax_error (ST_NULLIFY);
2368
2369 cleanup:
2370   gfc_free_statements (new_st.next);
2371   return MATCH_ERROR;
2372 }
2373
2374
2375 /* Match a DEALLOCATE statement.  */
2376
2377 match
2378 gfc_match_deallocate (void)
2379 {
2380   gfc_alloc *head, *tail;
2381   gfc_expr *stat;
2382   match m;
2383
2384   head = tail = NULL;
2385   stat = NULL;
2386
2387   if (gfc_match_char ('(') != MATCH_YES)
2388     goto syntax;
2389
2390   for (;;)
2391     {
2392       if (head == NULL)
2393         head = tail = gfc_get_alloc ();
2394       else
2395         {
2396           tail->next = gfc_get_alloc ();
2397           tail = tail->next;
2398         }
2399
2400       m = gfc_match_variable (&tail->expr, 0);
2401       if (m == MATCH_ERROR)
2402         goto cleanup;
2403       if (m == MATCH_NO)
2404         goto syntax;
2405
2406       if (gfc_check_do_variable (tail->expr->symtree))
2407         goto cleanup;
2408
2409       if (gfc_pure (NULL)
2410           && gfc_impure_variable (tail->expr->symtree->n.sym))
2411         {
2412           gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
2413                      "for a PURE procedure");
2414           goto cleanup;
2415         }
2416
2417       if (gfc_match_char (',') != MATCH_YES)
2418         break;
2419
2420       m = gfc_match (" stat = %v", &stat);
2421       if (m == MATCH_ERROR)
2422         goto cleanup;
2423       if (m == MATCH_YES)
2424         break;
2425     }
2426
2427   if (stat != NULL)
2428     gfc_check_do_variable(stat->symtree);
2429
2430   if (gfc_match (" )%t") != MATCH_YES)
2431     goto syntax;
2432
2433   new_st.op = EXEC_DEALLOCATE;
2434   new_st.expr = stat;
2435   new_st.ext.alloc_list = head;
2436
2437   return MATCH_YES;
2438
2439 syntax:
2440   gfc_syntax_error (ST_DEALLOCATE);
2441
2442 cleanup:
2443   gfc_free_expr (stat);
2444   gfc_free_alloc_list (head);
2445   return MATCH_ERROR;
2446 }
2447
2448
2449 /* Match a RETURN statement.  */
2450
2451 match
2452 gfc_match_return (void)
2453 {
2454   gfc_expr *e;
2455   match m;
2456   gfc_compile_state s;
2457
2458   e = NULL;
2459   if (gfc_match_eos () == MATCH_YES)
2460     goto done;
2461
2462   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2463     {
2464       gfc_error ("Alternate RETURN statement at %C is only allowed within "
2465                  "a SUBROUTINE");
2466       goto cleanup;
2467     }
2468
2469   if (gfc_current_form == FORM_FREE)
2470     {
2471       /* The following are valid, so we can't require a blank after the
2472         RETURN keyword:
2473           return+1
2474           return(1)  */
2475       char c = gfc_peek_ascii_char ();
2476       if (ISALPHA (c) || ISDIGIT (c))
2477         return MATCH_NO;
2478     }
2479
2480   m = gfc_match (" %e%t", &e);
2481   if (m == MATCH_YES)
2482     goto done;
2483   if (m == MATCH_ERROR)
2484     goto cleanup;
2485
2486   gfc_syntax_error (ST_RETURN);
2487
2488 cleanup:
2489   gfc_free_expr (e);
2490   return MATCH_ERROR;
2491
2492 done:
2493   gfc_enclosing_unit (&s);
2494   if (s == COMP_PROGRAM
2495       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2496                         "main program at %C") == FAILURE)
2497       return MATCH_ERROR;
2498
2499   new_st.op = EXEC_RETURN;
2500   new_st.expr = e;
2501
2502   return MATCH_YES;
2503 }
2504
2505
2506 /* Match a CALL statement.  The tricky part here are possible
2507    alternate return specifiers.  We handle these by having all
2508    "subroutines" actually return an integer via a register that gives
2509    the return number.  If the call specifies alternate returns, we
2510    generate code for a SELECT statement whose case clauses contain
2511    GOTOs to the various labels.  */
2512
2513 match
2514 gfc_match_call (void)
2515 {
2516   char name[GFC_MAX_SYMBOL_LEN + 1];
2517   gfc_actual_arglist *a, *arglist;
2518   gfc_case *new_case;
2519   gfc_symbol *sym;
2520   gfc_symtree *st;
2521   gfc_code *c;
2522   match m;
2523   int i;
2524
2525   arglist = NULL;
2526
2527   m = gfc_match ("% %n", name);
2528   if (m == MATCH_NO)
2529     goto syntax;
2530   if (m != MATCH_YES)
2531     return m;
2532
2533   if (gfc_get_ha_sym_tree (name, &st))
2534     return MATCH_ERROR;
2535
2536   sym = st->n.sym;
2537
2538   /* If it does not seem to be callable...  */
2539   if (!sym->attr.generic
2540         && !sym->attr.subroutine)
2541     {
2542       if (!(sym->attr.external && !sym->attr.referenced))
2543         {
2544           /* ...create a symbol in this scope...  */
2545           if (sym->ns != gfc_current_ns
2546                 && gfc_get_sym_tree (name, NULL, &st) == 1)
2547             return MATCH_ERROR;
2548
2549           if (sym != st->n.sym)
2550             sym = st->n.sym;
2551         }
2552
2553       /* ...and then to try to make the symbol into a subroutine.  */
2554       if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2555         return MATCH_ERROR;
2556     }
2557
2558   gfc_set_sym_referenced (sym);
2559
2560   if (gfc_match_eos () != MATCH_YES)
2561     {
2562       m = gfc_match_actual_arglist (1, &arglist);
2563       if (m == MATCH_NO)
2564         goto syntax;
2565       if (m == MATCH_ERROR)
2566         goto cleanup;
2567
2568       if (gfc_match_eos () != MATCH_YES)
2569         goto syntax;
2570     }
2571
2572   /* If any alternate return labels were found, construct a SELECT
2573      statement that will jump to the right place.  */
2574
2575   i = 0;
2576   for (a = arglist; a; a = a->next)
2577     if (a->expr == NULL)
2578       i = 1;
2579
2580   if (i)
2581     {
2582       gfc_symtree *select_st;
2583       gfc_symbol *select_sym;
2584       char name[GFC_MAX_SYMBOL_LEN + 1];
2585
2586       new_st.next = c = gfc_get_code ();
2587       c->op = EXEC_SELECT;
2588       sprintf (name, "_result_%s", sym->name);
2589       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
2590
2591       select_sym = select_st->n.sym;
2592       select_sym->ts.type = BT_INTEGER;
2593       select_sym->ts.kind = gfc_default_integer_kind;
2594       gfc_set_sym_referenced (select_sym);
2595       c->expr = gfc_get_expr ();
2596       c->expr->expr_type = EXPR_VARIABLE;
2597       c->expr->symtree = select_st;
2598       c->expr->ts = select_sym->ts;
2599       c->expr->where = gfc_current_locus;
2600
2601       i = 0;
2602       for (a = arglist; a; a = a->next)
2603         {
2604           if (a->expr != NULL)
2605             continue;
2606
2607           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2608             continue;
2609
2610           i++;
2611
2612           c->block = gfc_get_code ();
2613           c = c->block;
2614           c->op = EXEC_SELECT;
2615
2616           new_case = gfc_get_case ();
2617           new_case->high = new_case->low = gfc_int_expr (i);
2618           c->ext.case_list = new_case;
2619
2620           c->next = gfc_get_code ();
2621           c->next->op = EXEC_GOTO;
2622           c->next->label = a->label;
2623         }
2624     }
2625
2626   new_st.op = EXEC_CALL;
2627   new_st.symtree = st;
2628   new_st.ext.actual = arglist;
2629
2630   return MATCH_YES;
2631
2632 syntax:
2633   gfc_syntax_error (ST_CALL);
2634
2635 cleanup:
2636   gfc_free_actual_arglist (arglist);
2637   return MATCH_ERROR;
2638 }
2639
2640
2641 /* Given a name, return a pointer to the common head structure,
2642    creating it if it does not exist. If FROM_MODULE is nonzero, we
2643    mangle the name so that it doesn't interfere with commons defined
2644    in the using namespace.
2645    TODO: Add to global symbol tree.  */
2646
2647 gfc_common_head *
2648 gfc_get_common (const char *name, int from_module)
2649 {
2650   gfc_symtree *st;
2651   static int serial = 0;
2652   char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
2653
2654   if (from_module)
2655     {
2656       /* A use associated common block is only needed to correctly layout
2657          the variables it contains.  */
2658       snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2659       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2660     }
2661   else
2662     {
2663       st = gfc_find_symtree (gfc_current_ns->common_root, name);
2664
2665       if (st == NULL)
2666         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2667     }
2668
2669   if (st->n.common == NULL)
2670     {
2671       st->n.common = gfc_get_common_head ();
2672       st->n.common->where = gfc_current_locus;
2673       strcpy (st->n.common->name, name);
2674     }
2675
2676   return st->n.common;
2677 }
2678
2679
2680 /* Match a common block name.  */
2681
2682 match match_common_name (char *name)
2683 {
2684   match m;
2685
2686   if (gfc_match_char ('/') == MATCH_NO)
2687     {
2688       name[0] = '\0';
2689       return MATCH_YES;
2690     }
2691
2692   if (gfc_match_char ('/') == MATCH_YES)
2693     {
2694       name[0] = '\0';
2695       return MATCH_YES;
2696     }
2697
2698   m = gfc_match_name (name);
2699
2700   if (m == MATCH_ERROR)
2701     return MATCH_ERROR;
2702   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2703     return MATCH_YES;
2704
2705   gfc_error ("Syntax error in common block name at %C");
2706   return MATCH_ERROR;
2707 }
2708
2709
2710 /* Match a COMMON statement.  */
2711
2712 match
2713 gfc_match_common (void)
2714 {
2715   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2716   char name[GFC_MAX_SYMBOL_LEN + 1];
2717   gfc_common_head *t;
2718   gfc_array_spec *as;
2719   gfc_equiv *e1, *e2;
2720   match m;
2721   gfc_gsymbol *gsym;
2722
2723   old_blank_common = gfc_current_ns->blank_common.head;
2724   if (old_blank_common)
2725     {
2726       while (old_blank_common->common_next)
2727         old_blank_common = old_blank_common->common_next;
2728     }
2729
2730   as = NULL;
2731
2732   for (;;)
2733     {
2734       m = match_common_name (name);
2735       if (m == MATCH_ERROR)
2736         goto cleanup;
2737
2738       gsym = gfc_get_gsymbol (name);
2739       if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
2740         {
2741           gfc_error ("Symbol '%s' at %C is already an external symbol that "
2742                      "is not COMMON", name);
2743           goto cleanup;
2744         }
2745
2746       if (gsym->type == GSYM_UNKNOWN)
2747         {
2748           gsym->type = GSYM_COMMON;
2749           gsym->where = gfc_current_locus;
2750           gsym->defined = 1;
2751         }
2752
2753       gsym->used = 1;
2754
2755       if (name[0] == '\0')
2756         {
2757           t = &gfc_current_ns->blank_common;
2758           if (t->head == NULL)
2759             t->where = gfc_current_locus;
2760         }
2761       else
2762         {
2763           t = gfc_get_common (name, 0);
2764         }
2765       head = &t->head;
2766
2767       if (*head == NULL)
2768         tail = NULL;
2769       else
2770         {
2771           tail = *head;
2772           while (tail->common_next)
2773             tail = tail->common_next;
2774         }
2775
2776       /* Grab the list of symbols.  */
2777       for (;;)
2778         {
2779           m = gfc_match_symbol (&sym, 0);
2780           if (m == MATCH_ERROR)
2781             goto cleanup;
2782           if (m == MATCH_NO)
2783             goto syntax;
2784
2785           /* Store a ref to the common block for error checking.  */
2786           sym->common_block = t;
2787
2788           /* See if we know the current common block is bind(c), and if
2789              so, then see if we can check if the symbol is (which it'll
2790              need to be).  This can happen if the bind(c) attr stmt was
2791              applied to the common block, and the variable(s) already
2792              defined, before declaring the common block.  */
2793           if (t->is_bind_c == 1)
2794             {
2795               if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
2796                 {
2797                   /* If we find an error, just print it and continue,
2798                      cause it's just semantic, and we can see if there
2799                      are more errors.  */
2800                   gfc_error_now ("Variable '%s' at %L in common block '%s' "
2801                                  "at %C must be declared with a C "
2802                                  "interoperable kind since common block "
2803                                  "'%s' is bind(c)",
2804                                  sym->name, &(sym->declared_at), t->name,
2805                                  t->name);
2806                 }
2807
2808               if (sym->attr.is_bind_c == 1)
2809                 gfc_error_now ("Variable '%s' in common block "
2810                                "'%s' at %C can not be bind(c) since "
2811                                "it is not global", sym->name, t->name);
2812             }
2813
2814           if (sym->attr.in_common)
2815             {
2816               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2817                          sym->name);
2818               goto cleanup;
2819             }
2820
2821           if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
2822                || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
2823             {
2824               if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
2825                                                "can only be COMMON in "
2826                                                "BLOCK DATA", sym->name)
2827                   == FAILURE)
2828                 goto cleanup;
2829             }
2830
2831           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2832             goto cleanup;
2833
2834           if (tail != NULL)
2835             tail->common_next = sym;
2836           else
2837             *head = sym;
2838
2839           tail = sym;
2840
2841           /* Deal with an optional array specification after the
2842              symbol name.  */
2843           m = gfc_match_array_spec (&as);
2844           if (m == MATCH_ERROR)
2845             goto cleanup;
2846
2847           if (m == MATCH_YES)
2848             {
2849               if (as->type != AS_EXPLICIT)
2850                 {
2851                   gfc_error ("Array specification for symbol '%s' in COMMON "
2852                              "at %C must be explicit", sym->name);
2853                   goto cleanup;
2854                 }
2855
2856               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2857                 goto cleanup;
2858
2859               if (sym->attr.pointer)
2860                 {
2861                   gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
2862                              "POINTER array", sym->name);
2863                   goto cleanup;
2864                 }
2865
2866               sym->as = as;
2867               as = NULL;
2868
2869             }
2870
2871           sym->common_head = t;
2872
2873           /* Check to see if the symbol is already in an equivalence group.
2874              If it is, set the other members as being in common.  */
2875           if (sym->attr.in_equivalence)
2876             {
2877               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2878                 {
2879                   for (e2 = e1; e2; e2 = e2->eq)
2880                     if (e2->expr->symtree->n.sym == sym)
2881                       goto equiv_found;
2882
2883                   continue;
2884
2885           equiv_found:
2886
2887                   for (e2 = e1; e2; e2 = e2->eq)
2888                     {
2889                       other = e2->expr->symtree->n.sym;
2890                       if (other->common_head
2891                           && other->common_head != sym->common_head)
2892                         {
2893                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
2894                                      "%C is being indirectly equivalenced to "
2895                                      "another COMMON block '%s'",
2896                                      sym->name, sym->common_head->name,
2897                                      other->common_head->name);
2898                             goto cleanup;
2899                         }
2900                       other->attr.in_common = 1;
2901                       other->common_head = t;
2902                     }
2903                 }
2904             }
2905
2906
2907           gfc_gobble_whitespace ();
2908           if (gfc_match_eos () == MATCH_YES)
2909             goto done;
2910           if (gfc_peek_ascii_char () == '/')
2911             break;
2912           if (gfc_match_char (',') != MATCH_YES)
2913             goto syntax;
2914           gfc_gobble_whitespace ();
2915           if (gfc_peek_ascii_char () == '/')
2916             break;
2917         }
2918     }
2919
2920 done:
2921   return MATCH_YES;
2922
2923 syntax:
2924   gfc_syntax_error (ST_COMMON);
2925
2926 cleanup:
2927   if (old_blank_common)
2928     old_blank_common->common_next = NULL;
2929   else
2930     gfc_current_ns->blank_common.head = NULL;
2931   gfc_free_array_spec (as);
2932   return MATCH_ERROR;
2933 }
2934
2935
2936 /* Match a BLOCK DATA program unit.  */
2937
2938 match
2939 gfc_match_block_data (void)
2940 {
2941   char name[GFC_MAX_SYMBOL_LEN + 1];
2942   gfc_symbol *sym;
2943   match m;
2944
2945   if (gfc_match_eos () == MATCH_YES)
2946     {
2947       gfc_new_block = NULL;
2948       return MATCH_YES;
2949     }
2950
2951   m = gfc_match ("% %n%t", name);
2952   if (m != MATCH_YES)
2953     return MATCH_ERROR;
2954
2955   if (gfc_get_symbol (name, NULL, &sym))
2956     return MATCH_ERROR;
2957
2958   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2959     return MATCH_ERROR;
2960
2961   gfc_new_block = sym;
2962
2963   return MATCH_YES;
2964 }
2965
2966
2967 /* Free a namelist structure.  */
2968
2969 void
2970 gfc_free_namelist (gfc_namelist *name)
2971 {
2972   gfc_namelist *n;
2973
2974   for (; name; name = n)
2975     {
2976       n = name->next;
2977       gfc_free (name);
2978     }
2979 }
2980
2981
2982 /* Match a NAMELIST statement.  */
2983
2984 match
2985 gfc_match_namelist (void)
2986 {
2987   gfc_symbol *group_name, *sym;
2988   gfc_namelist *nl;
2989   match m, m2;
2990
2991   m = gfc_match (" / %s /", &group_name);
2992   if (m == MATCH_NO)
2993     goto syntax;
2994   if (m == MATCH_ERROR)
2995     goto error;
2996
2997   for (;;)
2998     {
2999       if (group_name->ts.type != BT_UNKNOWN)
3000         {
3001           gfc_error ("Namelist group name '%s' at %C already has a basic "
3002                      "type of %s", group_name->name,
3003                      gfc_typename (&group_name->ts));
3004           return MATCH_ERROR;
3005         }
3006
3007       if (group_name->attr.flavor == FL_NAMELIST
3008           && group_name->attr.use_assoc
3009           && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
3010                              "at %C already is USE associated and can"
3011                              "not be respecified.", group_name->name)
3012              == FAILURE)
3013         return MATCH_ERROR;
3014
3015       if (group_name->attr.flavor != FL_NAMELIST
3016           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
3017                              group_name->name, NULL) == FAILURE)
3018         return MATCH_ERROR;
3019
3020       for (;;)
3021         {
3022           m = gfc_match_symbol (&sym, 1);
3023           if (m == MATCH_NO)
3024             goto syntax;
3025           if (m == MATCH_ERROR)
3026             goto error;
3027
3028           if (sym->attr.in_namelist == 0
3029               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
3030             goto error;
3031
3032           /* Use gfc_error_check here, rather than goto error, so that
3033              these are the only errors for the next two lines.  */
3034           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3035             {
3036               gfc_error ("Assumed size array '%s' in namelist '%s' at "
3037                          "%C is not allowed", sym->name, group_name->name);
3038               gfc_error_check ();
3039             }
3040
3041           if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
3042             {
3043               gfc_error ("Assumed character length '%s' in namelist '%s' at "
3044                          "%C is not allowed", sym->name, group_name->name);
3045               gfc_error_check ();
3046             }
3047
3048           nl = gfc_get_namelist ();
3049           nl->sym = sym;
3050           sym->refs++;
3051
3052           if (group_name->namelist == NULL)
3053             group_name->namelist = group_name->namelist_tail = nl;
3054           else
3055             {
3056               group_name->namelist_tail->next = nl;
3057               group_name->namelist_tail = nl;
3058             }
3059
3060           if (gfc_match_eos () == MATCH_YES)
3061             goto done;
3062
3063           m = gfc_match_char (',');
3064
3065           if (gfc_match_char ('/') == MATCH_YES)
3066             {
3067               m2 = gfc_match (" %s /", &group_name);
3068               if (m2 == MATCH_YES)
3069                 break;
3070               if (m2 == MATCH_ERROR)
3071                 goto error;
3072               goto syntax;
3073             }
3074
3075           if (m != MATCH_YES)
3076             goto syntax;
3077         }
3078     }
3079
3080 done:
3081   return MATCH_YES;
3082
3083 syntax:
3084   gfc_syntax_error (ST_NAMELIST);
3085
3086 error:
3087   return MATCH_ERROR;
3088 }
3089
3090
3091 /* Match a MODULE statement.  */
3092
3093 match
3094 gfc_match_module (void)
3095 {
3096   match m;
3097
3098   m = gfc_match (" %s%t", &gfc_new_block);
3099   if (m != MATCH_YES)
3100     return m;
3101
3102   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
3103                       gfc_new_block->name, NULL) == FAILURE)
3104     return MATCH_ERROR;
3105
3106   return MATCH_YES;
3107 }
3108
3109
3110 /* Free equivalence sets and lists.  Recursively is the easiest way to
3111    do this.  */
3112
3113 void
3114 gfc_free_equiv (gfc_equiv *eq)
3115 {
3116   if (eq == NULL)
3117     return;
3118
3119   gfc_free_equiv (eq->eq);
3120   gfc_free_equiv (eq->next);
3121   gfc_free_expr (eq->expr);
3122   gfc_free (eq);
3123 }
3124
3125
3126 /* Match an EQUIVALENCE statement.  */
3127
3128 match
3129 gfc_match_equivalence (void)
3130 {
3131   gfc_equiv *eq, *set, *tail;
3132   gfc_ref *ref;
3133   gfc_symbol *sym;
3134   match m;
3135   gfc_common_head *common_head = NULL;
3136   bool common_flag;
3137   int cnt;
3138
3139   tail = NULL;
3140
3141   for (;;)
3142     {
3143       eq = gfc_get_equiv ();
3144       if (tail == NULL)
3145         tail = eq;
3146
3147       eq->next = gfc_current_ns->equiv;
3148       gfc_current_ns->equiv = eq;
3149
3150       if (gfc_match_char ('(') != MATCH_YES)
3151         goto syntax;
3152
3153       set = eq;
3154       common_flag = FALSE;
3155       cnt = 0;
3156
3157       for (;;)
3158         {
3159           m = gfc_match_equiv_variable (&set->expr);
3160           if (m == MATCH_ERROR)
3161             goto cleanup;
3162           if (m == MATCH_NO)
3163             goto syntax;
3164
3165           /*  count the number of objects.  */
3166           cnt++;
3167
3168           if (gfc_match_char ('%') == MATCH_YES)
3169             {
3170               gfc_error ("Derived type component %C is not a "
3171                          "permitted EQUIVALENCE member");
3172               goto cleanup;
3173             }
3174
3175           for (ref = set->expr->ref; ref; ref = ref->next)
3176             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3177               {
3178                 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3179                            "be an array section");
3180                 goto cleanup;
3181               }
3182
3183           sym = set->expr->symtree->n.sym;
3184
3185           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
3186             goto cleanup;
3187
3188           if (sym->attr.in_common)
3189             {
3190               common_flag = TRUE;
3191               common_head = sym->common_head;
3192             }
3193
3194           if (gfc_match_char (')') == MATCH_YES)
3195             break;
3196
3197           if (gfc_match_char (',') != MATCH_YES)
3198             goto syntax;
3199
3200           set->eq = gfc_get_equiv ();
3201           set = set->eq;
3202         }
3203
3204       if (cnt < 2)
3205         {
3206           gfc_error ("EQUIVALENCE at %C requires two or more objects");
3207           goto cleanup;
3208         }
3209
3210       /* If one of the members of an equivalence is in common, then
3211          mark them all as being in common.  Before doing this, check
3212          that members of the equivalence group are not in different
3213          common blocks.  */
3214       if (common_flag)
3215         for (set = eq; set; set = set->eq)
3216           {
3217             sym = set->expr->symtree->n.sym;
3218             if (sym->common_head && sym->common_head != common_head)
3219               {
3220                 gfc_error ("Attempt to indirectly overlap COMMON "
3221                            "blocks %s and %s by EQUIVALENCE at %C",
3222                            sym->common_head->name, common_head->name);
3223                 goto cleanup;
3224               }
3225             sym->attr.in_common = 1;
3226             sym->common_head = common_head;
3227           }
3228
3229       if (gfc_match_eos () == MATCH_YES)
3230         break;
3231       if (gfc_match_char (',') != MATCH_YES)
3232         goto syntax;
3233     }
3234
3235   return MATCH_YES;
3236
3237 syntax:
3238   gfc_syntax_error (ST_EQUIVALENCE);
3239
3240 cleanup:
3241   eq = tail->next;
3242   tail->next = NULL;
3243
3244   gfc_free_equiv (gfc_current_ns->equiv);
3245   gfc_current_ns->equiv = eq;
3246
3247   return MATCH_ERROR;
3248 }
3249
3250
3251 /* Check that a statement function is not recursive. This is done by looking
3252    for the statement function symbol(sym) by looking recursively through its
3253    expression(e).  If a reference to sym is found, true is returned.
3254    12.5.4 requires that any variable of function that is implicitly typed
3255    shall have that type confirmed by any subsequent type declaration.  The
3256    implicit typing is conveniently done here.  */
3257 static bool
3258 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
3259
3260 static bool
3261 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
3262 {
3263
3264   if (e == NULL)
3265     return false;
3266
3267   switch (e->expr_type)
3268     {
3269     case EXPR_FUNCTION:
3270       if (e->symtree == NULL)
3271         return false;
3272
3273       /* Check the name before testing for nested recursion!  */
3274       if (sym->name == e->symtree->n.sym->name)
3275         return true;
3276
3277       /* Catch recursion via other statement functions.  */
3278       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
3279           && e->symtree->n.sym->value
3280           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
3281         return true;
3282
3283       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3284         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3285
3286       break;
3287
3288     case EXPR_VARIABLE:
3289       if (e->symtree && sym->name == e->symtree->n.sym->name)
3290         return true;
3291
3292       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3293         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3294       break;
3295
3296     default:
3297       break;
3298     }
3299
3300   return false;
3301 }
3302
3303
3304 static bool
3305 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
3306 {
3307   return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
3308 }
3309
3310
3311 /* Match a statement function declaration.  It is so easy to match
3312    non-statement function statements with a MATCH_ERROR as opposed to
3313    MATCH_NO that we suppress error message in most cases.  */
3314
3315 match
3316 gfc_match_st_function (void)
3317 {
3318   gfc_error_buf old_error;
3319   gfc_symbol *sym;
3320   gfc_expr *expr;
3321   match m;
3322
3323   m = gfc_match_symbol (&sym, 0);
3324   if (m != MATCH_YES)
3325     return m;
3326
3327   gfc_push_error (&old_error);
3328
3329   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
3330                          sym->name, NULL) == FAILURE)
3331     goto undo_error;
3332
3333   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
3334     goto undo_error;
3335
3336   m = gfc_match (" = %e%t", &expr);
3337   if (m == MATCH_NO)
3338     goto undo_error;
3339
3340   gfc_free_error (&old_error);
3341   if (m == MATCH_ERROR)
3342     return m;
3343
3344   if (recursive_stmt_fcn (expr, sym))
3345     {
3346       gfc_error ("Statement function at %L is recursive", &expr->where);
3347       return MATCH_ERROR;
3348     }
3349
3350   sym->value = expr;
3351
3352   return MATCH_YES;
3353
3354 undo_error:
3355   gfc_pop_error (&old_error);
3356   return MATCH_NO;
3357 }
3358
3359
3360 /***************** SELECT CASE subroutines ******************/
3361
3362 /* Free a single case structure.  */
3363
3364 static void
3365 free_case (gfc_case *p)
3366 {
3367   if (p->low == p->high)
3368     p->high = NULL;
3369   gfc_free_expr (p->low);
3370   gfc_free_expr (p->high);
3371   gfc_free (p);
3372 }
3373
3374
3375 /* Free a list of case structures.  */
3376
3377 void
3378 gfc_free_case_list (gfc_case *p)
3379 {
3380   gfc_case *q;
3381
3382   for (; p; p = q)
3383     {
3384       q = p->next;
3385       free_case (p);
3386     }
3387 }
3388
3389
3390 /* Match a single case selector.  */
3391
3392 static match
3393 match_case_selector (gfc_case **cp)
3394 {
3395   gfc_case *c;
3396   match m;
3397
3398   c = gfc_get_case ();
3399   c->where = gfc_current_locus;
3400
3401   if (gfc_match_char (':') == MATCH_YES)
3402     {
3403       m = gfc_match_init_expr (&c->high);
3404       if (m == MATCH_NO)
3405         goto need_expr;
3406       if (m == MATCH_ERROR)
3407         goto cleanup;
3408     }
3409   else
3410     {
3411       m = gfc_match_init_expr (&c->low);
3412       if (m == MATCH_ERROR)
3413         goto cleanup;
3414       if (m == MATCH_NO)
3415         goto need_expr;
3416
3417       /* If we're not looking at a ':' now, make a range out of a single
3418          target.  Else get the upper bound for the case range.  */
3419       if (gfc_match_char (':') != MATCH_YES)
3420         c->high = c->low;
3421       else
3422         {
3423           m = gfc_match_init_expr (&c->high);
3424           if (m == MATCH_ERROR)
3425             goto cleanup;
3426           /* MATCH_NO is fine.  It's OK if nothing is there!  */
3427         }
3428     }
3429
3430   *cp = c;
3431   return MATCH_YES;
3432
3433 need_expr:
3434   gfc_error ("Expected initialization expression in CASE at %C");
3435
3436 cleanup:
3437   free_case (c);
3438   return MATCH_ERROR;
3439 }
3440
3441
3442 /* Match the end of a case statement.  */
3443
3444 static match
3445 match_case_eos (void)
3446 {
3447   char name[GFC_MAX_SYMBOL_LEN + 1];
3448   match m;
3449
3450   if (gfc_match_eos () == MATCH_YES)
3451     return MATCH_YES;
3452
3453   /* If the case construct doesn't have a case-construct-name, we
3454      should have matched the EOS.  */
3455   if (!gfc_current_block ())
3456     {
3457       gfc_error ("Expected the name of the SELECT CASE construct at %C");
3458       return MATCH_ERROR;
3459     }
3460
3461   gfc_gobble_whitespace ();
3462
3463   m = gfc_match_name (name);
3464   if (m != MATCH_YES)
3465     return m;
3466
3467   if (strcmp (name, gfc_current_block ()->name) != 0)
3468     {
3469       gfc_error ("Expected case name of '%s' at %C",
3470                  gfc_current_block ()->name);
3471       return MATCH_ERROR;
3472     }
3473
3474   return gfc_match_eos ();
3475 }
3476
3477
3478 /* Match a SELECT statement.  */
3479
3480 match
3481 gfc_match_select (void)
3482 {
3483   gfc_expr *expr;
3484   match m;
3485
3486   m = gfc_match_label ();
3487   if (m == MATCH_ERROR)
3488     return m;
3489
3490   m = gfc_match (" select case ( %e )%t", &expr);
3491   if (m != MATCH_YES)
3492     return m;
3493
3494   new_st.op = EXEC_SELECT;
3495   new_st.expr = expr;
3496
3497   return MATCH_YES;
3498 }
3499
3500
3501 /* Match a CASE statement.  */
3502
3503 match
3504 gfc_match_case (void)
3505 {
3506   gfc_case *c, *head, *tail;
3507   match m;
3508
3509   head = tail = NULL;
3510
3511   if (gfc_current_state () != COMP_SELECT)
3512     {
3513       gfc_error ("Unexpected CASE statement at %C");
3514       return MATCH_ERROR;
3515     }
3516
3517   if (gfc_match ("% default") == MATCH_YES)
3518     {
3519       m = match_case_eos ();
3520       if (m == MATCH_NO)
3521         goto syntax;
3522       if (m == MATCH_ERROR)
3523         goto cleanup;
3524
3525       new_st.op = EXEC_SELECT;
3526       c = gfc_get_case ();
3527       c->where = gfc_current_locus;
3528       new_st.ext.case_list = c;
3529       return MATCH_YES;
3530     }
3531
3532   if (gfc_match_char ('(') != MATCH_YES)
3533     goto syntax;
3534
3535   for (;;)
3536     {
3537       if (match_case_selector (&c) == MATCH_ERROR)
3538         goto cleanup;
3539
3540       if (head == NULL)
3541         head = c;
3542       else
3543         tail->next = c;
3544
3545       tail = c;
3546
3547       if (gfc_match_char (')') == MATCH_YES)
3548         break;
3549       if (gfc_match_char (',') != MATCH_YES)
3550         goto syntax;
3551     }
3552
3553   m = match_case_eos ();
3554   if (m == MATCH_NO)
3555     goto syntax;
3556   if (m == MATCH_ERROR)
3557     goto cleanup;
3558
3559   new_st.op = EXEC_SELECT;
3560   new_st.ext.case_list = head;
3561
3562   return MATCH_YES;
3563
3564 syntax:
3565   gfc_error ("Syntax error in CASE-specification at %C");
3566
3567 cleanup:
3568   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
3569   return MATCH_ERROR;
3570 }
3571
3572 /********************* WHERE subroutines ********************/
3573
3574 /* Match the rest of a simple WHERE statement that follows an IF statement.
3575  */
3576
3577 static match
3578 match_simple_where (void)
3579 {
3580   gfc_expr *expr;
3581   gfc_code *c;
3582   match m;
3583
3584   m = gfc_match (" ( %e )", &expr);
3585   if (m != MATCH_YES)
3586     return m;
3587
3588   m = gfc_match_assignment ();
3589   if (m == MATCH_NO)
3590     goto syntax;
3591   if (m == MATCH_ERROR)
3592     goto cleanup;
3593
3594   if (gfc_match_eos () != MATCH_YES)
3595     goto syntax;
3596
3597   c = gfc_get_code ();
3598
3599   c->op = EXEC_WHERE;
3600   c->expr = expr;
3601   c->next = gfc_get_code ();
3602
3603   *c->next = new_st;
3604   gfc_clear_new_st ();
3605
3606   new_st.op = EXEC_WHERE;
3607   new_st.block = c;
3608
3609   return MATCH_YES;
3610
3611 syntax:
3612   gfc_syntax_error (ST_WHERE);
3613
3614 cleanup:
3615   gfc_free_expr (expr);
3616   return MATCH_ERROR;
3617 }
3618
3619
3620 /* Match a WHERE statement.  */
3621
3622 match
3623 gfc_match_where (gfc_statement *st)
3624 {
3625   gfc_expr *expr;
3626   match m0, m;
3627   gfc_code *c;
3628
3629   m0 = gfc_match_label ();
3630   if (m0 == MATCH_ERROR)
3631     return m0;
3632
3633   m = gfc_match (" where ( %e )", &expr);
3634   if (m != MATCH_YES)
3635     return m;
3636
3637   if (gfc_match_eos () == MATCH_YES)
3638     {
3639       *st = ST_WHERE_BLOCK;
3640       new_st.op = EXEC_WHERE;
3641       new_st.expr = expr;
3642       return MATCH_YES;
3643     }
3644
3645   m = gfc_match_assignment ();
3646   if (m == MATCH_NO)
3647     gfc_syntax_error (ST_WHERE);
3648
3649   if (m != MATCH_YES)
3650     {
3651       gfc_free_expr (expr);
3652       return MATCH_ERROR;
3653     }
3654
3655   /* We've got a simple WHERE statement.  */
3656   *st = ST_WHERE;
3657   c = gfc_get_code ();
3658
3659   c->op = EXEC_WHERE;
3660   c->expr = expr;
3661   c->next = gfc_get_code ();
3662
3663   *c->next = new_st;
3664   gfc_clear_new_st ();
3665
3666   new_st.op = EXEC_WHERE;
3667   new_st.block = c;
3668
3669   return MATCH_YES;
3670 }
3671
3672
3673 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
3674    new_st if successful.  */
3675
3676 match
3677 gfc_match_elsewhere (void)
3678 {
3679   char name[GFC_MAX_SYMBOL_LEN + 1];
3680   gfc_expr *expr;
3681   match m;
3682
3683   if (gfc_current_state () != COMP_WHERE)
3684     {
3685       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3686       return MATCH_ERROR;
3687     }
3688
3689   expr = NULL;
3690
3691   if (gfc_match_char ('(') == MATCH_YES)
3692     {
3693       m = gfc_match_expr (&expr);
3694       if (m == MATCH_NO)
3695         goto syntax;
3696       if (m == MATCH_ERROR)
3697         return MATCH_ERROR;
3698
3699       if (gfc_match_char (')') != MATCH_YES)
3700         goto syntax;
3701     }
3702
3703   if (gfc_match_eos () != MATCH_YES)
3704     {
3705       /* Only makes sense if we have a where-construct-name.  */
3706       if (!gfc_current_block ())
3707         {
3708           m = MATCH_ERROR;
3709           goto cleanup;
3710         }
3711       /* Better be a name at this point.  */
3712       m = gfc_match_name (name);
3713       if (m == MATCH_NO)
3714         goto syntax;
3715       if (m == MATCH_ERROR)
3716         goto cleanup;
3717
3718       if (gfc_match_eos () != MATCH_YES)
3719         goto syntax;
3720
3721       if (strcmp (name, gfc_current_block ()->name) != 0)
3722         {
3723           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3724                      name, gfc_current_block ()->name);
3725           goto cleanup;
3726         }
3727     }
3728
3729   new_st.op = EXEC_WHERE;
3730   new_st.expr = expr;
3731   return MATCH_YES;
3732
3733 syntax:
3734   gfc_syntax_error (ST_ELSEWHERE);
3735
3736 cleanup:
3737   gfc_free_expr (expr);
3738   return MATCH_ERROR;
3739 }
3740
3741
3742 /******************** FORALL subroutines ********************/
3743
3744 /* Free a list of FORALL iterators.  */
3745
3746 void
3747 gfc_free_forall_iterator (gfc_forall_iterator *iter)
3748 {
3749   gfc_forall_iterator *next;
3750
3751   while (iter)
3752     {
3753       next = iter->next;
3754       gfc_free_expr (iter->var);
3755       gfc_free_expr (iter->start);
3756       gfc_free_expr (iter->end);
3757       gfc_free_expr (iter->stride);
3758       gfc_free (iter);
3759       iter = next;
3760     }
3761 }
3762
3763
3764 /* Match an iterator as part of a FORALL statement.  The format is:
3765
3766      <var> = <start>:<end>[:<stride>]
3767
3768    On MATCH_NO, the caller tests for the possibility that there is a
3769    scalar mask expression.  */
3770
3771 static match
3772 match_forall_iterator (gfc_forall_iterator **result)
3773 {
3774   gfc_forall_iterator *iter;
3775   locus where;
3776   match m;
3777
3778   where = gfc_current_locus;
3779   iter = XCNEW (gfc_forall_iterator);
3780
3781   m = gfc_match_expr (&iter->var);
3782   if (m != MATCH_YES)
3783     goto cleanup;
3784
3785   if (gfc_match_char ('=') != MATCH_YES
3786       || iter->var->expr_type != EXPR_VARIABLE)
3787     {
3788       m = MATCH_NO;
3789       goto cleanup;
3790     }
3791
3792   m = gfc_match_expr (&iter->start);
3793   if (m != MATCH_YES)
3794     goto cleanup;
3795
3796   if (gfc_match_char (':') != MATCH_YES)
3797     goto syntax;
3798
3799   m = gfc_match_expr (&iter->end);
3800   if (m == MATCH_NO)
3801     goto syntax;
3802   if (m == MATCH_ERROR)
3803     goto cleanup;
3804
3805   if (gfc_match_char (':') == MATCH_NO)
3806     iter->stride = gfc_int_expr (1);
3807   else
3808     {
3809       m = gfc_match_expr (&iter->stride);
3810       if (m == MATCH_NO)
3811         goto syntax;
3812       if (m == MATCH_ERROR)
3813         goto cleanup;
3814     }
3815
3816   /* Mark the iteration variable's symbol as used as a FORALL index.  */
3817   iter->var->symtree->n.sym->forall_index = true;
3818
3819   *result = iter;
3820   return MATCH_YES;
3821
3822 syntax:
3823   gfc_error ("Syntax error in FORALL iterator at %C");
3824   m = MATCH_ERROR;
3825
3826 cleanup:
3827
3828   gfc_current_locus = where;
3829   gfc_free_forall_iterator (iter);
3830   return m;
3831 }
3832
3833
3834 /* Match the header of a FORALL statement.  */
3835
3836 static match
3837 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
3838 {
3839   gfc_forall_iterator *head, *tail, *new;
3840   gfc_expr *msk;
3841   match m;
3842
3843   gfc_gobble_whitespace ();
3844
3845   head = tail = NULL;
3846   msk = NULL;
3847
3848   if (gfc_match_char ('(') != MATCH_YES)
3849     return MATCH_NO;
3850
3851   m = match_forall_iterator (&new);
3852   if (m == MATCH_ERROR)
3853     goto cleanup;
3854   if (m == MATCH_NO)
3855     goto syntax;
3856
3857   head = tail = new;
3858
3859   for (;;)
3860     {
3861       if (gfc_match_char (',') != MATCH_YES)
3862         break;
3863
3864       m = match_forall_iterator (&new);
3865       if (m == MATCH_ERROR)
3866         goto cleanup;
3867
3868       if (m == MATCH_YES)
3869         {
3870           tail->next = new;
3871           tail = new;
3872           continue;
3873         }
3874
3875       /* Have to have a mask expression.  */
3876
3877       m = gfc_match_expr (&msk);
3878       if (m == MATCH_NO)
3879         goto syntax;
3880       if (m == MATCH_ERROR)
3881         goto cleanup;
3882
3883       break;
3884     }
3885
3886   if (gfc_match_char (')') == MATCH_NO)
3887     goto syntax;
3888
3889   *phead = head;
3890   *mask = msk;
3891   return MATCH_YES;
3892
3893 syntax:
3894   gfc_syntax_error (ST_FORALL);
3895
3896 cleanup:
3897   gfc_free_expr (msk);
3898   gfc_free_forall_iterator (head);
3899
3900   return MATCH_ERROR;
3901 }
3902
3903 /* Match the rest of a simple FORALL statement that follows an
3904    IF statement.  */
3905
3906 static match
3907 match_simple_forall (void)
3908 {
3909   gfc_forall_iterator *head;
3910   gfc_expr *mask;
3911   gfc_code *c;
3912   match m;
3913
3914   mask = NULL;
3915   head = NULL;
3916   c = NULL;
3917
3918   m = match_forall_header (&head, &mask);
3919
3920   if (m == MATCH_NO)
3921     goto syntax;
3922   if (m != MATCH_YES)
3923     goto cleanup;
3924
3925   m = gfc_match_assignment ();
3926
3927   if (m == MATCH_ERROR)
3928     goto cleanup;
3929   if (m == MATCH_NO)
3930     {
3931       m = gfc_match_pointer_assignment ();
3932       if (m == MATCH_ERROR)
3933         goto cleanup;
3934       if (m == MATCH_NO)
3935         goto syntax;
3936     }
3937
3938   c = gfc_get_code ();
3939   *c = new_st;
3940   c->loc = gfc_current_locus;
3941
3942   if (gfc_match_eos () != MATCH_YES)
3943     goto syntax;
3944
3945   gfc_clear_new_st ();
3946   new_st.op = EXEC_FORALL;
3947   new_st.expr = mask;
3948   new_st.ext.forall_iterator = head;
3949   new_st.block = gfc_get_code ();
3950
3951   new_st.block->op = EXEC_FORALL;
3952   new_st.block->next = c;
3953
3954   return MATCH_YES;
3955
3956 syntax:
3957   gfc_syntax_error (ST_FORALL);
3958
3959 cleanup:
3960   gfc_free_forall_iterator (head);
3961   gfc_free_expr (mask);
3962
3963   return MATCH_ERROR;
3964 }
3965
3966
3967 /* Match a FORALL statement.  */
3968
3969 match
3970 gfc_match_forall (gfc_statement *st)
3971 {
3972   gfc_forall_iterator *head;
3973   gfc_expr *mask;
3974   gfc_code *c;
3975   match m0, m;
3976
3977   head = NULL;
3978   mask = NULL;
3979   c = NULL;
3980
3981   m0 = gfc_match_label ();
3982   if (m0 == MATCH_ERROR)
3983     return MATCH_ERROR;
3984
3985   m = gfc_match (" forall");
3986   if (m != MATCH_YES)
3987     return m;
3988
3989   m = match_forall_header (&head, &mask);
3990   if (m == MATCH_ERROR)
3991     goto cleanup;
3992   if (m == MATCH_NO)
3993     goto syntax;
3994
3995   if (gfc_match_eos () == MATCH_YES)
3996     {
3997       *st = ST_FORALL_BLOCK;
3998       new_st.op = EXEC_FORALL;
3999       new_st.expr = mask;
4000       new_st.ext.forall_iterator = head;
4001       return MATCH_YES;
4002     }
4003
4004   m = gfc_match_assignment ();
4005   if (m == MATCH_ERROR)
4006     goto cleanup;
4007   if (m == MATCH_NO)
4008     {
4009       m = gfc_match_pointer_assignment ();
4010       if (m == MATCH_ERROR)
4011         goto cleanup;
4012       if (m == MATCH_NO)
4013         goto syntax;
4014     }
4015
4016   c = gfc_get_code ();
4017   *c = new_st;
4018   c->loc = gfc_current_locus;
4019
4020   gfc_clear_new_st ();
4021   new_st.op = EXEC_FORALL;
4022   new_st.expr = mask;
4023   new_st.ext.forall_iterator = head;
4024   new_st.block = gfc_get_code ();
4025   new_st.block->op = EXEC_FORALL;
4026   new_st.block->next = c;
4027
4028   *st = ST_FORALL;
4029   return MATCH_YES;
4030
4031 syntax:
4032   gfc_syntax_error (ST_FORALL);
4033
4034 cleanup:
4035   gfc_free_forall_iterator (head);
4036   gfc_free_expr (mask);
4037   gfc_free_statements (c);
4038   return MATCH_NO;
4039 }