gcc/fortran/match.c

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