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