gcc/fortran/match.c

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