gcc/fortran/match.c

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