gcc/fortran/match.c

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