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 ("wait", gfc_match_wait, ST_WAIT)
1537   match ("where", match_simple_where, ST_WHERE)
1538   match ("write", gfc_match_write, ST_WRITE)
1539
1540   /* The gfc_match_assignment() above may have returned a MATCH_NO
1541      where the assignment was to a named constant.  Check that
1542      special case here.  */
1543   m = gfc_match_assignment ();
1544   if (m == MATCH_NO)
1545    {
1546       gfc_error ("Cannot assign to a named constant at %C");
1547       gfc_free_expr (expr);
1548       gfc_undo_symbols ();
1549       gfc_current_locus = old_loc;
1550       return MATCH_ERROR;
1551    }
1552
1553   /* All else has failed, so give up.  See if any of the matchers has
1554      stored an error message of some sort.  */
1555   if (gfc_error_check () == 0)
1556     gfc_error ("Unclassifiable statement in IF-clause at %C");
1557
1558   gfc_free_expr (expr);
1559   return MATCH_ERROR;
1560
1561 got_match:
1562   if (m == MATCH_NO)
1563     gfc_error ("Syntax error in IF-clause at %C");
1564   if (m != MATCH_YES)
1565     {
1566       gfc_free_expr (expr);
1567       return MATCH_ERROR;
1568     }
1569
1570   /* At this point, we've matched the single IF and the action clause
1571      is in new_st.  Rearrange things so that the IF statement appears
1572      in new_st.  */
1573
1574   p = gfc_get_code ();
1575   p->next = gfc_get_code ();
1576   *p->next = new_st;
1577   p->next->loc = gfc_current_locus;
1578
1579   p->expr = expr;
1580   p->op = EXEC_IF;
1581
1582   gfc_clear_new_st ();
1583
1584   new_st.op = EXEC_IF;
1585   new_st.block = p;
1586
1587   return MATCH_YES;
1588 }
1589
1590 #undef match
1591
1592
1593 /* Match an ELSE statement.  */
1594
1595 match
1596 gfc_match_else (void)
1597 {
1598   char name[GFC_MAX_SYMBOL_LEN + 1];
1599
1600   if (gfc_match_eos () == MATCH_YES)
1601     return MATCH_YES;
1602
1603   if (gfc_match_name (name) != MATCH_YES
1604       || gfc_current_block () == NULL
1605       || gfc_match_eos () != MATCH_YES)
1606     {
1607       gfc_error ("Unexpected junk after ELSE statement at %C");
1608       return MATCH_ERROR;
1609     }
1610
1611   if (strcmp (name, gfc_current_block ()->name) != 0)
1612     {
1613       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1614                  name, gfc_current_block ()->name);
1615       return MATCH_ERROR;
1616     }
1617
1618   return MATCH_YES;
1619 }
1620
1621
1622 /* Match an ELSE IF statement.  */
1623
1624 match
1625 gfc_match_elseif (void)
1626 {
1627   char name[GFC_MAX_SYMBOL_LEN + 1];
1628   gfc_expr *expr;
1629   match m;
1630
1631   m = gfc_match (" ( %e ) then", &expr);
1632   if (m != MATCH_YES)
1633     return m;
1634
1635   if (gfc_match_eos () == MATCH_YES)
1636     goto done;
1637
1638   if (gfc_match_name (name) != MATCH_YES
1639       || gfc_current_block () == NULL
1640       || gfc_match_eos () != MATCH_YES)
1641     {
1642       gfc_error ("Unexpected junk after ELSE IF statement at %C");
1643       goto cleanup;
1644     }
1645
1646   if (strcmp (name, gfc_current_block ()->name) != 0)
1647     {
1648       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1649                  name, gfc_current_block ()->name);
1650       goto cleanup;
1651     }
1652
1653 done:
1654   new_st.op = EXEC_IF;
1655   new_st.expr = expr;
1656   return MATCH_YES;
1657
1658 cleanup:
1659   gfc_free_expr (expr);
1660   return MATCH_ERROR;
1661 }
1662
1663
1664 /* Free a gfc_iterator structure.  */
1665
1666 void
1667 gfc_free_iterator (gfc_iterator *iter, int flag)
1668 {
1669
1670   if (iter == NULL)
1671     return;
1672
1673   gfc_free_expr (iter->var);
1674   gfc_free_expr (iter->start);
1675   gfc_free_expr (iter->end);
1676   gfc_free_expr (iter->step);
1677
1678   if (flag)
1679     gfc_free (iter);
1680 }
1681
1682
1683 /* Match a DO statement.  */
1684
1685 match
1686 gfc_match_do (void)
1687 {
1688   gfc_iterator iter, *ip;
1689   locus old_loc;
1690   gfc_st_label *label;
1691   match m;
1692
1693   old_loc = gfc_current_locus;
1694
1695   label = NULL;
1696   iter.var = iter.start = iter.end = iter.step = NULL;
1697
1698   m = gfc_match_label ();
1699   if (m == MATCH_ERROR)
1700     return m;
1701
1702   if (gfc_match (" do") != MATCH_YES)
1703     return MATCH_NO;
1704
1705   m = gfc_match_st_label (&label);
1706   if (m == MATCH_ERROR)
1707     goto cleanup;
1708
1709   /* Match an infinite DO, make it like a DO WHILE(.TRUE.).  */
1710
1711   if (gfc_match_eos () == MATCH_YES)
1712     {
1713       iter.end = gfc_logical_expr (1, NULL);
1714       new_st.op = EXEC_DO_WHILE;
1715       goto done;
1716     }
1717
1718   /* Match an optional comma, if no comma is found, a space is obligatory.  */
1719   if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
1720     return MATCH_NO;
1721
1722   /* See if we have a DO WHILE.  */
1723   if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1724     {
1725       new_st.op = EXEC_DO_WHILE;
1726       goto done;
1727     }
1728
1729   /* The abortive DO WHILE may have done something to the symbol
1730      table, so we start over.  */
1731   gfc_undo_symbols ();
1732   gfc_current_locus = old_loc;
1733
1734   gfc_match_label ();           /* This won't error.  */
1735   gfc_match (" do ");           /* This will work.  */
1736
1737   gfc_match_st_label (&label);  /* Can't error out.  */
1738   gfc_match_char (',');         /* Optional comma.  */
1739
1740   m = gfc_match_iterator (&iter, 0);
1741   if (m == MATCH_NO)
1742     return MATCH_NO;
1743   if (m == MATCH_ERROR)
1744     goto cleanup;
1745
1746   iter.var->symtree->n.sym->attr.implied_index = 0;
1747   gfc_check_do_variable (iter.var->symtree);
1748
1749   if (gfc_match_eos () != MATCH_YES)
1750     {
1751       gfc_syntax_error (ST_DO);
1752       goto cleanup;
1753     }
1754
1755   new_st.op = EXEC_DO;
1756
1757 done:
1758   if (label != NULL
1759       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1760     goto cleanup;
1761
1762   new_st.label = label;
1763
1764   if (new_st.op == EXEC_DO_WHILE)
1765     new_st.expr = iter.end;
1766   else
1767     {
1768       new_st.ext.iterator = ip = gfc_get_iterator ();
1769       *ip = iter;
1770     }
1771
1772   return MATCH_YES;
1773
1774 cleanup:
1775   gfc_free_iterator (&iter, 0);
1776
1777   return MATCH_ERROR;
1778 }
1779
1780
1781 /* Match an EXIT or CYCLE statement.  */
1782
1783 static match
1784 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1785 {
1786   gfc_state_data *p, *o;
1787   gfc_symbol *sym;
1788   match m;
1789
1790   if (gfc_match_eos () == MATCH_YES)
1791     sym = NULL;
1792   else
1793     {
1794       m = gfc_match ("% %s%t", &sym);
1795       if (m == MATCH_ERROR)
1796         return MATCH_ERROR;
1797       if (m == MATCH_NO)
1798         {
1799           gfc_syntax_error (st);
1800           return MATCH_ERROR;
1801         }
1802
1803       if (sym->attr.flavor != FL_LABEL)
1804         {
1805           gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1806                      sym->name, gfc_ascii_statement (st));
1807           return MATCH_ERROR;
1808         }
1809     }
1810
1811   /* Find the loop mentioned specified by the label (or lack of a label).  */
1812   for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1813     if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1814       break;
1815     else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1816       o = p;
1817
1818   if (p == NULL)
1819     {
1820       if (sym == NULL)
1821         gfc_error ("%s statement at %C is not within a loop",
1822                    gfc_ascii_statement (st));
1823       else
1824         gfc_error ("%s statement at %C is not within loop '%s'",
1825                    gfc_ascii_statement (st), sym->name);
1826
1827       return MATCH_ERROR;
1828     }
1829
1830   if (o != NULL)
1831     {
1832       gfc_error ("%s statement at %C leaving OpenMP structured block",
1833                  gfc_ascii_statement (st));
1834       return MATCH_ERROR;
1835     }
1836   else if (st == ST_EXIT
1837            && p->previous != NULL
1838            && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1839            && (p->previous->head->op == EXEC_OMP_DO
1840                || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1841     {
1842       gcc_assert (p->previous->head->next != NULL);
1843       gcc_assert (p->previous->head->next->op == EXEC_DO
1844                   || p->previous->head->next->op == EXEC_DO_WHILE);
1845       gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1846       return MATCH_ERROR;
1847     }
1848
1849   /* Save the first statement in the loop - needed by the backend.  */
1850   new_st.ext.whichloop = p->head;
1851
1852   new_st.op = op;
1853
1854   return MATCH_YES;
1855 }
1856
1857
1858 /* Match the EXIT statement.  */
1859
1860 match
1861 gfc_match_exit (void)
1862 {
1863   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1864 }
1865
1866
1867 /* Match the CYCLE statement.  */
1868
1869 match
1870 gfc_match_cycle (void)
1871 {
1872   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1873 }
1874
1875
1876 /* Match a number or character constant after a STOP or PAUSE statement.  */
1877
1878 static match
1879 gfc_match_stopcode (gfc_statement st)
1880 {
1881   int stop_code;
1882   gfc_expr *e;
1883   match m;
1884   int cnt;
1885
1886   stop_code = -1;
1887   e = NULL;
1888
1889   if (gfc_match_eos () != MATCH_YES)
1890     {
1891       m = gfc_match_small_literal_int (&stop_code, &cnt);
1892       if (m == MATCH_ERROR)
1893         goto cleanup;
1894
1895       if (m == MATCH_YES && cnt > 5)
1896         {
1897           gfc_error ("Too many digits in STOP code at %C");
1898           goto cleanup;
1899         }
1900
1901       if (m == MATCH_NO)
1902         {
1903           /* Try a character constant.  */
1904           m = gfc_match_expr (&e);
1905           if (m == MATCH_ERROR)
1906             goto cleanup;
1907           if (m == MATCH_NO)
1908             goto syntax;
1909           if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1910             goto syntax;
1911         }
1912
1913       if (gfc_match_eos () != MATCH_YES)
1914         goto syntax;
1915     }
1916
1917   if (gfc_pure (NULL))
1918     {
1919       gfc_error ("%s statement not allowed in PURE procedure at %C",
1920                  gfc_ascii_statement (st));
1921       goto cleanup;
1922     }
1923
1924   new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1925   new_st.expr = e;
1926   new_st.ext.stop_code = stop_code;
1927
1928   return MATCH_YES;
1929
1930 syntax:
1931   gfc_syntax_error (st);
1932
1933 cleanup:
1934
1935   gfc_free_expr (e);
1936   return MATCH_ERROR;
1937 }
1938
1939
1940 /* Match the (deprecated) PAUSE statement.  */
1941
1942 match
1943 gfc_match_pause (void)
1944 {
1945   match m;
1946
1947   m = gfc_match_stopcode (ST_PAUSE);
1948   if (m == MATCH_YES)
1949     {
1950       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
1951           " at %C")
1952           == FAILURE)
1953         m = MATCH_ERROR;
1954     }
1955   return m;
1956 }
1957
1958
1959 /* Match the STOP statement.  */
1960
1961 match
1962 gfc_match_stop (void)
1963 {
1964   return gfc_match_stopcode (ST_STOP);
1965 }
1966
1967
1968 /* Match a CONTINUE statement.  */
1969
1970 match
1971 gfc_match_continue (void)
1972 {
1973   if (gfc_match_eos () != MATCH_YES)
1974     {
1975       gfc_syntax_error (ST_CONTINUE);
1976       return MATCH_ERROR;
1977     }
1978
1979   new_st.op = EXEC_CONTINUE;
1980   return MATCH_YES;
1981 }
1982
1983
1984 /* Match the (deprecated) ASSIGN statement.  */
1985
1986 match
1987 gfc_match_assign (void)
1988 {
1989   gfc_expr *expr;
1990   gfc_st_label *label;
1991
1992   if (gfc_match (" %l", &label) == MATCH_YES)
1993     {
1994       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
1995         return MATCH_ERROR;
1996       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
1997         {
1998           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
1999                               "statement at %C")
2000               == FAILURE)
2001             return MATCH_ERROR;
2002
2003           expr->symtree->n.sym->attr.assign = 1;
2004
2005           new_st.op = EXEC_LABEL_ASSIGN;
2006           new_st.label = label;
2007           new_st.expr = expr;
2008           return MATCH_YES;
2009         }
2010     }
2011   return MATCH_NO;
2012 }
2013
2014
2015 /* Match the GO TO statement.  As a computed GOTO statement is
2016    matched, it is transformed into an equivalent SELECT block.  No
2017    tree is necessary, and the resulting jumps-to-jumps are
2018    specifically optimized away by the back end.  */
2019
2020 match
2021 gfc_match_goto (void)
2022 {
2023   gfc_code *head, *tail;
2024   gfc_expr *expr;
2025   gfc_case *cp;
2026   gfc_st_label *label;
2027   int i;
2028   match m;
2029
2030   if (gfc_match (" %l%t", &label) == MATCH_YES)
2031     {
2032       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2033         return MATCH_ERROR;
2034
2035       new_st.op = EXEC_GOTO;
2036       new_st.label = label;
2037       return MATCH_YES;
2038     }
2039
2040   /* The assigned GO TO statement.  */
2041
2042   if (gfc_match_variable (&expr, 0) == MATCH_YES)
2043     {
2044       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
2045                           "statement at %C")
2046           == FAILURE)
2047         return MATCH_ERROR;
2048
2049       new_st.op = EXEC_GOTO;
2050       new_st.expr = expr;
2051
2052       if (gfc_match_eos () == MATCH_YES)
2053         return MATCH_YES;
2054
2055       /* Match label list.  */
2056       gfc_match_char (',');
2057       if (gfc_match_char ('(') != MATCH_YES)
2058         {
2059           gfc_syntax_error (ST_GOTO);
2060           return MATCH_ERROR;
2061         }
2062       head = tail = NULL;
2063
2064       do
2065         {
2066           m = gfc_match_st_label (&label);
2067           if (m != MATCH_YES)
2068             goto syntax;
2069
2070           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2071             goto cleanup;
2072
2073           if (head == NULL)
2074             head = tail = gfc_get_code ();
2075           else
2076             {
2077               tail->block = gfc_get_code ();
2078               tail = tail->block;
2079             }
2080
2081           tail->label = label;
2082           tail->op = EXEC_GOTO;
2083         }
2084       while (gfc_match_char (',') == MATCH_YES);
2085
2086       if (gfc_match (")%t") != MATCH_YES)
2087         goto syntax;
2088
2089       if (head == NULL)
2090         {
2091            gfc_error ("Statement label list in GOTO at %C cannot be empty");
2092            goto syntax;
2093         }
2094       new_st.block = head;
2095
2096       return MATCH_YES;
2097     }
2098
2099   /* Last chance is a computed GO TO statement.  */
2100   if (gfc_match_char ('(') != MATCH_YES)
2101     {
2102       gfc_syntax_error (ST_GOTO);
2103       return MATCH_ERROR;
2104     }
2105
2106   head = tail = NULL;
2107   i = 1;
2108
2109   do
2110     {
2111       m = gfc_match_st_label (&label);
2112       if (m != MATCH_YES)
2113         goto syntax;
2114
2115       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2116         goto cleanup;
2117
2118       if (head == NULL)
2119         head = tail = gfc_get_code ();
2120       else
2121         {
2122           tail->block = gfc_get_code ();
2123           tail = tail->block;
2124         }
2125
2126       cp = gfc_get_case ();
2127       cp->low = cp->high = gfc_int_expr (i++);
2128
2129       tail->op = EXEC_SELECT;
2130       tail->ext.case_list = cp;
2131
2132       tail->next = gfc_get_code ();
2133       tail->next->op = EXEC_GOTO;
2134       tail->next->label = label;
2135     }
2136   while (gfc_match_char (',') == MATCH_YES);
2137
2138   if (gfc_match_char (')') != MATCH_YES)
2139     goto syntax;
2140
2141   if (head == NULL)
2142     {
2143       gfc_error ("Statement label list in GOTO at %C cannot be empty");
2144       goto syntax;
2145     }
2146
2147   /* Get the rest of the statement.  */
2148   gfc_match_char (',');
2149
2150   if (gfc_match (" %e%t", &expr) != MATCH_YES)
2151     goto syntax;
2152
2153   /* At this point, a computed GOTO has been fully matched and an
2154      equivalent SELECT statement constructed.  */
2155
2156   new_st.op = EXEC_SELECT;
2157   new_st.expr = NULL;
2158
2159   /* Hack: For a "real" SELECT, the expression is in expr. We put
2160      it in expr2 so we can distinguish then and produce the correct
2161      diagnostics.  */
2162   new_st.expr2 = expr;
2163   new_st.block = head;
2164   return MATCH_YES;
2165
2166 syntax:
2167   gfc_syntax_error (ST_GOTO);
2168 cleanup:
2169   gfc_free_statements (head);
2170   return MATCH_ERROR;
2171 }
2172
2173
2174 /* Frees a list of gfc_alloc structures.  */
2175
2176 void
2177 gfc_free_alloc_list (gfc_alloc *p)
2178 {
2179   gfc_alloc *q;
2180
2181   for (; p; p = q)
2182     {
2183       q = p->next;
2184       gfc_free_expr (p->expr);
2185       gfc_free (p);
2186     }
2187 }
2188
2189
2190 /* Match an ALLOCATE statement.  */
2191
2192 match
2193 gfc_match_allocate (void)
2194 {
2195   gfc_alloc *head, *tail;
2196   gfc_expr *stat;
2197   match m;
2198
2199   head = tail = NULL;
2200   stat = NULL;
2201
2202   if (gfc_match_char ('(') != MATCH_YES)
2203     goto syntax;
2204
2205   for (;;)
2206     {
2207       if (head == NULL)
2208         head = tail = gfc_get_alloc ();
2209       else
2210         {
2211           tail->next = gfc_get_alloc ();
2212           tail = tail->next;
2213         }
2214
2215       m = gfc_match_variable (&tail->expr, 0);
2216       if (m == MATCH_NO)
2217         goto syntax;
2218       if (m == MATCH_ERROR)
2219         goto cleanup;
2220
2221       if (gfc_check_do_variable (tail->expr->symtree))
2222         goto cleanup;
2223
2224       if (gfc_pure (NULL)
2225           && gfc_impure_variable (tail->expr->symtree->n.sym))
2226         {
2227           gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
2228                      "PURE procedure");
2229           goto cleanup;
2230         }
2231
2232       if (tail->expr->ts.type == BT_DERIVED)
2233         tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
2234
2235       if (gfc_match_char (',') != MATCH_YES)
2236         break;
2237
2238       m = gfc_match (" stat = %v", &stat);
2239       if (m == MATCH_ERROR)
2240         goto cleanup;
2241       if (m == MATCH_YES)
2242         break;
2243     }
2244
2245   if (stat != NULL)
2246     gfc_check_do_variable(stat->symtree);
2247
2248   if (gfc_match (" )%t") != MATCH_YES)
2249     goto syntax;
2250
2251   new_st.op = EXEC_ALLOCATE;
2252   new_st.expr = stat;
2253   new_st.ext.alloc_list = head;
2254
2255   return MATCH_YES;
2256
2257 syntax:
2258   gfc_syntax_error (ST_ALLOCATE);
2259
2260 cleanup:
2261   gfc_free_expr (stat);
2262   gfc_free_alloc_list (head);
2263   return MATCH_ERROR;
2264 }
2265
2266
2267 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2268    a set of pointer assignments to intrinsic NULL().  */
2269
2270 match
2271 gfc_match_nullify (void)
2272 {
2273   gfc_code *tail;
2274   gfc_expr *e, *p;
2275   match m;
2276
2277   tail = NULL;
2278
2279   if (gfc_match_char ('(') != MATCH_YES)
2280     goto syntax;
2281
2282   for (;;)
2283     {
2284       m = gfc_match_variable (&p, 0);
2285       if (m == MATCH_ERROR)
2286         goto cleanup;
2287       if (m == MATCH_NO)
2288         goto syntax;
2289
2290       if (gfc_check_do_variable (p->symtree))
2291         goto cleanup;
2292
2293       if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
2294         {
2295           gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2296           goto cleanup;
2297         }
2298
2299       /* build ' => NULL() '.  */
2300       e = gfc_get_expr ();
2301       e->where = gfc_current_locus;
2302       e->expr_type = EXPR_NULL;
2303       e->ts.type = BT_UNKNOWN;
2304
2305       /* Chain to list.  */
2306       if (tail == NULL)
2307         tail = &new_st;
2308       else
2309         {
2310           tail->next = gfc_get_code ();
2311           tail = tail->next;
2312         }
2313
2314       tail->op = EXEC_POINTER_ASSIGN;
2315       tail->expr = p;
2316       tail->expr2 = e;
2317
2318       if (gfc_match (" )%t") == MATCH_YES)
2319         break;
2320       if (gfc_match_char (',') != MATCH_YES)
2321         goto syntax;
2322     }
2323
2324   return MATCH_YES;
2325
2326 syntax:
2327   gfc_syntax_error (ST_NULLIFY);
2328
2329 cleanup:
2330   gfc_free_statements (new_st.next);
2331   return MATCH_ERROR;
2332 }
2333
2334
2335 /* Match a DEALLOCATE statement.  */
2336
2337 match
2338 gfc_match_deallocate (void)
2339 {
2340   gfc_alloc *head, *tail;
2341   gfc_expr *stat;
2342   match m;
2343
2344   head = tail = NULL;
2345   stat = NULL;
2346
2347   if (gfc_match_char ('(') != MATCH_YES)
2348     goto syntax;
2349
2350   for (;;)
2351     {
2352       if (head == NULL)
2353         head = tail = gfc_get_alloc ();
2354       else
2355         {
2356           tail->next = gfc_get_alloc ();
2357           tail = tail->next;
2358         }
2359
2360       m = gfc_match_variable (&tail->expr, 0);
2361       if (m == MATCH_ERROR)
2362         goto cleanup;
2363       if (m == MATCH_NO)
2364         goto syntax;
2365
2366       if (gfc_check_do_variable (tail->expr->symtree))
2367         goto cleanup;
2368
2369       if (gfc_pure (NULL)
2370           && gfc_impure_variable (tail->expr->symtree->n.sym))
2371         {
2372           gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
2373                      "for a PURE procedure");
2374           goto cleanup;
2375         }
2376
2377       if (gfc_match_char (',') != MATCH_YES)
2378         break;
2379
2380       m = gfc_match (" stat = %v", &stat);
2381       if (m == MATCH_ERROR)
2382         goto cleanup;
2383       if (m == MATCH_YES)
2384         break;
2385     }
2386
2387   if (stat != NULL)
2388     gfc_check_do_variable(stat->symtree);
2389
2390   if (gfc_match (" )%t") != MATCH_YES)
2391     goto syntax;
2392
2393   new_st.op = EXEC_DEALLOCATE;
2394   new_st.expr = stat;
2395   new_st.ext.alloc_list = head;
2396
2397   return MATCH_YES;
2398
2399 syntax:
2400   gfc_syntax_error (ST_DEALLOCATE);
2401
2402 cleanup:
2403   gfc_free_expr (stat);
2404   gfc_free_alloc_list (head);
2405   return MATCH_ERROR;
2406 }
2407
2408
2409 /* Match a RETURN statement.  */
2410
2411 match
2412 gfc_match_return (void)
2413 {
2414   gfc_expr *e;
2415   match m;
2416   gfc_compile_state s;
2417   int c;
2418
2419   e = NULL;
2420   if (gfc_match_eos () == MATCH_YES)
2421     goto done;
2422
2423   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2424     {
2425       gfc_error ("Alternate RETURN statement at %C is only allowed within "
2426                  "a SUBROUTINE");
2427       goto cleanup;
2428     }
2429
2430   if (gfc_current_form == FORM_FREE)
2431     {
2432       /* The following are valid, so we can't require a blank after the
2433         RETURN keyword:
2434           return+1
2435           return(1)  */
2436       c = gfc_peek_char ();
2437       if (ISALPHA (c) || ISDIGIT (c))
2438         return MATCH_NO;
2439     }
2440
2441   m = gfc_match (" %e%t", &e);
2442   if (m == MATCH_YES)
2443     goto done;
2444   if (m == MATCH_ERROR)
2445     goto cleanup;
2446
2447   gfc_syntax_error (ST_RETURN);
2448
2449 cleanup:
2450   gfc_free_expr (e);
2451   return MATCH_ERROR;
2452
2453 done:
2454   gfc_enclosing_unit (&s);
2455   if (s == COMP_PROGRAM
2456       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2457                         "main program at %C") == FAILURE)
2458       return MATCH_ERROR;
2459
2460   new_st.op = EXEC_RETURN;
2461   new_st.expr = e;
2462
2463   return MATCH_YES;
2464 }
2465
2466
2467 /* Match a CALL statement.  The tricky part here are possible
2468    alternate return specifiers.  We handle these by having all
2469    "subroutines" actually return an integer via a register that gives
2470    the return number.  If the call specifies alternate returns, we
2471    generate code for a SELECT statement whose case clauses contain
2472    GOTOs to the various labels.  */
2473
2474 match
2475 gfc_match_call (void)
2476 {
2477   char name[GFC_MAX_SYMBOL_LEN + 1];
2478   gfc_actual_arglist *a, *arglist;
2479   gfc_case *new_case;
2480   gfc_symbol *sym;
2481   gfc_symtree *st;
2482   gfc_code *c;
2483   match m;
2484   int i;
2485
2486   arglist = NULL;
2487
2488   m = gfc_match ("% %n", name);
2489   if (m == MATCH_NO)
2490     goto syntax;
2491   if (m != MATCH_YES)
2492     return m;
2493
2494   if (gfc_get_ha_sym_tree (name, &st))
2495     return MATCH_ERROR;
2496
2497   sym = st->n.sym;
2498
2499   /* If it does not seem to be callable...  */
2500   if (!sym->attr.generic
2501         && !sym->attr.subroutine)
2502     {
2503       if (!(sym->attr.external && !sym->attr.referenced))
2504         {
2505           /* ...create a symbol in this scope...  */
2506           if (sym->ns != gfc_current_ns
2507                 && gfc_get_sym_tree (name, NULL, &st) == 1)
2508             return MATCH_ERROR;
2509
2510           if (sym != st->n.sym)
2511             sym = st->n.sym;
2512         }
2513
2514       /* ...and then to try to make the symbol into a subroutine.  */
2515       if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2516         return MATCH_ERROR;
2517     }
2518
2519   gfc_set_sym_referenced (sym);
2520
2521   if (gfc_match_eos () != MATCH_YES)
2522     {
2523       m = gfc_match_actual_arglist (1, &arglist);
2524       if (m == MATCH_NO)
2525         goto syntax;
2526       if (m == MATCH_ERROR)
2527         goto cleanup;
2528
2529       if (gfc_match_eos () != MATCH_YES)
2530         goto syntax;
2531     }
2532
2533   /* If any alternate return labels were found, construct a SELECT
2534      statement that will jump to the right place.  */
2535
2536   i = 0;
2537   for (a = arglist; a; a = a->next)
2538     if (a->expr == NULL)
2539       i = 1;
2540
2541   if (i)
2542     {
2543       gfc_symtree *select_st;
2544       gfc_symbol *select_sym;
2545       char name[GFC_MAX_SYMBOL_LEN + 1];
2546
2547       new_st.next = c = gfc_get_code ();
2548       c->op = EXEC_SELECT;
2549       sprintf (name, "_result_%s", sym->name);
2550       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
2551
2552       select_sym = select_st->n.sym;
2553       select_sym->ts.type = BT_INTEGER;
2554       select_sym->ts.kind = gfc_default_integer_kind;
2555       gfc_set_sym_referenced (select_sym);
2556       c->expr = gfc_get_expr ();
2557       c->expr->expr_type = EXPR_VARIABLE;
2558       c->expr->symtree = select_st;
2559       c->expr->ts = select_sym->ts;
2560       c->expr->where = gfc_current_locus;
2561
2562       i = 0;
2563       for (a = arglist; a; a = a->next)
2564         {
2565           if (a->expr != NULL)
2566             continue;
2567
2568           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2569             continue;
2570
2571           i++;
2572
2573           c->block = gfc_get_code ();
2574           c = c->block;
2575           c->op = EXEC_SELECT;
2576
2577           new_case = gfc_get_case ();
2578           new_case->high = new_case->low = gfc_int_expr (i);
2579           c->ext.case_list = new_case;
2580
2581           c->next = gfc_get_code ();
2582           c->next->op = EXEC_GOTO;
2583           c->next->label = a->label;
2584         }
2585     }
2586
2587   new_st.op = EXEC_CALL;
2588   new_st.symtree = st;
2589   new_st.ext.actual = arglist;
2590
2591   return MATCH_YES;
2592
2593 syntax:
2594   gfc_syntax_error (ST_CALL);
2595
2596 cleanup:
2597   gfc_free_actual_arglist (arglist);
2598   return MATCH_ERROR;
2599 }
2600
2601
2602 /* Given a name, return a pointer to the common head structure,
2603    creating it if it does not exist. If FROM_MODULE is nonzero, we
2604    mangle the name so that it doesn't interfere with commons defined
2605    in the using namespace.
2606    TODO: Add to global symbol tree.  */
2607
2608 gfc_common_head *
2609 gfc_get_common (const char *name, int from_module)
2610 {
2611   gfc_symtree *st;
2612   static int serial = 0;
2613   char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
2614
2615   if (from_module)
2616     {
2617       /* A use associated common block is only needed to correctly layout
2618          the variables it contains.  */
2619       snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2620       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2621     }
2622   else
2623     {
2624       st = gfc_find_symtree (gfc_current_ns->common_root, name);
2625
2626       if (st == NULL)
2627         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2628     }
2629
2630   if (st->n.common == NULL)
2631     {
2632       st->n.common = gfc_get_common_head ();
2633       st->n.common->where = gfc_current_locus;
2634       strcpy (st->n.common->name, name);
2635     }
2636
2637   return st->n.common;
2638 }
2639
2640
2641 /* Match a common block name.  */
2642
2643 match match_common_name (char *name)
2644 {
2645   match m;
2646
2647   if (gfc_match_char ('/') == MATCH_NO)
2648     {
2649       name[0] = '\0';
2650       return MATCH_YES;
2651     }
2652
2653   if (gfc_match_char ('/') == MATCH_YES)
2654     {
2655       name[0] = '\0';
2656       return MATCH_YES;
2657     }
2658
2659   m = gfc_match_name (name);
2660
2661   if (m == MATCH_ERROR)
2662     return MATCH_ERROR;
2663   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2664     return MATCH_YES;
2665
2666   gfc_error ("Syntax error in common block name at %C");
2667   return MATCH_ERROR;
2668 }
2669
2670
2671 /* Match a COMMON statement.  */
2672
2673 match
2674 gfc_match_common (void)
2675 {
2676   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2677   char name[GFC_MAX_SYMBOL_LEN + 1];
2678   gfc_common_head *t;
2679   gfc_array_spec *as;
2680   gfc_equiv *e1, *e2;
2681   match m;
2682   gfc_gsymbol *gsym;
2683
2684   old_blank_common = gfc_current_ns->blank_common.head;
2685   if (old_blank_common)
2686     {
2687       while (old_blank_common->common_next)
2688         old_blank_common = old_blank_common->common_next;
2689     }
2690
2691   as = NULL;
2692
2693   for (;;)
2694     {
2695       m = match_common_name (name);
2696       if (m == MATCH_ERROR)
2697         goto cleanup;
2698
2699       gsym = gfc_get_gsymbol (name);
2700       if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
2701         {
2702           gfc_error ("Symbol '%s' at %C is already an external symbol that "
2703                      "is not COMMON", name);
2704           goto cleanup;
2705         }
2706
2707       if (gsym->type == GSYM_UNKNOWN)
2708         {
2709           gsym->type = GSYM_COMMON;
2710           gsym->where = gfc_current_locus;
2711           gsym->defined = 1;
2712         }
2713
2714       gsym->used = 1;
2715
2716       if (name[0] == '\0')
2717         {
2718           t = &gfc_current_ns->blank_common;
2719           if (t->head == NULL)
2720             t->where = gfc_current_locus;
2721         }
2722       else
2723         {
2724           t = gfc_get_common (name, 0);
2725         }
2726       head = &t->head;
2727
2728       if (*head == NULL)
2729         tail = NULL;
2730       else
2731         {
2732           tail = *head;
2733           while (tail->common_next)
2734             tail = tail->common_next;
2735         }
2736
2737       /* Grab the list of symbols.  */
2738       for (;;)
2739         {
2740           m = gfc_match_symbol (&sym, 0);
2741           if (m == MATCH_ERROR)
2742             goto cleanup;
2743           if (m == MATCH_NO)
2744             goto syntax;
2745
2746           /* Store a ref to the common block for error checking.  */
2747           sym->common_block = t;
2748
2749           /* See if we know the current common block is bind(c), and if
2750              so, then see if we can check if the symbol is (which it'll
2751              need to be).  This can happen if the bind(c) attr stmt was
2752              applied to the common block, and the variable(s) already
2753              defined, before declaring the common block.  */
2754           if (t->is_bind_c == 1)
2755             {
2756               if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
2757                 {
2758                   /* If we find an error, just print it and continue,
2759                      cause it's just semantic, and we can see if there
2760                      are more errors.  */
2761                   gfc_error_now ("Variable '%s' at %L in common block '%s' "
2762                                  "at %C must be declared with a C "
2763                                  "interoperable kind since common block "
2764                                  "'%s' is bind(c)",
2765                                  sym->name, &(sym->declared_at), t->name,
2766                                  t->name);
2767                 }
2768
2769               if (sym->attr.is_bind_c == 1)
2770                 gfc_error_now ("Variable '%s' in common block "
2771                                "'%s' at %C can not be bind(c) since "
2772                                "it is not global", sym->name, t->name);
2773             }
2774
2775           if (sym->attr.in_common)
2776             {
2777               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2778                          sym->name);
2779               goto cleanup;
2780             }
2781
2782           if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
2783                || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
2784             {
2785               if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
2786                                                "can only be COMMON in "
2787                                                "BLOCK DATA", sym->name)
2788                   == FAILURE)
2789                 goto cleanup;
2790             }
2791
2792           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2793             goto cleanup;
2794
2795           if (tail != NULL)
2796             tail->common_next = sym;
2797           else
2798             *head = sym;
2799
2800           tail = sym;
2801
2802           /* Deal with an optional array specification after the
2803              symbol name.  */
2804           m = gfc_match_array_spec (&as);
2805           if (m == MATCH_ERROR)
2806             goto cleanup;
2807
2808           if (m == MATCH_YES)
2809             {
2810               if (as->type != AS_EXPLICIT)
2811                 {
2812                   gfc_error ("Array specification for symbol '%s' in COMMON "
2813                              "at %C must be explicit", sym->name);
2814                   goto cleanup;
2815                 }
2816
2817               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2818                 goto cleanup;
2819
2820               if (sym->attr.pointer)
2821                 {
2822                   gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
2823                              "POINTER array", sym->name);
2824                   goto cleanup;
2825                 }
2826
2827               sym->as = as;
2828               as = NULL;
2829
2830             }
2831
2832           sym->common_head = t;
2833
2834           /* Check to see if the symbol is already in an equivalence group.
2835              If it is, set the other members as being in common.  */
2836           if (sym->attr.in_equivalence)
2837             {
2838               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2839                 {
2840                   for (e2 = e1; e2; e2 = e2->eq)
2841                     if (e2->expr->symtree->n.sym == sym)
2842                       goto equiv_found;
2843
2844                   continue;
2845
2846           equiv_found:
2847
2848                   for (e2 = e1; e2; e2 = e2->eq)
2849                     {
2850                       other = e2->expr->symtree->n.sym;
2851                       if (other->common_head
2852                           && other->common_head != sym->common_head)
2853                         {
2854                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
2855                                      "%C is being indirectly equivalenced to "
2856                                      "another COMMON block '%s'",
2857                                      sym->name, sym->common_head->name,
2858                                      other->common_head->name);
2859                             goto cleanup;
2860                         }
2861                       other->attr.in_common = 1;
2862                       other->common_head = t;
2863                     }
2864                 }
2865             }
2866
2867
2868           gfc_gobble_whitespace ();
2869           if (gfc_match_eos () == MATCH_YES)
2870             goto done;
2871           if (gfc_peek_char () == '/')
2872             break;
2873           if (gfc_match_char (',') != MATCH_YES)
2874             goto syntax;
2875           gfc_gobble_whitespace ();
2876           if (gfc_peek_char () == '/')
2877             break;
2878         }
2879     }
2880
2881 done:
2882   return MATCH_YES;
2883
2884 syntax:
2885   gfc_syntax_error (ST_COMMON);
2886
2887 cleanup:
2888   if (old_blank_common)
2889     old_blank_common->common_next = NULL;
2890   else
2891     gfc_current_ns->blank_common.head = NULL;
2892   gfc_free_array_spec (as);
2893   return MATCH_ERROR;
2894 }
2895
2896
2897 /* Match a BLOCK DATA program unit.  */
2898
2899 match
2900 gfc_match_block_data (void)
2901 {
2902   char name[GFC_MAX_SYMBOL_LEN + 1];
2903   gfc_symbol *sym;
2904   match m;
2905
2906   if (gfc_match_eos () == MATCH_YES)
2907     {
2908       gfc_new_block = NULL;
2909       return MATCH_YES;
2910     }
2911
2912   m = gfc_match ("% %n%t", name);
2913   if (m != MATCH_YES)
2914     return MATCH_ERROR;
2915
2916   if (gfc_get_symbol (name, NULL, &sym))
2917     return MATCH_ERROR;
2918
2919   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2920     return MATCH_ERROR;
2921
2922   gfc_new_block = sym;
2923
2924   return MATCH_YES;
2925 }
2926
2927
2928 /* Free a namelist structure.  */
2929
2930 void
2931 gfc_free_namelist (gfc_namelist *name)
2932 {
2933   gfc_namelist *n;
2934
2935   for (; name; name = n)
2936     {
2937       n = name->next;
2938       gfc_free (name);
2939     }
2940 }
2941
2942
2943 /* Match a NAMELIST statement.  */
2944
2945 match
2946 gfc_match_namelist (void)
2947 {
2948   gfc_symbol *group_name, *sym;
2949   gfc_namelist *nl;
2950   match m, m2;
2951
2952   m = gfc_match (" / %s /", &group_name);
2953   if (m == MATCH_NO)
2954     goto syntax;
2955   if (m == MATCH_ERROR)
2956     goto error;
2957
2958   for (;;)
2959     {
2960       if (group_name->ts.type != BT_UNKNOWN)
2961         {
2962           gfc_error ("Namelist group name '%s' at %C already has a basic "
2963                      "type of %s", group_name->name,
2964                      gfc_typename (&group_name->ts));
2965           return MATCH_ERROR;
2966         }
2967
2968       if (group_name->attr.flavor == FL_NAMELIST
2969           && group_name->attr.use_assoc
2970           && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
2971                              "at %C already is USE associated and can"
2972                              "not be respecified.", group_name->name)
2973              == FAILURE)
2974         return MATCH_ERROR;
2975
2976       if (group_name->attr.flavor != FL_NAMELIST
2977           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2978                              group_name->name, NULL) == FAILURE)
2979         return MATCH_ERROR;
2980
2981       for (;;)
2982         {
2983           m = gfc_match_symbol (&sym, 1);
2984           if (m == MATCH_NO)
2985             goto syntax;
2986           if (m == MATCH_ERROR)
2987             goto error;
2988
2989           if (sym->attr.in_namelist == 0
2990               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
2991             goto error;
2992
2993           /* Use gfc_error_check here, rather than goto error, so that
2994              these are the only errors for the next two lines.  */
2995           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
2996             {
2997               gfc_error ("Assumed size array '%s' in namelist '%s' at "
2998                          "%C is not allowed", sym->name, group_name->name);
2999               gfc_error_check ();
3000             }
3001
3002           if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
3003             {
3004               gfc_error ("Assumed character length '%s' in namelist '%s' at "
3005                          "%C is not allowed", sym->name, group_name->name);
3006               gfc_error_check ();
3007             }
3008
3009           nl = gfc_get_namelist ();
3010           nl->sym = sym;
3011           sym->refs++;
3012
3013           if (group_name->namelist == NULL)
3014             group_name->namelist = group_name->namelist_tail = nl;
3015           else
3016             {
3017               group_name->namelist_tail->next = nl;
3018               group_name->namelist_tail = nl;
3019             }
3020
3021           if (gfc_match_eos () == MATCH_YES)
3022             goto done;
3023
3024           m = gfc_match_char (',');
3025
3026           if (gfc_match_char ('/') == MATCH_YES)
3027             {
3028               m2 = gfc_match (" %s /", &group_name);
3029               if (m2 == MATCH_YES)
3030                 break;
3031               if (m2 == MATCH_ERROR)
3032                 goto error;
3033               goto syntax;
3034             }
3035
3036           if (m != MATCH_YES)
3037             goto syntax;
3038         }
3039     }
3040
3041 done:
3042   return MATCH_YES;
3043
3044 syntax:
3045   gfc_syntax_error (ST_NAMELIST);
3046
3047 error:
3048   return MATCH_ERROR;
3049 }
3050
3051
3052 /* Match a MODULE statement.  */
3053
3054 match
3055 gfc_match_module (void)
3056 {
3057   match m;
3058
3059   m = gfc_match (" %s%t", &gfc_new_block);
3060   if (m != MATCH_YES)
3061     return m;
3062
3063   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
3064                       gfc_new_block->name, NULL) == FAILURE)
3065     return MATCH_ERROR;
3066
3067   return MATCH_YES;
3068 }
3069
3070
3071 /* Free equivalence sets and lists.  Recursively is the easiest way to
3072    do this.  */
3073
3074 void
3075 gfc_free_equiv (gfc_equiv *eq)
3076 {
3077   if (eq == NULL)
3078     return;
3079
3080   gfc_free_equiv (eq->eq);
3081   gfc_free_equiv (eq->next);
3082   gfc_free_expr (eq->expr);
3083   gfc_free (eq);
3084 }
3085
3086
3087 /* Match an EQUIVALENCE statement.  */
3088
3089 match
3090 gfc_match_equivalence (void)
3091 {
3092   gfc_equiv *eq, *set, *tail;
3093   gfc_ref *ref;
3094   gfc_symbol *sym;
3095   match m;
3096   gfc_common_head *common_head = NULL;
3097   bool common_flag;
3098   int cnt;
3099
3100   tail = NULL;
3101
3102   for (;;)
3103     {
3104       eq = gfc_get_equiv ();
3105       if (tail == NULL)
3106         tail = eq;
3107
3108       eq->next = gfc_current_ns->equiv;
3109       gfc_current_ns->equiv = eq;
3110
3111       if (gfc_match_char ('(') != MATCH_YES)
3112         goto syntax;
3113
3114       set = eq;
3115       common_flag = FALSE;
3116       cnt = 0;
3117
3118       for (;;)
3119         {
3120           m = gfc_match_equiv_variable (&set->expr);
3121           if (m == MATCH_ERROR)
3122             goto cleanup;
3123           if (m == MATCH_NO)
3124             goto syntax;
3125
3126           /*  count the number of objects.  */
3127           cnt++;
3128
3129           if (gfc_match_char ('%') == MATCH_YES)
3130             {
3131               gfc_error ("Derived type component %C is not a "
3132                          "permitted EQUIVALENCE member");
3133               goto cleanup;
3134             }
3135
3136           for (ref = set->expr->ref; ref; ref = ref->next)
3137             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3138               {
3139                 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3140                            "be an array section");
3141                 goto cleanup;
3142               }
3143
3144           sym = set->expr->symtree->n.sym;
3145
3146           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
3147             goto cleanup;
3148
3149           if (sym->attr.in_common)
3150             {
3151               common_flag = TRUE;
3152               common_head = sym->common_head;
3153             }
3154
3155           if (gfc_match_char (')') == MATCH_YES)
3156             break;
3157
3158           if (gfc_match_char (',') != MATCH_YES)
3159             goto syntax;
3160
3161           set->eq = gfc_get_equiv ();
3162           set = set->eq;
3163         }
3164
3165       if (cnt < 2)
3166         {
3167           gfc_error ("EQUIVALENCE at %C requires two or more objects");
3168           goto cleanup;
3169         }
3170
3171       /* If one of the members of an equivalence is in common, then
3172          mark them all as being in common.  Before doing this, check
3173          that members of the equivalence group are not in different
3174          common blocks.  */
3175       if (common_flag)
3176         for (set = eq; set; set = set->eq)
3177           {
3178             sym = set->expr->symtree->n.sym;
3179             if (sym->common_head && sym->common_head != common_head)
3180               {
3181                 gfc_error ("Attempt to indirectly overlap COMMON "
3182                            "blocks %s and %s by EQUIVALENCE at %C",
3183                            sym->common_head->name, common_head->name);
3184                 goto cleanup;
3185               }
3186             sym->attr.in_common = 1;
3187             sym->common_head = common_head;
3188           }
3189
3190       if (gfc_match_eos () == MATCH_YES)
3191         break;
3192       if (gfc_match_char (',') != MATCH_YES)
3193         goto syntax;
3194     }
3195
3196   return MATCH_YES;
3197
3198 syntax:
3199   gfc_syntax_error (ST_EQUIVALENCE);
3200
3201 cleanup:
3202   eq = tail->next;
3203   tail->next = NULL;
3204
3205   gfc_free_equiv (gfc_current_ns->equiv);
3206   gfc_current_ns->equiv = eq;
3207
3208   return MATCH_ERROR;
3209 }
3210
3211
3212 /* Check that a statement function is not recursive. This is done by looking
3213    for the statement function symbol(sym) by looking recursively through its
3214    expression(e).  If a reference to sym is found, true is returned.
3215    12.5.4 requires that any variable of function that is implicitly typed
3216    shall have that type confirmed by any subsequent type declaration.  The
3217    implicit typing is conveniently done here.  */
3218 static bool
3219 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
3220
3221 static bool
3222 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
3223 {
3224
3225   if (e == NULL)
3226     return false;
3227
3228   switch (e->expr_type)
3229     {
3230     case EXPR_FUNCTION:
3231       if (e->symtree == NULL)
3232         return false;
3233
3234       /* Check the name before testing for nested recursion!  */
3235       if (sym->name == e->symtree->n.sym->name)
3236         return true;
3237
3238       /* Catch recursion via other statement functions.  */
3239       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
3240           && e->symtree->n.sym->value
3241           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
3242         return true;
3243
3244       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3245         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3246
3247       break;
3248
3249     case EXPR_VARIABLE:
3250       if (e->symtree && sym->name == e->symtree->n.sym->name)
3251         return true;
3252
3253       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3254         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3255       break;
3256
3257     default:
3258       break;
3259     }
3260
3261   return false;
3262 }
3263
3264
3265 static bool
3266 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
3267 {
3268   return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
3269 }
3270
3271
3272 /* Match a statement function declaration.  It is so easy to match
3273    non-statement function statements with a MATCH_ERROR as opposed to
3274    MATCH_NO that we suppress error message in most cases.  */
3275
3276 match
3277 gfc_match_st_function (void)
3278 {
3279   gfc_error_buf old_error;
3280   gfc_symbol *sym;
3281   gfc_expr *expr;
3282   match m;
3283
3284   m = gfc_match_symbol (&sym, 0);
3285   if (m != MATCH_YES)
3286     return m;
3287
3288   gfc_push_error (&old_error);
3289
3290   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
3291                          sym->name, NULL) == FAILURE)
3292     goto undo_error;
3293
3294   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
3295     goto undo_error;
3296
3297   m = gfc_match (" = %e%t", &expr);
3298   if (m == MATCH_NO)
3299     goto undo_error;
3300
3301   gfc_free_error (&old_error);
3302   if (m == MATCH_ERROR)
3303     return m;
3304
3305   if (recursive_stmt_fcn (expr, sym))
3306     {
3307       gfc_error ("Statement function at %L is recursive", &expr->where);
3308       return MATCH_ERROR;
3309     }
3310
3311   sym->value = expr;
3312
3313   return MATCH_YES;
3314
3315 undo_error:
3316   gfc_pop_error (&old_error);
3317   return MATCH_NO;
3318 }
3319
3320
3321 /***************** SELECT CASE subroutines ******************/
3322
3323 /* Free a single case structure.  */
3324
3325 static void
3326 free_case (gfc_case *p)
3327 {
3328   if (p->low == p->high)
3329     p->high = NULL;
3330   gfc_free_expr (p->low);
3331   gfc_free_expr (p->high);
3332   gfc_free (p);
3333 }
3334
3335
3336 /* Free a list of case structures.  */
3337
3338 void
3339 gfc_free_case_list (gfc_case *p)
3340 {
3341   gfc_case *q;
3342
3343   for (; p; p = q)
3344     {
3345       q = p->next;
3346       free_case (p);
3347     }
3348 }
3349
3350
3351 /* Match a single case selector.  */
3352
3353 static match
3354 match_case_selector (gfc_case **cp)
3355 {
3356   gfc_case *c;
3357   match m;
3358
3359   c = gfc_get_case ();
3360   c->where = gfc_current_locus;
3361
3362   if (gfc_match_char (':') == MATCH_YES)
3363     {
3364       m = gfc_match_init_expr (&c->high);
3365       if (m == MATCH_NO)
3366         goto need_expr;
3367       if (m == MATCH_ERROR)
3368         goto cleanup;
3369     }
3370   else
3371     {
3372       m = gfc_match_init_expr (&c->low);
3373       if (m == MATCH_ERROR)
3374         goto cleanup;
3375       if (m == MATCH_NO)
3376         goto need_expr;
3377
3378       /* If we're not looking at a ':' now, make a range out of a single
3379          target.  Else get the upper bound for the case range.  */
3380       if (gfc_match_char (':') != MATCH_YES)
3381         c->high = c->low;
3382       else
3383         {
3384           m = gfc_match_init_expr (&c->high);
3385           if (m == MATCH_ERROR)
3386             goto cleanup;
3387           /* MATCH_NO is fine.  It's OK if nothing is there!  */
3388         }
3389     }
3390
3391   *cp = c;
3392   return MATCH_YES;
3393
3394 need_expr:
3395   gfc_error ("Expected initialization expression in CASE at %C");
3396
3397 cleanup:
3398   free_case (c);
3399   return MATCH_ERROR;
3400 }
3401
3402
3403 /* Match the end of a case statement.  */
3404
3405 static match
3406 match_case_eos (void)
3407 {
3408   char name[GFC_MAX_SYMBOL_LEN + 1];
3409   match m;
3410
3411   if (gfc_match_eos () == MATCH_YES)
3412     return MATCH_YES;
3413
3414   /* If the case construct doesn't have a case-construct-name, we
3415      should have matched the EOS.  */
3416   if (!gfc_current_block ())
3417     {
3418       gfc_error ("Expected the name of the SELECT CASE construct at %C");
3419       return MATCH_ERROR;
3420     }
3421
3422   gfc_gobble_whitespace ();
3423
3424   m = gfc_match_name (name);
3425   if (m != MATCH_YES)
3426     return m;
3427
3428   if (strcmp (name, gfc_current_block ()->name) != 0)
3429     {
3430       gfc_error ("Expected case name of '%s' at %C",
3431                  gfc_current_block ()->name);
3432       return MATCH_ERROR;
3433     }
3434
3435   return gfc_match_eos ();
3436 }
3437
3438
3439 /* Match a SELECT statement.  */
3440
3441 match
3442 gfc_match_select (void)
3443 {
3444   gfc_expr *expr;
3445   match m;
3446
3447   m = gfc_match_label ();
3448   if (m == MATCH_ERROR)
3449     return m;
3450
3451   m = gfc_match (" select case ( %e )%t", &expr);
3452   if (m != MATCH_YES)
3453     return m;
3454
3455   new_st.op = EXEC_SELECT;
3456   new_st.expr = expr;
3457
3458   return MATCH_YES;
3459 }
3460
3461
3462 /* Match a CASE statement.  */
3463
3464 match
3465 gfc_match_case (void)
3466 {
3467   gfc_case *c, *head, *tail;
3468   match m;
3469
3470   head = tail = NULL;
3471
3472   if (gfc_current_state () != COMP_SELECT)
3473     {
3474       gfc_error ("Unexpected CASE statement at %C");
3475       return MATCH_ERROR;
3476     }
3477
3478   if (gfc_match ("% default") == MATCH_YES)
3479     {
3480       m = match_case_eos ();
3481       if (m == MATCH_NO)
3482         goto syntax;
3483       if (m == MATCH_ERROR)
3484         goto cleanup;
3485
3486       new_st.op = EXEC_SELECT;
3487       c = gfc_get_case ();
3488       c->where = gfc_current_locus;
3489       new_st.ext.case_list = c;
3490       return MATCH_YES;
3491     }
3492
3493   if (gfc_match_char ('(') != MATCH_YES)
3494     goto syntax;
3495
3496   for (;;)
3497     {
3498       if (match_case_selector (&c) == MATCH_ERROR)
3499         goto cleanup;
3500
3501       if (head == NULL)
3502         head = c;
3503       else
3504         tail->next = c;
3505
3506       tail = c;
3507
3508       if (gfc_match_char (')') == MATCH_YES)
3509         break;
3510       if (gfc_match_char (',') != MATCH_YES)
3511         goto syntax;
3512     }
3513
3514   m = match_case_eos ();
3515   if (m == MATCH_NO)
3516     goto syntax;
3517   if (m == MATCH_ERROR)
3518     goto cleanup;
3519
3520   new_st.op = EXEC_SELECT;
3521   new_st.ext.case_list = head;
3522
3523   return MATCH_YES;
3524
3525 syntax:
3526   gfc_error ("Syntax error in CASE-specification at %C");
3527
3528 cleanup:
3529   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
3530   return MATCH_ERROR;
3531 }
3532
3533 /********************* WHERE subroutines ********************/
3534
3535 /* Match the rest of a simple WHERE statement that follows an IF statement.
3536  */
3537
3538 static match
3539 match_simple_where (void)
3540 {
3541   gfc_expr *expr;
3542   gfc_code *c;
3543   match m;
3544
3545   m = gfc_match (" ( %e )", &expr);
3546   if (m != MATCH_YES)
3547     return m;
3548
3549   m = gfc_match_assignment ();
3550   if (m == MATCH_NO)
3551     goto syntax;
3552   if (m == MATCH_ERROR)
3553     goto cleanup;
3554
3555   if (gfc_match_eos () != MATCH_YES)
3556     goto syntax;
3557
3558   c = gfc_get_code ();
3559
3560   c->op = EXEC_WHERE;
3561   c->expr = expr;
3562   c->next = gfc_get_code ();
3563
3564   *c->next = new_st;
3565   gfc_clear_new_st ();
3566
3567   new_st.op = EXEC_WHERE;
3568   new_st.block = c;
3569
3570   return MATCH_YES;
3571
3572 syntax:
3573   gfc_syntax_error (ST_WHERE);
3574
3575 cleanup:
3576   gfc_free_expr (expr);
3577   return MATCH_ERROR;
3578 }
3579
3580
3581 /* Match a WHERE statement.  */
3582
3583 match
3584 gfc_match_where (gfc_statement *st)
3585 {
3586   gfc_expr *expr;
3587   match m0, m;
3588   gfc_code *c;
3589
3590   m0 = gfc_match_label ();
3591   if (m0 == MATCH_ERROR)
3592     return m0;
3593
3594   m = gfc_match (" where ( %e )", &expr);
3595   if (m != MATCH_YES)
3596     return m;
3597
3598   if (gfc_match_eos () == MATCH_YES)
3599     {
3600       *st = ST_WHERE_BLOCK;
3601       new_st.op = EXEC_WHERE;
3602       new_st.expr = expr;
3603       return MATCH_YES;
3604     }
3605
3606   m = gfc_match_assignment ();
3607   if (m == MATCH_NO)
3608     gfc_syntax_error (ST_WHERE);
3609
3610   if (m != MATCH_YES)
3611     {
3612       gfc_free_expr (expr);
3613       return MATCH_ERROR;
3614     }
3615
3616   /* We've got a simple WHERE statement.  */
3617   *st = ST_WHERE;
3618   c = gfc_get_code ();
3619
3620   c->op = EXEC_WHERE;
3621   c->expr = expr;
3622   c->next = gfc_get_code ();
3623
3624   *c->next = new_st;
3625   gfc_clear_new_st ();
3626
3627   new_st.op = EXEC_WHERE;
3628   new_st.block = c;
3629
3630   return MATCH_YES;
3631 }
3632
3633
3634 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
3635    new_st if successful.  */
3636
3637 match
3638 gfc_match_elsewhere (void)
3639 {
3640   char name[GFC_MAX_SYMBOL_LEN + 1];
3641   gfc_expr *expr;
3642   match m;
3643
3644   if (gfc_current_state () != COMP_WHERE)
3645     {
3646       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3647       return MATCH_ERROR;
3648     }
3649
3650   expr = NULL;
3651
3652   if (gfc_match_char ('(') == MATCH_YES)
3653     {
3654       m = gfc_match_expr (&expr);
3655       if (m == MATCH_NO)
3656         goto syntax;
3657       if (m == MATCH_ERROR)
3658         return MATCH_ERROR;
3659
3660       if (gfc_match_char (')') != MATCH_YES)
3661         goto syntax;
3662     }
3663
3664   if (gfc_match_eos () != MATCH_YES)
3665     {
3666       /* Only makes sense if we have a where-construct-name.  */
3667       if (!gfc_current_block ())
3668         {
3669           m = MATCH_ERROR;
3670           goto cleanup;
3671         }
3672       /* Better be a name at this point.  */
3673       m = gfc_match_name (name);
3674       if (m == MATCH_NO)
3675         goto syntax;
3676       if (m == MATCH_ERROR)
3677         goto cleanup;
3678
3679       if (gfc_match_eos () != MATCH_YES)
3680         goto syntax;
3681
3682       if (strcmp (name, gfc_current_block ()->name) != 0)
3683         {
3684           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3685                      name, gfc_current_block ()->name);
3686           goto cleanup;
3687         }
3688     }
3689
3690   new_st.op = EXEC_WHERE;
3691   new_st.expr = expr;
3692   return MATCH_YES;
3693
3694 syntax:
3695   gfc_syntax_error (ST_ELSEWHERE);
3696
3697 cleanup:
3698   gfc_free_expr (expr);
3699   return MATCH_ERROR;
3700 }
3701
3702
3703 /******************** FORALL subroutines ********************/
3704
3705 /* Free a list of FORALL iterators.  */
3706
3707 void
3708 gfc_free_forall_iterator (gfc_forall_iterator *iter)
3709 {
3710   gfc_forall_iterator *next;
3711
3712   while (iter)
3713     {
3714       next = iter->next;
3715       gfc_free_expr (iter->var);
3716       gfc_free_expr (iter->start);
3717       gfc_free_expr (iter->end);
3718       gfc_free_expr (iter->stride);
3719       gfc_free (iter);
3720       iter = next;
3721     }
3722 }
3723
3724
3725 /* Match an iterator as part of a FORALL statement.  The format is:
3726
3727      <var> = <start>:<end>[:<stride>]
3728
3729    On MATCH_NO, the caller tests for the possibility that there is a
3730    scalar mask expression.  */
3731
3732 static match
3733 match_forall_iterator (gfc_forall_iterator **result)
3734 {
3735   gfc_forall_iterator *iter;
3736   locus where;
3737   match m;
3738
3739   where = gfc_current_locus;
3740   iter = gfc_getmem (sizeof (gfc_forall_iterator));
3741
3742   m = gfc_match_expr (&iter->var);
3743   if (m != MATCH_YES)
3744     goto cleanup;
3745
3746   if (gfc_match_char ('=') != MATCH_YES
3747       || iter->var->expr_type != EXPR_VARIABLE)
3748     {
3749       m = MATCH_NO;
3750       goto cleanup;
3751     }
3752
3753   m = gfc_match_expr (&iter->start);
3754   if (m != MATCH_YES)
3755     goto cleanup;
3756
3757   if (gfc_match_char (':') != MATCH_YES)
3758     goto syntax;
3759
3760   m = gfc_match_expr (&iter->end);
3761   if (m == MATCH_NO)
3762     goto syntax;
3763   if (m == MATCH_ERROR)
3764     goto cleanup;
3765
3766   if (gfc_match_char (':') == MATCH_NO)
3767     iter->stride = gfc_int_expr (1);
3768   else
3769     {
3770       m = gfc_match_expr (&iter->stride);
3771       if (m == MATCH_NO)
3772         goto syntax;
3773       if (m == MATCH_ERROR)
3774         goto cleanup;
3775     }
3776
3777   /* Mark the iteration variable's symbol as used as a FORALL index.  */
3778   iter->var->symtree->n.sym->forall_index = true;
3779
3780   *result = iter;
3781   return MATCH_YES;
3782
3783 syntax:
3784   gfc_error ("Syntax error in FORALL iterator at %C");
3785   m = MATCH_ERROR;
3786
3787 cleanup:
3788
3789   gfc_current_locus = where;
3790   gfc_free_forall_iterator (iter);
3791   return m;
3792 }
3793
3794
3795 /* Match the header of a FORALL statement.  */
3796
3797 static match
3798 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
3799 {
3800   gfc_forall_iterator *head, *tail, *new;
3801   gfc_expr *msk;
3802   match m;
3803
3804   gfc_gobble_whitespace ();
3805
3806   head = tail = NULL;
3807   msk = NULL;
3808
3809   if (gfc_match_char ('(') != MATCH_YES)
3810     return MATCH_NO;
3811
3812   m = match_forall_iterator (&new);
3813   if (m == MATCH_ERROR)
3814     goto cleanup;
3815   if (m == MATCH_NO)
3816     goto syntax;
3817
3818   head = tail = new;
3819
3820   for (;;)
3821     {
3822       if (gfc_match_char (',') != MATCH_YES)
3823         break;
3824
3825       m = match_forall_iterator (&new);
3826       if (m == MATCH_ERROR)
3827         goto cleanup;
3828
3829       if (m == MATCH_YES)
3830         {
3831           tail->next = new;
3832           tail = new;
3833           continue;
3834         }
3835
3836       /* Have to have a mask expression.  */
3837
3838       m = gfc_match_expr (&msk);
3839       if (m == MATCH_NO)
3840         goto syntax;
3841       if (m == MATCH_ERROR)
3842         goto cleanup;
3843
3844       break;
3845     }
3846
3847   if (gfc_match_char (')') == MATCH_NO)
3848     goto syntax;
3849
3850   *phead = head;
3851   *mask = msk;
3852   return MATCH_YES;
3853
3854 syntax:
3855   gfc_syntax_error (ST_FORALL);
3856
3857 cleanup:
3858   gfc_free_expr (msk);
3859   gfc_free_forall_iterator (head);
3860
3861   return MATCH_ERROR;
3862 }
3863
3864 /* Match the rest of a simple FORALL statement that follows an
3865    IF statement.  */
3866
3867 static match
3868 match_simple_forall (void)
3869 {
3870   gfc_forall_iterator *head;
3871   gfc_expr *mask;
3872   gfc_code *c;
3873   match m;
3874
3875   mask = NULL;
3876   head = NULL;
3877   c = NULL;
3878
3879   m = match_forall_header (&head, &mask);
3880
3881   if (m == MATCH_NO)
3882     goto syntax;
3883   if (m != MATCH_YES)
3884     goto cleanup;
3885
3886   m = gfc_match_assignment ();
3887
3888   if (m == MATCH_ERROR)
3889     goto cleanup;
3890   if (m == MATCH_NO)
3891     {
3892       m = gfc_match_pointer_assignment ();
3893       if (m == MATCH_ERROR)
3894         goto cleanup;
3895       if (m == MATCH_NO)
3896         goto syntax;
3897     }
3898
3899   c = gfc_get_code ();
3900   *c = new_st;
3901   c->loc = gfc_current_locus;
3902
3903   if (gfc_match_eos () != MATCH_YES)
3904     goto syntax;
3905
3906   gfc_clear_new_st ();
3907   new_st.op = EXEC_FORALL;
3908   new_st.expr = mask;
3909   new_st.ext.forall_iterator = head;
3910   new_st.block = gfc_get_code ();
3911
3912   new_st.block->op = EXEC_FORALL;
3913   new_st.block->next = c;
3914
3915   return MATCH_YES;
3916
3917 syntax:
3918   gfc_syntax_error (ST_FORALL);
3919
3920 cleanup:
3921   gfc_free_forall_iterator (head);
3922   gfc_free_expr (mask);
3923
3924   return MATCH_ERROR;
3925 }
3926
3927
3928 /* Match a FORALL statement.  */
3929
3930 match
3931 gfc_match_forall (gfc_statement *st)
3932 {
3933   gfc_forall_iterator *head;
3934   gfc_expr *mask;
3935   gfc_code *c;
3936   match m0, m;
3937
3938   head = NULL;
3939   mask = NULL;
3940   c = NULL;
3941
3942   m0 = gfc_match_label ();
3943   if (m0 == MATCH_ERROR)
3944     return MATCH_ERROR;
3945
3946   m = gfc_match (" forall");
3947   if (m != MATCH_YES)
3948     return m;
3949
3950   m = match_forall_header (&head, &mask);
3951   if (m == MATCH_ERROR)
3952     goto cleanup;
3953   if (m == MATCH_NO)
3954     goto syntax;
3955
3956   if (gfc_match_eos () == MATCH_YES)
3957     {
3958       *st = ST_FORALL_BLOCK;
3959       new_st.op = EXEC_FORALL;
3960       new_st.expr = mask;
3961       new_st.ext.forall_iterator = head;
3962       return MATCH_YES;
3963     }
3964
3965   m = gfc_match_assignment ();
3966   if (m == MATCH_ERROR)
3967     goto cleanup;
3968   if (m == MATCH_NO)
3969     {
3970       m = gfc_match_pointer_assignment ();
3971       if (m == MATCH_ERROR)
3972         goto cleanup;
3973       if (m == MATCH_NO)
3974         goto syntax;
3975     }
3976
3977   c = gfc_get_code ();
3978   *c = new_st;
3979   c->loc = gfc_current_locus;
3980
3981   gfc_clear_new_st ();
3982   new_st.op = EXEC_FORALL;
3983   new_st.expr = mask;
3984   new_st.ext.forall_iterator = head;
3985   new_st.block = gfc_get_code ();
3986   new_st.block->op = EXEC_FORALL;
3987   new_st.block->next = c;
3988
3989   *st = ST_FORALL;
3990   return MATCH_YES;
3991
3992 syntax:
3993   gfc_syntax_error (ST_FORALL);
3994
3995 cleanup:
3996   gfc_free_forall_iterator (head);
3997   gfc_free_expr (mask);
3998   gfc_free_statements (c);
3999   return MATCH_NO;
4000 }