gcc/fortran/match.c

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