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