gcc/fortran/match.c

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