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 (sym->value != NULL && sym->value->expr_type != EXPR_NULL
2790               && (name[0] == '\0' || !sym->attr.data))
2791             {
2792               if (name[0] == '\0')
2793                 gfc_error ("Previously initialized symbol '%s' in "
2794                            "blank COMMON block at %C", sym->name);
2795               else
2796                 gfc_error ("Previously initialized symbol '%s' in "
2797                            "COMMON block '%s' at %C", sym->name, name);
2798               goto cleanup;
2799             }
2800
2801           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2802             goto cleanup;
2803
2804           if (tail != NULL)
2805             tail->common_next = sym;
2806           else
2807             *head = sym;
2808
2809           tail = sym;
2810
2811           /* Deal with an optional array specification after the
2812              symbol name.  */
2813           m = gfc_match_array_spec (&as);
2814           if (m == MATCH_ERROR)
2815             goto cleanup;
2816
2817           if (m == MATCH_YES)
2818             {
2819               if (as->type != AS_EXPLICIT)
2820                 {
2821                   gfc_error ("Array specification for symbol '%s' in COMMON "
2822                              "at %C must be explicit", sym->name);
2823                   goto cleanup;
2824                 }
2825
2826               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2827                 goto cleanup;
2828
2829               if (sym->attr.pointer)
2830                 {
2831                   gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
2832                              "POINTER array", sym->name);
2833                   goto cleanup;
2834                 }
2835
2836               sym->as = as;
2837               as = NULL;
2838
2839             }
2840
2841           sym->common_head = t;
2842
2843           /* Check to see if the symbol is already in an equivalence group.
2844              If it is, set the other members as being in common.  */
2845           if (sym->attr.in_equivalence)
2846             {
2847               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2848                 {
2849                   for (e2 = e1; e2; e2 = e2->eq)
2850                     if (e2->expr->symtree->n.sym == sym)
2851                       goto equiv_found;
2852
2853                   continue;
2854
2855           equiv_found:
2856
2857                   for (e2 = e1; e2; e2 = e2->eq)
2858                     {
2859                       other = e2->expr->symtree->n.sym;
2860                       if (other->common_head
2861                           && other->common_head != sym->common_head)
2862                         {
2863                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
2864                                      "%C is being indirectly equivalenced to "
2865                                      "another COMMON block '%s'",
2866                                      sym->name, sym->common_head->name,
2867                                      other->common_head->name);
2868                             goto cleanup;
2869                         }
2870                       other->attr.in_common = 1;
2871                       other->common_head = t;
2872                     }
2873                 }
2874             }
2875
2876
2877           gfc_gobble_whitespace ();
2878           if (gfc_match_eos () == MATCH_YES)
2879             goto done;
2880           if (gfc_peek_char () == '/')
2881             break;
2882           if (gfc_match_char (',') != MATCH_YES)
2883             goto syntax;
2884           gfc_gobble_whitespace ();
2885           if (gfc_peek_char () == '/')
2886             break;
2887         }
2888     }
2889
2890 done:
2891   return MATCH_YES;
2892
2893 syntax:
2894   gfc_syntax_error (ST_COMMON);
2895
2896 cleanup:
2897   if (old_blank_common)
2898     old_blank_common->common_next = NULL;
2899   else
2900     gfc_current_ns->blank_common.head = NULL;
2901   gfc_free_array_spec (as);
2902   return MATCH_ERROR;
2903 }
2904
2905
2906 /* Match a BLOCK DATA program unit.  */
2907
2908 match
2909 gfc_match_block_data (void)
2910 {
2911   char name[GFC_MAX_SYMBOL_LEN + 1];
2912   gfc_symbol *sym;
2913   match m;
2914
2915   if (gfc_match_eos () == MATCH_YES)
2916     {
2917       gfc_new_block = NULL;
2918       return MATCH_YES;
2919     }
2920
2921   m = gfc_match ("% %n%t", name);
2922   if (m != MATCH_YES)
2923     return MATCH_ERROR;
2924
2925   if (gfc_get_symbol (name, NULL, &sym))
2926     return MATCH_ERROR;
2927
2928   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2929     return MATCH_ERROR;
2930
2931   gfc_new_block = sym;
2932
2933   return MATCH_YES;
2934 }
2935
2936
2937 /* Free a namelist structure.  */
2938
2939 void
2940 gfc_free_namelist (gfc_namelist *name)
2941 {
2942   gfc_namelist *n;
2943
2944   for (; name; name = n)
2945     {
2946       n = name->next;
2947       gfc_free (name);
2948     }
2949 }
2950
2951
2952 /* Match a NAMELIST statement.  */
2953
2954 match
2955 gfc_match_namelist (void)
2956 {
2957   gfc_symbol *group_name, *sym;
2958   gfc_namelist *nl;
2959   match m, m2;
2960
2961   m = gfc_match (" / %s /", &group_name);
2962   if (m == MATCH_NO)
2963     goto syntax;
2964   if (m == MATCH_ERROR)
2965     goto error;
2966
2967   for (;;)
2968     {
2969       if (group_name->ts.type != BT_UNKNOWN)
2970         {
2971           gfc_error ("Namelist group name '%s' at %C already has a basic "
2972                      "type of %s", group_name->name,
2973                      gfc_typename (&group_name->ts));
2974           return MATCH_ERROR;
2975         }
2976
2977       if (group_name->attr.flavor == FL_NAMELIST
2978           && group_name->attr.use_assoc
2979           && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
2980                              "at %C already is USE associated and can"
2981                              "not be respecified.", group_name->name)
2982              == FAILURE)
2983         return MATCH_ERROR;
2984
2985       if (group_name->attr.flavor != FL_NAMELIST
2986           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2987                              group_name->name, NULL) == FAILURE)
2988         return MATCH_ERROR;
2989
2990       for (;;)
2991         {
2992           m = gfc_match_symbol (&sym, 1);
2993           if (m == MATCH_NO)
2994             goto syntax;
2995           if (m == MATCH_ERROR)
2996             goto error;
2997
2998           if (sym->attr.in_namelist == 0
2999               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
3000             goto error;
3001
3002           /* Use gfc_error_check here, rather than goto error, so that
3003              these are the only errors for the next two lines.  */
3004           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3005             {
3006               gfc_error ("Assumed size array '%s' in namelist '%s' at "
3007                          "%C is not allowed", sym->name, group_name->name);
3008               gfc_error_check ();
3009             }
3010
3011           if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
3012             {
3013               gfc_error ("Assumed character length '%s' in namelist '%s' at "
3014                          "%C is not allowed", sym->name, group_name->name);
3015               gfc_error_check ();
3016             }
3017
3018           nl = gfc_get_namelist ();
3019           nl->sym = sym;
3020           sym->refs++;
3021
3022           if (group_name->namelist == NULL)
3023             group_name->namelist = group_name->namelist_tail = nl;
3024           else
3025             {
3026               group_name->namelist_tail->next = nl;
3027               group_name->namelist_tail = nl;
3028             }
3029
3030           if (gfc_match_eos () == MATCH_YES)
3031             goto done;
3032
3033           m = gfc_match_char (',');
3034
3035           if (gfc_match_char ('/') == MATCH_YES)
3036             {
3037               m2 = gfc_match (" %s /", &group_name);
3038               if (m2 == MATCH_YES)
3039                 break;
3040               if (m2 == MATCH_ERROR)
3041                 goto error;
3042               goto syntax;
3043             }
3044
3045           if (m != MATCH_YES)
3046             goto syntax;
3047         }
3048     }
3049
3050 done:
3051   return MATCH_YES;
3052
3053 syntax:
3054   gfc_syntax_error (ST_NAMELIST);
3055
3056 error:
3057   return MATCH_ERROR;
3058 }
3059
3060
3061 /* Match a MODULE statement.  */
3062
3063 match
3064 gfc_match_module (void)
3065 {
3066   match m;
3067
3068   m = gfc_match (" %s%t", &gfc_new_block);
3069   if (m != MATCH_YES)
3070     return m;
3071
3072   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
3073                       gfc_new_block->name, NULL) == FAILURE)
3074     return MATCH_ERROR;
3075
3076   return MATCH_YES;
3077 }
3078
3079
3080 /* Free equivalence sets and lists.  Recursively is the easiest way to
3081    do this.  */
3082
3083 void
3084 gfc_free_equiv (gfc_equiv *eq)
3085 {
3086   if (eq == NULL)
3087     return;
3088
3089   gfc_free_equiv (eq->eq);
3090   gfc_free_equiv (eq->next);
3091   gfc_free_expr (eq->expr);
3092   gfc_free (eq);
3093 }
3094
3095
3096 /* Match an EQUIVALENCE statement.  */
3097
3098 match
3099 gfc_match_equivalence (void)
3100 {
3101   gfc_equiv *eq, *set, *tail;
3102   gfc_ref *ref;
3103   gfc_symbol *sym;
3104   match m;
3105   gfc_common_head *common_head = NULL;
3106   bool common_flag;
3107   int cnt;
3108
3109   tail = NULL;
3110
3111   for (;;)
3112     {
3113       eq = gfc_get_equiv ();
3114       if (tail == NULL)
3115         tail = eq;
3116
3117       eq->next = gfc_current_ns->equiv;
3118       gfc_current_ns->equiv = eq;
3119
3120       if (gfc_match_char ('(') != MATCH_YES)
3121         goto syntax;
3122
3123       set = eq;
3124       common_flag = FALSE;
3125       cnt = 0;
3126
3127       for (;;)
3128         {
3129           m = gfc_match_equiv_variable (&set->expr);
3130           if (m == MATCH_ERROR)
3131             goto cleanup;
3132           if (m == MATCH_NO)
3133             goto syntax;
3134
3135           /*  count the number of objects.  */
3136           cnt++;
3137
3138           if (gfc_match_char ('%') == MATCH_YES)
3139             {
3140               gfc_error ("Derived type component %C is not a "
3141                          "permitted EQUIVALENCE member");
3142               goto cleanup;
3143             }
3144
3145           for (ref = set->expr->ref; ref; ref = ref->next)
3146             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3147               {
3148                 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3149                            "be an array section");
3150                 goto cleanup;
3151               }
3152
3153           sym = set->expr->symtree->n.sym;
3154
3155           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
3156             goto cleanup;
3157
3158           if (sym->attr.in_common)
3159             {
3160               common_flag = TRUE;
3161               common_head = sym->common_head;
3162             }
3163
3164           if (gfc_match_char (')') == MATCH_YES)
3165             break;
3166
3167           if (gfc_match_char (',') != MATCH_YES)
3168             goto syntax;
3169
3170           set->eq = gfc_get_equiv ();
3171           set = set->eq;
3172         }
3173
3174       if (cnt < 2)
3175         {
3176           gfc_error ("EQUIVALENCE at %C requires two or more objects");
3177           goto cleanup;
3178         }
3179
3180       /* If one of the members of an equivalence is in common, then
3181          mark them all as being in common.  Before doing this, check
3182          that members of the equivalence group are not in different
3183          common blocks.  */
3184       if (common_flag)
3185         for (set = eq; set; set = set->eq)
3186           {
3187             sym = set->expr->symtree->n.sym;
3188             if (sym->common_head && sym->common_head != common_head)
3189               {
3190                 gfc_error ("Attempt to indirectly overlap COMMON "
3191                            "blocks %s and %s by EQUIVALENCE at %C",
3192                            sym->common_head->name, common_head->name);
3193                 goto cleanup;
3194               }
3195             sym->attr.in_common = 1;
3196             sym->common_head = common_head;
3197           }
3198
3199       if (gfc_match_eos () == MATCH_YES)
3200         break;
3201       if (gfc_match_char (',') != MATCH_YES)
3202         goto syntax;
3203     }
3204
3205   return MATCH_YES;
3206
3207 syntax:
3208   gfc_syntax_error (ST_EQUIVALENCE);
3209
3210 cleanup:
3211   eq = tail->next;
3212   tail->next = NULL;
3213
3214   gfc_free_equiv (gfc_current_ns->equiv);
3215   gfc_current_ns->equiv = eq;
3216
3217   return MATCH_ERROR;
3218 }
3219
3220
3221 /* Check that a statement function is not recursive. This is done by looking
3222    for the statement function symbol(sym) by looking recursively through its
3223    expression(e).  If a reference to sym is found, true is returned.
3224    12.5.4 requires that any variable of function that is implicitly typed
3225    shall have that type confirmed by any subsequent type declaration.  The
3226    implicit typing is conveniently done here.  */
3227
3228 static bool
3229 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
3230 {
3231   gfc_actual_arglist *arg;
3232   gfc_ref *ref;
3233   int i;
3234
3235   if (e == NULL)
3236     return false;
3237
3238   switch (e->expr_type)
3239     {
3240     case EXPR_FUNCTION:
3241       for (arg = e->value.function.actual; arg; arg = arg->next)
3242         {
3243           if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym))
3244             return true;
3245         }
3246
3247       if (e->symtree == NULL)
3248         return false;
3249
3250       /* Check the name before testing for nested recursion!  */
3251       if (sym->name == e->symtree->n.sym->name)
3252         return true;
3253
3254       /* Catch recursion via other statement functions.  */
3255       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
3256           && e->symtree->n.sym->value
3257           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
3258         return true;
3259
3260       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3261         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3262
3263       break;
3264
3265     case EXPR_VARIABLE:
3266       if (e->symtree && sym->name == e->symtree->n.sym->name)
3267         return true;
3268
3269       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3270         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3271       break;
3272
3273     case EXPR_OP:
3274       if (recursive_stmt_fcn (e->value.op.op1, sym)
3275           || recursive_stmt_fcn (e->value.op.op2, sym))
3276         return true;
3277       break;
3278
3279     default:
3280       break;
3281     }
3282
3283   /* Component references do not need to be checked.  */
3284   if (e->ref)
3285     {
3286       for (ref = e->ref; ref; ref = ref->next)
3287         {
3288           switch (ref->type)
3289             {
3290             case REF_ARRAY:
3291               for (i = 0; i < ref->u.ar.dimen; i++)
3292                 {
3293                   if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
3294                       || recursive_stmt_fcn (ref->u.ar.end[i], sym)
3295                       || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
3296                     return true;
3297                 }
3298               break;
3299
3300             case REF_SUBSTRING:
3301               if (recursive_stmt_fcn (ref->u.ss.start, sym)
3302                   || recursive_stmt_fcn (ref->u.ss.end, sym))
3303                 return true;
3304
3305               break;
3306
3307             default:
3308               break;
3309             }
3310         }
3311     }
3312   return false;
3313 }
3314
3315
3316 /* Match a statement function declaration.  It is so easy to match
3317    non-statement function statements with a MATCH_ERROR as opposed to
3318    MATCH_NO that we suppress error message in most cases.  */
3319
3320 match
3321 gfc_match_st_function (void)
3322 {
3323   gfc_error_buf old_error;
3324   gfc_symbol *sym;
3325   gfc_expr *expr;
3326   match m;
3327
3328   m = gfc_match_symbol (&sym, 0);
3329   if (m != MATCH_YES)
3330     return m;
3331
3332   gfc_push_error (&old_error);
3333
3334   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
3335                          sym->name, NULL) == FAILURE)
3336     goto undo_error;
3337
3338   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
3339     goto undo_error;
3340
3341   m = gfc_match (" = %e%t", &expr);
3342   if (m == MATCH_NO)
3343     goto undo_error;
3344
3345   gfc_free_error (&old_error);
3346   if (m == MATCH_ERROR)
3347     return m;
3348
3349   if (recursive_stmt_fcn (expr, sym))
3350     {
3351       gfc_error ("Statement function at %L is recursive", &expr->where);
3352       return MATCH_ERROR;
3353     }
3354
3355   sym->value = expr;
3356
3357   return MATCH_YES;
3358
3359 undo_error:
3360   gfc_pop_error (&old_error);
3361   return MATCH_NO;
3362 }
3363
3364
3365 /***************** SELECT CASE subroutines ******************/
3366
3367 /* Free a single case structure.  */
3368
3369 static void
3370 free_case (gfc_case *p)
3371 {
3372   if (p->low == p->high)
3373     p->high = NULL;
3374   gfc_free_expr (p->low);
3375   gfc_free_expr (p->high);
3376   gfc_free (p);
3377 }
3378
3379
3380 /* Free a list of case structures.  */
3381
3382 void
3383 gfc_free_case_list (gfc_case *p)
3384 {
3385   gfc_case *q;
3386
3387   for (; p; p = q)
3388     {
3389       q = p->next;
3390       free_case (p);
3391     }
3392 }
3393
3394
3395 /* Match a single case selector.  */
3396
3397 static match
3398 match_case_selector (gfc_case **cp)
3399 {
3400   gfc_case *c;
3401   match m;
3402
3403   c = gfc_get_case ();
3404   c->where = gfc_current_locus;
3405
3406   if (gfc_match_char (':') == MATCH_YES)
3407     {
3408       m = gfc_match_init_expr (&c->high);
3409       if (m == MATCH_NO)
3410         goto need_expr;
3411       if (m == MATCH_ERROR)
3412         goto cleanup;
3413     }
3414   else
3415     {
3416       m = gfc_match_init_expr (&c->low);
3417       if (m == MATCH_ERROR)
3418         goto cleanup;
3419       if (m == MATCH_NO)
3420         goto need_expr;
3421
3422       /* If we're not looking at a ':' now, make a range out of a single
3423          target.  Else get the upper bound for the case range.  */
3424       if (gfc_match_char (':') != MATCH_YES)
3425         c->high = c->low;
3426       else
3427         {
3428           m = gfc_match_init_expr (&c->high);
3429           if (m == MATCH_ERROR)
3430             goto cleanup;
3431           /* MATCH_NO is fine.  It's OK if nothing is there!  */
3432         }
3433     }
3434
3435   *cp = c;
3436   return MATCH_YES;
3437
3438 need_expr:
3439   gfc_error ("Expected initialization expression in CASE at %C");
3440
3441 cleanup:
3442   free_case (c);
3443   return MATCH_ERROR;
3444 }
3445
3446
3447 /* Match the end of a case statement.  */
3448
3449 static match
3450 match_case_eos (void)
3451 {
3452   char name[GFC_MAX_SYMBOL_LEN + 1];
3453   match m;
3454
3455   if (gfc_match_eos () == MATCH_YES)
3456     return MATCH_YES;
3457
3458   /* If the case construct doesn't have a case-construct-name, we
3459      should have matched the EOS.  */
3460   if (!gfc_current_block ())
3461     {
3462       gfc_error ("Expected the name of the SELECT CASE construct at %C");
3463       return MATCH_ERROR;
3464     }
3465
3466   gfc_gobble_whitespace ();
3467
3468   m = gfc_match_name (name);
3469   if (m != MATCH_YES)
3470     return m;
3471
3472   if (strcmp (name, gfc_current_block ()->name) != 0)
3473     {
3474       gfc_error ("Expected case name of '%s' at %C",
3475                  gfc_current_block ()->name);
3476       return MATCH_ERROR;
3477     }
3478
3479   return gfc_match_eos ();
3480 }
3481
3482
3483 /* Match a SELECT statement.  */
3484
3485 match
3486 gfc_match_select (void)
3487 {
3488   gfc_expr *expr;
3489   match m;
3490
3491   m = gfc_match_label ();
3492   if (m == MATCH_ERROR)
3493     return m;
3494
3495   m = gfc_match (" select case ( %e )%t", &expr);
3496   if (m != MATCH_YES)
3497     return m;
3498
3499   new_st.op = EXEC_SELECT;
3500   new_st.expr = expr;
3501
3502   return MATCH_YES;
3503 }
3504
3505
3506 /* Match a CASE statement.  */
3507
3508 match
3509 gfc_match_case (void)
3510 {
3511   gfc_case *c, *head, *tail;
3512   match m;
3513
3514   head = tail = NULL;
3515
3516   if (gfc_current_state () != COMP_SELECT)
3517     {
3518       gfc_error ("Unexpected CASE statement at %C");
3519       return MATCH_ERROR;
3520     }
3521
3522   if (gfc_match ("% default") == MATCH_YES)
3523     {
3524       m = match_case_eos ();
3525       if (m == MATCH_NO)
3526         goto syntax;
3527       if (m == MATCH_ERROR)
3528         goto cleanup;
3529
3530       new_st.op = EXEC_SELECT;
3531       c = gfc_get_case ();
3532       c->where = gfc_current_locus;
3533       new_st.ext.case_list = c;
3534       return MATCH_YES;
3535     }
3536
3537   if (gfc_match_char ('(') != MATCH_YES)
3538     goto syntax;
3539
3540   for (;;)
3541     {
3542       if (match_case_selector (&c) == MATCH_ERROR)
3543         goto cleanup;
3544
3545       if (head == NULL)
3546         head = c;
3547       else
3548         tail->next = c;
3549
3550       tail = c;
3551
3552       if (gfc_match_char (')') == MATCH_YES)
3553         break;
3554       if (gfc_match_char (',') != MATCH_YES)
3555         goto syntax;
3556     }
3557
3558   m = match_case_eos ();
3559   if (m == MATCH_NO)
3560     goto syntax;
3561   if (m == MATCH_ERROR)
3562     goto cleanup;
3563
3564   new_st.op = EXEC_SELECT;
3565   new_st.ext.case_list = head;
3566
3567   return MATCH_YES;
3568
3569 syntax:
3570   gfc_error ("Syntax error in CASE-specification at %C");
3571
3572 cleanup:
3573   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
3574   return MATCH_ERROR;
3575 }
3576
3577 /********************* WHERE subroutines ********************/
3578
3579 /* Match the rest of a simple WHERE statement that follows an IF statement.
3580  */
3581
3582 static match
3583 match_simple_where (void)
3584 {
3585   gfc_expr *expr;
3586   gfc_code *c;
3587   match m;
3588
3589   m = gfc_match (" ( %e )", &expr);
3590   if (m != MATCH_YES)
3591     return m;
3592
3593   m = gfc_match_assignment ();
3594   if (m == MATCH_NO)
3595     goto syntax;
3596   if (m == MATCH_ERROR)
3597     goto cleanup;
3598
3599   if (gfc_match_eos () != MATCH_YES)
3600     goto syntax;
3601
3602   c = gfc_get_code ();
3603
3604   c->op = EXEC_WHERE;
3605   c->expr = expr;
3606   c->next = gfc_get_code ();
3607
3608   *c->next = new_st;
3609   gfc_clear_new_st ();
3610
3611   new_st.op = EXEC_WHERE;
3612   new_st.block = c;
3613
3614   return MATCH_YES;
3615
3616 syntax:
3617   gfc_syntax_error (ST_WHERE);
3618
3619 cleanup:
3620   gfc_free_expr (expr);
3621   return MATCH_ERROR;
3622 }
3623
3624
3625 /* Match a WHERE statement.  */
3626
3627 match
3628 gfc_match_where (gfc_statement *st)
3629 {
3630   gfc_expr *expr;
3631   match m0, m;
3632   gfc_code *c;
3633
3634   m0 = gfc_match_label ();
3635   if (m0 == MATCH_ERROR)
3636     return m0;
3637
3638   m = gfc_match (" where ( %e )", &expr);
3639   if (m != MATCH_YES)
3640     return m;
3641
3642   if (gfc_match_eos () == MATCH_YES)
3643     {
3644       *st = ST_WHERE_BLOCK;
3645       new_st.op = EXEC_WHERE;
3646       new_st.expr = expr;
3647       return MATCH_YES;
3648     }
3649
3650   m = gfc_match_assignment ();
3651   if (m == MATCH_NO)
3652     gfc_syntax_error (ST_WHERE);
3653
3654   if (m != MATCH_YES)
3655     {
3656       gfc_free_expr (expr);
3657       return MATCH_ERROR;
3658     }
3659
3660   /* We've got a simple WHERE statement.  */
3661   *st = ST_WHERE;
3662   c = gfc_get_code ();
3663
3664   c->op = EXEC_WHERE;
3665   c->expr = expr;
3666   c->next = gfc_get_code ();
3667
3668   *c->next = new_st;
3669   gfc_clear_new_st ();
3670
3671   new_st.op = EXEC_WHERE;
3672   new_st.block = c;
3673
3674   return MATCH_YES;
3675 }
3676
3677
3678 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
3679    new_st if successful.  */
3680
3681 match
3682 gfc_match_elsewhere (void)
3683 {
3684   char name[GFC_MAX_SYMBOL_LEN + 1];
3685   gfc_expr *expr;
3686   match m;
3687
3688   if (gfc_current_state () != COMP_WHERE)
3689     {
3690       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3691       return MATCH_ERROR;
3692     }
3693
3694   expr = NULL;
3695
3696   if (gfc_match_char ('(') == MATCH_YES)
3697     {
3698       m = gfc_match_expr (&expr);
3699       if (m == MATCH_NO)
3700         goto syntax;
3701       if (m == MATCH_ERROR)
3702         return MATCH_ERROR;
3703
3704       if (gfc_match_char (')') != MATCH_YES)
3705         goto syntax;
3706     }
3707
3708   if (gfc_match_eos () != MATCH_YES)
3709     {
3710       /* Only makes sense if we have a where-construct-name.  */
3711       if (!gfc_current_block ())
3712         {
3713           m = MATCH_ERROR;
3714           goto cleanup;
3715         }
3716       /* Better be a name at this point.  */
3717       m = gfc_match_name (name);
3718       if (m == MATCH_NO)
3719         goto syntax;
3720       if (m == MATCH_ERROR)
3721         goto cleanup;
3722
3723       if (gfc_match_eos () != MATCH_YES)
3724         goto syntax;
3725
3726       if (strcmp (name, gfc_current_block ()->name) != 0)
3727         {
3728           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3729                      name, gfc_current_block ()->name);
3730           goto cleanup;
3731         }
3732     }
3733
3734   new_st.op = EXEC_WHERE;
3735   new_st.expr = expr;
3736   return MATCH_YES;
3737
3738 syntax:
3739   gfc_syntax_error (ST_ELSEWHERE);
3740
3741 cleanup:
3742   gfc_free_expr (expr);
3743   return MATCH_ERROR;
3744 }
3745
3746
3747 /******************** FORALL subroutines ********************/
3748
3749 /* Free a list of FORALL iterators.  */
3750
3751 void
3752 gfc_free_forall_iterator (gfc_forall_iterator *iter)
3753 {
3754   gfc_forall_iterator *next;
3755
3756   while (iter)
3757     {
3758       next = iter->next;
3759       gfc_free_expr (iter->var);
3760       gfc_free_expr (iter->start);
3761       gfc_free_expr (iter->end);
3762       gfc_free_expr (iter->stride);
3763       gfc_free (iter);
3764       iter = next;
3765     }
3766 }
3767
3768
3769 /* Match an iterator as part of a FORALL statement.  The format is:
3770
3771      <var> = <start>:<end>[:<stride>]
3772
3773    On MATCH_NO, the caller tests for the possibility that there is a
3774    scalar mask expression.  */
3775
3776 static match
3777 match_forall_iterator (gfc_forall_iterator **result)
3778 {
3779   gfc_forall_iterator *iter;
3780   locus where;
3781   match m;
3782
3783   where = gfc_current_locus;
3784   iter = gfc_getmem (sizeof (gfc_forall_iterator));
3785
3786   m = gfc_match_expr (&iter->var);
3787   if (m != MATCH_YES)
3788     goto cleanup;
3789
3790   if (gfc_match_char ('=') != MATCH_YES
3791       || iter->var->expr_type != EXPR_VARIABLE)
3792     {
3793       m = MATCH_NO;
3794       goto cleanup;
3795     }
3796
3797   m = gfc_match_expr (&iter->start);
3798   if (m != MATCH_YES)
3799     goto cleanup;
3800
3801   if (gfc_match_char (':') != MATCH_YES)
3802     goto syntax;
3803
3804   m = gfc_match_expr (&iter->end);
3805   if (m == MATCH_NO)
3806     goto syntax;
3807   if (m == MATCH_ERROR)
3808     goto cleanup;
3809
3810   if (gfc_match_char (':') == MATCH_NO)
3811     iter->stride = gfc_int_expr (1);
3812   else
3813     {
3814       m = gfc_match_expr (&iter->stride);
3815       if (m == MATCH_NO)
3816         goto syntax;
3817       if (m == MATCH_ERROR)
3818         goto cleanup;
3819     }
3820
3821   /* Mark the iteration variable's symbol as used as a FORALL index.  */
3822   iter->var->symtree->n.sym->forall_index = true;
3823
3824   *result = iter;
3825   return MATCH_YES;
3826
3827 syntax:
3828   gfc_error ("Syntax error in FORALL iterator at %C");
3829   m = MATCH_ERROR;
3830
3831 cleanup:
3832
3833   gfc_current_locus = where;
3834   gfc_free_forall_iterator (iter);
3835   return m;
3836 }
3837
3838
3839 /* Match the header of a FORALL statement.  */
3840
3841 static match
3842 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
3843 {
3844   gfc_forall_iterator *head, *tail, *new;
3845   gfc_expr *msk;
3846   match m;
3847
3848   gfc_gobble_whitespace ();
3849
3850   head = tail = NULL;
3851   msk = NULL;
3852
3853   if (gfc_match_char ('(') != MATCH_YES)
3854     return MATCH_NO;
3855
3856   m = match_forall_iterator (&new);
3857   if (m == MATCH_ERROR)
3858     goto cleanup;
3859   if (m == MATCH_NO)
3860     goto syntax;
3861
3862   head = tail = new;
3863
3864   for (;;)
3865     {
3866       if (gfc_match_char (',') != MATCH_YES)
3867         break;
3868
3869       m = match_forall_iterator (&new);
3870       if (m == MATCH_ERROR)
3871         goto cleanup;
3872
3873       if (m == MATCH_YES)
3874         {
3875           tail->next = new;
3876           tail = new;
3877           continue;
3878         }
3879
3880       /* Have to have a mask expression.  */
3881
3882       m = gfc_match_expr (&msk);
3883       if (m == MATCH_NO)
3884         goto syntax;
3885       if (m == MATCH_ERROR)
3886         goto cleanup;
3887
3888       break;
3889     }
3890
3891   if (gfc_match_char (')') == MATCH_NO)
3892     goto syntax;
3893
3894   *phead = head;
3895   *mask = msk;
3896   return MATCH_YES;
3897
3898 syntax:
3899   gfc_syntax_error (ST_FORALL);
3900
3901 cleanup:
3902   gfc_free_expr (msk);
3903   gfc_free_forall_iterator (head);
3904
3905   return MATCH_ERROR;
3906 }
3907
3908 /* Match the rest of a simple FORALL statement that follows an
3909    IF statement.  */
3910
3911 static match
3912 match_simple_forall (void)
3913 {
3914   gfc_forall_iterator *head;
3915   gfc_expr *mask;
3916   gfc_code *c;
3917   match m;
3918
3919   mask = NULL;
3920   head = NULL;
3921   c = NULL;
3922
3923   m = match_forall_header (&head, &mask);
3924
3925   if (m == MATCH_NO)
3926     goto syntax;
3927   if (m != MATCH_YES)
3928     goto cleanup;
3929
3930   m = gfc_match_assignment ();
3931
3932   if (m == MATCH_ERROR)
3933     goto cleanup;
3934   if (m == MATCH_NO)
3935     {
3936       m = gfc_match_pointer_assignment ();
3937       if (m == MATCH_ERROR)
3938         goto cleanup;
3939       if (m == MATCH_NO)
3940         goto syntax;
3941     }
3942
3943   c = gfc_get_code ();
3944   *c = new_st;
3945   c->loc = gfc_current_locus;
3946
3947   if (gfc_match_eos () != MATCH_YES)
3948     goto syntax;
3949
3950   gfc_clear_new_st ();
3951   new_st.op = EXEC_FORALL;
3952   new_st.expr = mask;
3953   new_st.ext.forall_iterator = head;
3954   new_st.block = gfc_get_code ();
3955
3956   new_st.block->op = EXEC_FORALL;
3957   new_st.block->next = c;
3958
3959   return MATCH_YES;
3960
3961 syntax:
3962   gfc_syntax_error (ST_FORALL);
3963
3964 cleanup:
3965   gfc_free_forall_iterator (head);
3966   gfc_free_expr (mask);
3967
3968   return MATCH_ERROR;
3969 }
3970
3971
3972 /* Match a FORALL statement.  */
3973
3974 match
3975 gfc_match_forall (gfc_statement *st)
3976 {
3977   gfc_forall_iterator *head;
3978   gfc_expr *mask;
3979   gfc_code *c;
3980   match m0, m;
3981
3982   head = NULL;
3983   mask = NULL;
3984   c = NULL;
3985
3986   m0 = gfc_match_label ();
3987   if (m0 == MATCH_ERROR)
3988     return MATCH_ERROR;
3989
3990   m = gfc_match (" forall");
3991   if (m != MATCH_YES)
3992     return m;
3993
3994   m = match_forall_header (&head, &mask);
3995   if (m == MATCH_ERROR)
3996     goto cleanup;
3997   if (m == MATCH_NO)
3998     goto syntax;
3999
4000   if (gfc_match_eos () == MATCH_YES)
4001     {
4002       *st = ST_FORALL_BLOCK;
4003       new_st.op = EXEC_FORALL;
4004       new_st.expr = mask;
4005       new_st.ext.forall_iterator = head;
4006       return MATCH_YES;
4007     }
4008
4009   m = gfc_match_assignment ();
4010   if (m == MATCH_ERROR)
4011     goto cleanup;
4012   if (m == MATCH_NO)
4013     {
4014       m = gfc_match_pointer_assignment ();
4015       if (m == MATCH_ERROR)
4016         goto cleanup;
4017       if (m == MATCH_NO)
4018         goto syntax;
4019     }
4020
4021   c = gfc_get_code ();
4022   *c = new_st;
4023   c->loc = gfc_current_locus;
4024
4025   gfc_clear_new_st ();
4026   new_st.op = EXEC_FORALL;
4027   new_st.expr = mask;
4028   new_st.ext.forall_iterator = head;
4029   new_st.block = gfc_get_code ();
4030   new_st.block->op = EXEC_FORALL;
4031   new_st.block->next = c;
4032
4033   *st = ST_FORALL;
4034   return MATCH_YES;
4035
4036 syntax:
4037   gfc_syntax_error (ST_FORALL);
4038
4039 cleanup:
4040   gfc_free_forall_iterator (head);
4041   gfc_free_expr (mask);
4042   gfc_free_statements (c);
4043   return MATCH_NO;
4044 }