gcc/fortran/match.c

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