gcc/fortran/match.c

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