gcc/fortran/match.c

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