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