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, false))
 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.expr1 = 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_is_proc_ptr_comp (lvalue, NULL))
1341     gfc_matching_procptr_assignment = 1;
1342
1343   m = gfc_match (" %e%t", &rvalue);
1344   gfc_matching_procptr_assignment = 0;
1345   if (m != MATCH_YES)
1346     goto cleanup;
1347
1348   new_st.op = EXEC_POINTER_ASSIGN;
1349   new_st.expr1 = lvalue;
1350   new_st.expr2 = rvalue;
1351
1352   return MATCH_YES;
1353
1354 cleanup:
1355   gfc_current_locus = old_loc;
1356   gfc_free_expr (lvalue);
1357   gfc_free_expr (rvalue);
1358   return m;
1359 }
1360
1361
1362 /* We try to match an easy arithmetic IF statement. This only happens
1363    when just after having encountered a simple IF statement. This code
1364    is really duplicate with parts of the gfc_match_if code, but this is
1365    *much* easier.  */
1366
1367 static match
1368 match_arithmetic_if (void)
1369 {
1370   gfc_st_label *l1, *l2, *l3;
1371   gfc_expr *expr;
1372   match m;
1373
1374   m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
1375   if (m != MATCH_YES)
1376     return m;
1377
1378   if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1379       || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1380       || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1381     {
1382       gfc_free_expr (expr);
1383       return MATCH_ERROR;
1384     }
1385
1386   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
1387                       "statement at %C") == FAILURE)
1388     return MATCH_ERROR;
1389
1390   new_st.op = EXEC_ARITHMETIC_IF;
1391   new_st.expr1 = expr;
1392   new_st.label1 = l1;
1393   new_st.label2 = l2;
1394   new_st.label3 = l3;
1395
1396   return MATCH_YES;
1397 }
1398
1399
1400 /* The IF statement is a bit of a pain.  First of all, there are three
1401    forms of it, the simple IF, the IF that starts a block and the
1402    arithmetic IF.
1403
1404    There is a problem with the simple IF and that is the fact that we
1405    only have a single level of undo information on symbols.  What this
1406    means is for a simple IF, we must re-match the whole IF statement
1407    multiple times in order to guarantee that the symbol table ends up
1408    in the proper state.  */
1409
1410 static match match_simple_forall (void);
1411 static match match_simple_where (void);
1412
1413 match
1414 gfc_match_if (gfc_statement *if_type)
1415 {
1416   gfc_expr *expr;
1417   gfc_st_label *l1, *l2, *l3;
1418   locus old_loc, old_loc2;
1419   gfc_code *p;
1420   match m, n;
1421
1422   n = gfc_match_label ();
1423   if (n == MATCH_ERROR)
1424     return n;
1425
1426   old_loc = gfc_current_locus;
1427
1428   m = gfc_match (" if ( %e", &expr);
1429   if (m != MATCH_YES)
1430     return m;
1431
1432   old_loc2 = gfc_current_locus;
1433   gfc_current_locus = old_loc;
1434
1435   if (gfc_match_parens () == MATCH_ERROR)
1436     return MATCH_ERROR;
1437
1438   gfc_current_locus = old_loc2;
1439
1440   if (gfc_match_char (')') != MATCH_YES)
1441     {
1442       gfc_error ("Syntax error in IF-expression at %C");
1443       gfc_free_expr (expr);
1444       return MATCH_ERROR;
1445     }
1446
1447   m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1448
1449   if (m == MATCH_YES)
1450     {
1451       if (n == MATCH_YES)
1452         {
1453           gfc_error ("Block label not appropriate for arithmetic IF "
1454                      "statement at %C");
1455           gfc_free_expr (expr);
1456           return MATCH_ERROR;
1457         }
1458
1459       if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1460           || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1461           || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1462         {
1463           gfc_free_expr (expr);
1464           return MATCH_ERROR;
1465         }
1466
1467       if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
1468                           "statement at %C") == FAILURE)
1469         return MATCH_ERROR;
1470
1471       new_st.op = EXEC_ARITHMETIC_IF;
1472       new_st.expr1 = expr;
1473       new_st.label1 = l1;
1474       new_st.label2 = l2;
1475       new_st.label3 = l3;
1476
1477       *if_type = ST_ARITHMETIC_IF;
1478       return MATCH_YES;
1479     }
1480
1481   if (gfc_match (" then%t") == MATCH_YES)
1482     {
1483       new_st.op = EXEC_IF;
1484       new_st.expr1 = expr;
1485       *if_type = ST_IF_BLOCK;
1486       return MATCH_YES;
1487     }
1488
1489   if (n == MATCH_YES)
1490     {
1491       gfc_error ("Block label is not appropriate for IF statement at %C");
1492       gfc_free_expr (expr);
1493       return MATCH_ERROR;
1494     }
1495
1496   /* At this point the only thing left is a simple IF statement.  At
1497      this point, n has to be MATCH_NO, so we don't have to worry about
1498      re-matching a block label.  From what we've got so far, try
1499      matching an assignment.  */
1500
1501   *if_type = ST_SIMPLE_IF;
1502
1503   m = gfc_match_assignment ();
1504   if (m == MATCH_YES)
1505     goto got_match;
1506
1507   gfc_free_expr (expr);
1508   gfc_undo_symbols ();
1509   gfc_current_locus = old_loc;
1510
1511   /* m can be MATCH_NO or MATCH_ERROR, here.  For MATCH_ERROR, a mangled
1512      assignment was found.  For MATCH_NO, continue to call the various
1513      matchers.  */
1514   if (m == MATCH_ERROR)
1515     return MATCH_ERROR;
1516
1517   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */
1518
1519   m = gfc_match_pointer_assignment ();
1520   if (m == MATCH_YES)
1521     goto got_match;
1522
1523   gfc_free_expr (expr);
1524   gfc_undo_symbols ();
1525   gfc_current_locus = old_loc;
1526
1527   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */
1528
1529   /* Look at the next keyword to see which matcher to call.  Matching
1530      the keyword doesn't affect the symbol table, so we don't have to
1531      restore between tries.  */
1532
1533 #define match(string, subr, statement) \
1534   if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1535
1536   gfc_clear_error ();
1537
1538   match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1539   match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1540   match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1541   match ("call", gfc_match_call, ST_CALL)
1542   match ("close", gfc_match_close, ST_CLOSE)
1543   match ("continue", gfc_match_continue, ST_CONTINUE)
1544   match ("cycle", gfc_match_cycle, ST_CYCLE)
1545   match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1546   match ("end file", gfc_match_endfile, ST_END_FILE)
1547   match ("exit", gfc_match_exit, ST_EXIT)
1548   match ("flush", gfc_match_flush, ST_FLUSH)
1549   match ("forall", match_simple_forall, ST_FORALL)
1550   match ("go to", gfc_match_goto, ST_GOTO)
1551   match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1552   match ("inquire", gfc_match_inquire, ST_INQUIRE)
1553   match ("nullify", gfc_match_nullify, ST_NULLIFY)
1554   match ("open", gfc_match_open, ST_OPEN)
1555   match ("pause", gfc_match_pause, ST_NONE)
1556   match ("print", gfc_match_print, ST_WRITE)
1557   match ("read", gfc_match_read, ST_READ)
1558   match ("return", gfc_match_return, ST_RETURN)
1559   match ("rewind", gfc_match_rewind, ST_REWIND)
1560   match ("stop", gfc_match_stop, ST_STOP)
1561   match ("wait", gfc_match_wait, ST_WAIT)
1562   match ("where", match_simple_where, ST_WHERE)
1563   match ("write", gfc_match_write, ST_WRITE)
1564
1565   /* The gfc_match_assignment() above may have returned a MATCH_NO
1566      where the assignment was to a named constant.  Check that
1567      special case here.  */
1568   m = gfc_match_assignment ();
1569   if (m == MATCH_NO)
1570    {
1571       gfc_error ("Cannot assign to a named constant at %C");
1572       gfc_free_expr (expr);
1573       gfc_undo_symbols ();
1574       gfc_current_locus = old_loc;
1575       return MATCH_ERROR;
1576    }
1577
1578   /* All else has failed, so give up.  See if any of the matchers has
1579      stored an error message of some sort.  */
1580   if (gfc_error_check () == 0)
1581     gfc_error ("Unclassifiable statement in IF-clause at %C");
1582
1583   gfc_free_expr (expr);
1584   return MATCH_ERROR;
1585
1586 got_match:
1587   if (m == MATCH_NO)
1588     gfc_error ("Syntax error in IF-clause at %C");
1589   if (m != MATCH_YES)
1590     {
1591       gfc_free_expr (expr);
1592       return MATCH_ERROR;
1593     }
1594
1595   /* At this point, we've matched the single IF and the action clause
1596      is in new_st.  Rearrange things so that the IF statement appears
1597      in new_st.  */
1598
1599   p = gfc_get_code ();
1600   p->next = gfc_get_code ();
1601   *p->next = new_st;
1602   p->next->loc = gfc_current_locus;
1603
1604   p->expr1 = expr;
1605   p->op = EXEC_IF;
1606
1607   gfc_clear_new_st ();
1608
1609   new_st.op = EXEC_IF;
1610   new_st.block = p;
1611
1612   return MATCH_YES;
1613 }
1614
1615 #undef match
1616
1617
1618 /* Match an ELSE statement.  */
1619
1620 match
1621 gfc_match_else (void)
1622 {
1623   char name[GFC_MAX_SYMBOL_LEN + 1];
1624
1625   if (gfc_match_eos () == MATCH_YES)
1626     return MATCH_YES;
1627
1628   if (gfc_match_name (name) != MATCH_YES
1629       || gfc_current_block () == NULL
1630       || gfc_match_eos () != MATCH_YES)
1631     {
1632       gfc_error ("Unexpected junk after ELSE statement at %C");
1633       return MATCH_ERROR;
1634     }
1635
1636   if (strcmp (name, gfc_current_block ()->name) != 0)
1637     {
1638       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1639                  name, gfc_current_block ()->name);
1640       return MATCH_ERROR;
1641     }
1642
1643   return MATCH_YES;
1644 }
1645
1646
1647 /* Match an ELSE IF statement.  */
1648
1649 match
1650 gfc_match_elseif (void)
1651 {
1652   char name[GFC_MAX_SYMBOL_LEN + 1];
1653   gfc_expr *expr;
1654   match m;
1655
1656   m = gfc_match (" ( %e ) then", &expr);
1657   if (m != MATCH_YES)
1658     return m;
1659
1660   if (gfc_match_eos () == MATCH_YES)
1661     goto done;
1662
1663   if (gfc_match_name (name) != MATCH_YES
1664       || gfc_current_block () == NULL
1665       || gfc_match_eos () != MATCH_YES)
1666     {
1667       gfc_error ("Unexpected junk after ELSE IF statement at %C");
1668       goto cleanup;
1669     }
1670
1671   if (strcmp (name, gfc_current_block ()->name) != 0)
1672     {
1673       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1674                  name, gfc_current_block ()->name);
1675       goto cleanup;
1676     }
1677
1678 done:
1679   new_st.op = EXEC_IF;
1680   new_st.expr1 = expr;
1681   return MATCH_YES;
1682
1683 cleanup:
1684   gfc_free_expr (expr);
1685   return MATCH_ERROR;
1686 }
1687
1688
1689 /* Free a gfc_iterator structure.  */
1690
1691 void
1692 gfc_free_iterator (gfc_iterator *iter, int flag)
1693 {
1694
1695   if (iter == NULL)
1696     return;
1697
1698   gfc_free_expr (iter->var);
1699   gfc_free_expr (iter->start);
1700   gfc_free_expr (iter->end);
1701   gfc_free_expr (iter->step);
1702
1703   if (flag)
1704     gfc_free (iter);
1705 }
1706
1707
1708 /* Match a BLOCK statement.  */
1709
1710 match
1711 gfc_match_block (void)
1712 {
1713   match m;
1714
1715   if (gfc_match_label () == MATCH_ERROR)
1716     return MATCH_ERROR;
1717
1718   if (gfc_match (" block") != MATCH_YES)
1719     return MATCH_NO;
1720
1721   /* For this to be a correct BLOCK statement, the line must end now.  */
1722   m = gfc_match_eos ();
1723   if (m == MATCH_ERROR)
1724     return MATCH_ERROR;
1725   if (m == MATCH_NO)
1726     return MATCH_NO;
1727
1728   return MATCH_YES;
1729 }
1730
1731
1732 /* Match a DO statement.  */
1733
1734 match
1735 gfc_match_do (void)
1736 {
1737   gfc_iterator iter, *ip;
1738   locus old_loc;
1739   gfc_st_label *label;
1740   match m;
1741
1742   old_loc = gfc_current_locus;
1743
1744   label = NULL;
1745   iter.var = iter.start = iter.end = iter.step = NULL;
1746
1747   m = gfc_match_label ();
1748   if (m == MATCH_ERROR)
1749     return m;
1750
1751   if (gfc_match (" do") != MATCH_YES)
1752     return MATCH_NO;
1753
1754   m = gfc_match_st_label (&label);
1755   if (m == MATCH_ERROR)
1756     goto cleanup;
1757
1758   /* Match an infinite DO, make it like a DO WHILE(.TRUE.).  */
1759
1760   if (gfc_match_eos () == MATCH_YES)
1761     {
1762       iter.end = gfc_logical_expr (1, NULL);
1763       new_st.op = EXEC_DO_WHILE;
1764       goto done;
1765     }
1766
1767   /* Match an optional comma, if no comma is found, a space is obligatory.  */
1768   if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
1769     return MATCH_NO;
1770
1771   /* Check for balanced parens.  */
1772
1773   if (gfc_match_parens () == MATCH_ERROR)
1774     return MATCH_ERROR;
1775
1776   /* See if we have a DO WHILE.  */
1777   if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1778     {
1779       new_st.op = EXEC_DO_WHILE;
1780       goto done;
1781     }
1782
1783   /* The abortive DO WHILE may have done something to the symbol
1784      table, so we start over.  */
1785   gfc_undo_symbols ();
1786   gfc_current_locus = old_loc;
1787
1788   gfc_match_label ();           /* This won't error.  */
1789   gfc_match (" do ");           /* This will work.  */
1790
1791   gfc_match_st_label (&label);  /* Can't error out.  */
1792   gfc_match_char (',');         /* Optional comma.  */
1793
1794   m = gfc_match_iterator (&iter, 0);
1795   if (m == MATCH_NO)
1796     return MATCH_NO;
1797   if (m == MATCH_ERROR)
1798     goto cleanup;
1799
1800   iter.var->symtree->n.sym->attr.implied_index = 0;
1801   gfc_check_do_variable (iter.var->symtree);
1802
1803   if (gfc_match_eos () != MATCH_YES)
1804     {
1805       gfc_syntax_error (ST_DO);
1806       goto cleanup;
1807     }
1808
1809   new_st.op = EXEC_DO;
1810
1811 done:
1812   if (label != NULL
1813       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1814     goto cleanup;
1815
1816   new_st.label1 = label;
1817
1818   if (new_st.op == EXEC_DO_WHILE)
1819     new_st.expr1 = iter.end;
1820   else
1821     {
1822       new_st.ext.iterator = ip = gfc_get_iterator ();
1823       *ip = iter;
1824     }
1825
1826   return MATCH_YES;
1827
1828 cleanup:
1829   gfc_free_iterator (&iter, 0);
1830
1831   return MATCH_ERROR;
1832 }
1833
1834
1835 /* Match an EXIT or CYCLE statement.  */
1836
1837 static match
1838 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1839 {
1840   gfc_state_data *p, *o;
1841   gfc_symbol *sym;
1842   match m;
1843
1844   if (gfc_match_eos () == MATCH_YES)
1845     sym = NULL;
1846   else
1847     {
1848       m = gfc_match ("% %s%t", &sym);
1849       if (m == MATCH_ERROR)
1850         return MATCH_ERROR;
1851       if (m == MATCH_NO)
1852         {
1853           gfc_syntax_error (st);
1854           return MATCH_ERROR;
1855         }
1856
1857       if (sym->attr.flavor != FL_LABEL)
1858         {
1859           gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1860                      sym->name, gfc_ascii_statement (st));
1861           return MATCH_ERROR;
1862         }
1863     }
1864
1865   /* Find the loop mentioned specified by the label (or lack of a label).  */
1866   for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1867     if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1868       break;
1869     else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1870       o = p;
1871
1872   if (p == NULL)
1873     {
1874       if (sym == NULL)
1875         gfc_error ("%s statement at %C is not within a loop",
1876                    gfc_ascii_statement (st));
1877       else
1878         gfc_error ("%s statement at %C is not within loop '%s'",
1879                    gfc_ascii_statement (st), sym->name);
1880
1881       return MATCH_ERROR;
1882     }
1883
1884   if (o != NULL)
1885     {
1886       gfc_error ("%s statement at %C leaving OpenMP structured block",
1887                  gfc_ascii_statement (st));
1888       return MATCH_ERROR;
1889     }
1890   else if (st == ST_EXIT
1891            && p->previous != NULL
1892            && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1893            && (p->previous->head->op == EXEC_OMP_DO
1894                || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1895     {
1896       gcc_assert (p->previous->head->next != NULL);
1897       gcc_assert (p->previous->head->next->op == EXEC_DO
1898                   || p->previous->head->next->op == EXEC_DO_WHILE);
1899       gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1900       return MATCH_ERROR;
1901     }
1902
1903   /* Save the first statement in the loop - needed by the backend.  */
1904   new_st.ext.whichloop = p->head;
1905
1906   new_st.op = op;
1907
1908   return MATCH_YES;
1909 }
1910
1911
1912 /* Match the EXIT statement.  */
1913
1914 match
1915 gfc_match_exit (void)
1916 {
1917   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1918 }
1919
1920
1921 /* Match the CYCLE statement.  */
1922
1923 match
1924 gfc_match_cycle (void)
1925 {
1926   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1927 }
1928
1929
1930 /* Match a number or character constant after a STOP or PAUSE statement.  */
1931
1932 static match
1933 gfc_match_stopcode (gfc_statement st)
1934 {
1935   int stop_code;
1936   gfc_expr *e;
1937   match m;
1938   int cnt;
1939
1940   stop_code = -1;
1941   e = NULL;
1942
1943   if (gfc_match_eos () != MATCH_YES)
1944     {
1945       m = gfc_match_small_literal_int (&stop_code, &cnt);
1946       if (m == MATCH_ERROR)
1947         goto cleanup;
1948
1949       if (m == MATCH_YES && cnt > 5)
1950         {
1951           gfc_error ("Too many digits in STOP code at %C");
1952           goto cleanup;
1953         }
1954
1955       if (m == MATCH_NO)
1956         {
1957           /* Try a character constant.  */
1958           m = gfc_match_expr (&e);
1959           if (m == MATCH_ERROR)
1960             goto cleanup;
1961           if (m == MATCH_NO)
1962             goto syntax;
1963           if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1964             goto syntax;
1965         }
1966
1967       if (gfc_match_eos () != MATCH_YES)
1968         goto syntax;
1969     }
1970
1971   if (gfc_pure (NULL))
1972     {
1973       gfc_error ("%s statement not allowed in PURE procedure at %C",
1974                  gfc_ascii_statement (st));
1975       goto cleanup;
1976     }
1977
1978   new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1979   new_st.expr1 = e;
1980   new_st.ext.stop_code = stop_code;
1981
1982   return MATCH_YES;
1983
1984 syntax:
1985   gfc_syntax_error (st);
1986
1987 cleanup:
1988
1989   gfc_free_expr (e);
1990   return MATCH_ERROR;
1991 }
1992
1993
1994 /* Match the (deprecated) PAUSE statement.  */
1995
1996 match
1997 gfc_match_pause (void)
1998 {
1999   match m;
2000
2001   m = gfc_match_stopcode (ST_PAUSE);
2002   if (m == MATCH_YES)
2003     {
2004       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
2005           " at %C")
2006           == FAILURE)
2007         m = MATCH_ERROR;
2008     }
2009   return m;
2010 }
2011
2012
2013 /* Match the STOP statement.  */
2014
2015 match
2016 gfc_match_stop (void)
2017 {
2018   return gfc_match_stopcode (ST_STOP);
2019 }
2020
2021
2022 /* Match a CONTINUE statement.  */
2023
2024 match
2025 gfc_match_continue (void)
2026 {
2027   if (gfc_match_eos () != MATCH_YES)
2028     {
2029       gfc_syntax_error (ST_CONTINUE);
2030       return MATCH_ERROR;
2031     }
2032
2033   new_st.op = EXEC_CONTINUE;
2034   return MATCH_YES;
2035 }
2036
2037
2038 /* Match the (deprecated) ASSIGN statement.  */
2039
2040 match
2041 gfc_match_assign (void)
2042 {
2043   gfc_expr *expr;
2044   gfc_st_label *label;
2045
2046   if (gfc_match (" %l", &label) == MATCH_YES)
2047     {
2048       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
2049         return MATCH_ERROR;
2050       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
2051         {
2052           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
2053                               "statement at %C")
2054               == FAILURE)
2055             return MATCH_ERROR;
2056
2057           expr->symtree->n.sym->attr.assign = 1;
2058
2059           new_st.op = EXEC_LABEL_ASSIGN;
2060           new_st.label1 = label;
2061           new_st.expr1 = expr;
2062           return MATCH_YES;
2063         }
2064     }
2065   return MATCH_NO;
2066 }
2067
2068
2069 /* Match the GO TO statement.  As a computed GOTO statement is
2070    matched, it is transformed into an equivalent SELECT block.  No
2071    tree is necessary, and the resulting jumps-to-jumps are
2072    specifically optimized away by the back end.  */
2073
2074 match
2075 gfc_match_goto (void)
2076 {
2077   gfc_code *head, *tail;
2078   gfc_expr *expr;
2079   gfc_case *cp;
2080   gfc_st_label *label;
2081   int i;
2082   match m;
2083
2084   if (gfc_match (" %l%t", &label) == MATCH_YES)
2085     {
2086       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2087         return MATCH_ERROR;
2088
2089       new_st.op = EXEC_GOTO;
2090       new_st.label1 = label;
2091       return MATCH_YES;
2092     }
2093
2094   /* The assigned GO TO statement.  */
2095
2096   if (gfc_match_variable (&expr, 0) == MATCH_YES)
2097     {
2098       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
2099                           "statement at %C")
2100           == FAILURE)
2101         return MATCH_ERROR;
2102
2103       new_st.op = EXEC_GOTO;
2104       new_st.expr1 = expr;
2105
2106       if (gfc_match_eos () == MATCH_YES)
2107         return MATCH_YES;
2108
2109       /* Match label list.  */
2110       gfc_match_char (',');
2111       if (gfc_match_char ('(') != MATCH_YES)
2112         {
2113           gfc_syntax_error (ST_GOTO);
2114           return MATCH_ERROR;
2115         }
2116       head = tail = NULL;
2117
2118       do
2119         {
2120           m = gfc_match_st_label (&label);
2121           if (m != MATCH_YES)
2122             goto syntax;
2123
2124           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2125             goto cleanup;
2126
2127           if (head == NULL)
2128             head = tail = gfc_get_code ();
2129           else
2130             {
2131               tail->block = gfc_get_code ();
2132               tail = tail->block;
2133             }
2134
2135           tail->label1 = label;
2136           tail->op = EXEC_GOTO;
2137         }
2138       while (gfc_match_char (',') == MATCH_YES);
2139
2140       if (gfc_match (")%t") != MATCH_YES)
2141         goto syntax;
2142
2143       if (head == NULL)
2144         {
2145            gfc_error ("Statement label list in GOTO at %C cannot be empty");
2146            goto syntax;
2147         }
2148       new_st.block = head;
2149
2150       return MATCH_YES;
2151     }
2152
2153   /* Last chance is a computed GO TO statement.  */
2154   if (gfc_match_char ('(') != MATCH_YES)
2155     {
2156       gfc_syntax_error (ST_GOTO);
2157       return MATCH_ERROR;
2158     }
2159
2160   head = tail = NULL;
2161   i = 1;
2162
2163   do
2164     {
2165       m = gfc_match_st_label (&label);
2166       if (m != MATCH_YES)
2167         goto syntax;
2168
2169       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2170         goto cleanup;
2171
2172       if (head == NULL)
2173         head = tail = gfc_get_code ();
2174       else
2175         {
2176           tail->block = gfc_get_code ();
2177           tail = tail->block;
2178         }
2179
2180       cp = gfc_get_case ();
2181       cp->low = cp->high = gfc_int_expr (i++);
2182
2183       tail->op = EXEC_SELECT;
2184       tail->ext.case_list = cp;
2185
2186       tail->next = gfc_get_code ();
2187       tail->next->op = EXEC_GOTO;
2188       tail->next->label1 = label;
2189     }
2190   while (gfc_match_char (',') == MATCH_YES);
2191
2192   if (gfc_match_char (')') != MATCH_YES)
2193     goto syntax;
2194
2195   if (head == NULL)
2196     {
2197       gfc_error ("Statement label list in GOTO at %C cannot be empty");
2198       goto syntax;
2199     }
2200
2201   /* Get the rest of the statement.  */
2202   gfc_match_char (',');
2203
2204   if (gfc_match (" %e%t", &expr) != MATCH_YES)
2205     goto syntax;
2206
2207   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO "
2208                       "at %C") == FAILURE)
2209     return MATCH_ERROR;
2210
2211   /* At this point, a computed GOTO has been fully matched and an
2212      equivalent SELECT statement constructed.  */
2213
2214   new_st.op = EXEC_SELECT;
2215   new_st.expr1 = NULL;
2216
2217   /* Hack: For a "real" SELECT, the expression is in expr. We put
2218      it in expr2 so we can distinguish then and produce the correct
2219      diagnostics.  */
2220   new_st.expr2 = expr;
2221   new_st.block = head;
2222   return MATCH_YES;
2223
2224 syntax:
2225   gfc_syntax_error (ST_GOTO);
2226 cleanup:
2227   gfc_free_statements (head);
2228   return MATCH_ERROR;
2229 }
2230
2231
2232 /* Frees a list of gfc_alloc structures.  */
2233
2234 void
2235 gfc_free_alloc_list (gfc_alloc *p)
2236 {
2237   gfc_alloc *q;
2238
2239   for (; p; p = q)
2240     {
2241       q = p->next;
2242       gfc_free_expr (p->expr);
2243       gfc_free (p);
2244     }
2245 }
2246
2247
2248 /* Match a Fortran 2003 type-spec (F03:R401).  This is similar to
2249    gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2250    It only includes the intrinsic types from the Fortran 2003 standard
2251    (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2252    the implicit_flag is not needed, so it was removed.  Derived types are
2253    identified by their name alone.  */
2254
2255 static match
2256 match_type_spec (gfc_typespec *ts)
2257 {
2258   match m;
2259   gfc_symbol *derived;
2260   locus old_locus;
2261
2262   gfc_clear_ts (ts);
2263   old_locus = gfc_current_locus;
2264
2265   if (gfc_match ("integer") == MATCH_YES)
2266     {
2267       ts->type = BT_INTEGER;
2268       ts->kind = gfc_default_integer_kind;
2269       goto kind_selector;
2270     }
2271
2272   if (gfc_match ("real") == MATCH_YES)
2273     {
2274       ts->type = BT_REAL;
2275       ts->kind = gfc_default_real_kind;
2276       goto kind_selector;
2277     }
2278
2279   if (gfc_match ("double precision") == MATCH_YES)
2280     {
2281       ts->type = BT_REAL;
2282       ts->kind = gfc_default_double_kind;
2283       return MATCH_YES;
2284     }
2285
2286   if (gfc_match ("complex") == MATCH_YES)
2287     {
2288       ts->type = BT_COMPLEX;
2289       ts->kind = gfc_default_complex_kind;
2290       goto kind_selector;
2291     }
2292
2293   if (gfc_match ("character") == MATCH_YES)
2294     {
2295       ts->type = BT_CHARACTER;
2296       goto char_selector;
2297     }
2298
2299   if (gfc_match ("logical") == MATCH_YES)
2300     {
2301       ts->type = BT_LOGICAL;
2302       ts->kind = gfc_default_logical_kind;
2303       goto kind_selector;
2304     }
2305
2306   if (gfc_match_symbol (&derived, 1) == MATCH_YES)
2307     {
2308       if (derived->attr.flavor == FL_DERIVED)
2309         {
2310           old_locus = gfc_current_locus;
2311           if (gfc_match (" :: ") != MATCH_YES)
2312             return MATCH_ERROR;
2313           gfc_current_locus = old_locus;
2314           ts->type = BT_DERIVED;
2315           ts->u.derived = derived;
2316           /* Enfore F03:C401.  */
2317           if (derived->attr.abstract)
2318             {
2319               gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
2320                          derived->name, &old_locus);
2321               return MATCH_ERROR;
2322             }
2323           return MATCH_YES;
2324         }
2325       else
2326         {
2327           if (gfc_match (" :: ") == MATCH_YES)
2328             {
2329               /* Enforce F03:C476.  */
2330               gfc_error ("'%s' at %L is not an accessible derived type",
2331                          derived->name, &old_locus);
2332               return MATCH_ERROR;
2333             }
2334           else
2335             {
2336               gfc_current_locus = old_locus;
2337               return MATCH_NO;
2338             }
2339         }
2340     }
2341
2342   /* If a type is not matched, simply return MATCH_NO.  */
2343   return MATCH_NO;
2344
2345 kind_selector:
2346
2347   gfc_gobble_whitespace ();
2348   if (gfc_peek_ascii_char () == '*')
2349     {
2350       gfc_error ("Invalid type-spec at %C");
2351       return MATCH_ERROR;
2352     }
2353
2354   m = gfc_match_kind_spec (ts, false);
2355
2356   if (m == MATCH_NO)
2357     m = MATCH_YES;              /* No kind specifier found.  */
2358
2359   return m;
2360
2361 char_selector:
2362
2363   m = gfc_match_char_spec (ts);
2364
2365   if (m == MATCH_NO)
2366     m = MATCH_YES;              /* No kind specifier found.  */
2367
2368   return m;
2369 }
2370
2371
2372 /* Used in gfc_match_allocate to check that a allocation-object and
2373    a source-expr are conformable.  This does not catch all possible
2374    cases; in particular a runtime checking is needed.  */
2375
2376 static gfc_try
2377 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
2378 {
2379   /* First compare rank.  */
2380   if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
2381     {
2382       gfc_error ("Source-expr at %L must be scalar or have the "
2383                  "same rank as the allocate-object at %L",
2384                  &e1->where, &e2->where);
2385       return FAILURE;
2386     }
2387
2388   if (e1->shape)
2389     {
2390       int i;
2391       mpz_t s;
2392
2393       mpz_init (s);
2394
2395       for (i = 0; i < e1->rank; i++)
2396         {
2397           if (e2->ref->u.ar.end[i])
2398             {
2399               mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
2400               mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
2401               mpz_add_ui (s, s, 1);
2402             }
2403           else
2404             {
2405               mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
2406             }
2407
2408           if (mpz_cmp (e1->shape[i], s) != 0)
2409             {
2410               gfc_error ("Source-expr at %L and allocate-object at %L must "
2411                          "have the same shape", &e1->where, &e2->where);
2412               mpz_clear (s);
2413               return FAILURE;
2414             }
2415         }
2416
2417       mpz_clear (s);
2418     }
2419
2420   return SUCCESS;
2421 }
2422
2423
2424 /* Match an ALLOCATE statement.  */
2425
2426 match
2427 gfc_match_allocate (void)
2428 {
2429   gfc_alloc *head, *tail;
2430   gfc_expr *stat, *errmsg, *tmp, *source;
2431   gfc_typespec ts;
2432   match m;
2433   locus old_locus;
2434   bool saw_stat, saw_errmsg, saw_source, b1, b2, b3;
2435
2436   head = tail = NULL;
2437   stat = errmsg = source = tmp = NULL;
2438   saw_stat = saw_errmsg = saw_source = false;
2439
2440   if (gfc_match_char ('(') != MATCH_YES)
2441     goto syntax;
2442
2443   /* Match an optional type-spec.  */
2444   old_locus = gfc_current_locus;
2445   m = match_type_spec (&ts);
2446   if (m == MATCH_ERROR)
2447     goto cleanup;
2448   else if (m == MATCH_NO)
2449     ts.type = BT_UNKNOWN;
2450   else
2451     {
2452       if (gfc_match (" :: ") == MATCH_YES)
2453         {
2454           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
2455                               "ALLOCATE at %L", &old_locus) == FAILURE)
2456             goto cleanup;
2457         }
2458       else
2459         {
2460           ts.type = BT_UNKNOWN;
2461           gfc_current_locus = old_locus;
2462         }
2463     }
2464
2465   for (;;)
2466     {
2467       if (head == NULL)
2468         head = tail = gfc_get_alloc ();
2469       else
2470         {
2471           tail->next = gfc_get_alloc ();
2472           tail = tail->next;
2473         }
2474
2475       m = gfc_match_variable (&tail->expr, 0);
2476       if (m == MATCH_NO)
2477         goto syntax;
2478       if (m == MATCH_ERROR)
2479         goto cleanup;
2480
2481       if (gfc_check_do_variable (tail->expr->symtree))
2482         goto cleanup;
2483
2484       if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2485         {
2486           gfc_error ("Bad allocate-object at %C for a PURE procedure");
2487           goto cleanup;
2488         }
2489
2490       /* The ALLOCATE statement had an optional typespec.  Check the
2491          constraints.  */
2492       if (ts.type != BT_UNKNOWN)
2493         {
2494           /* Enforce F03:C624.  */
2495           if (!gfc_type_compatible (&tail->expr->ts, &ts))
2496             {
2497               gfc_error ("Type of entity at %L is type incompatible with "
2498                          "typespec", &tail->expr->where);
2499               goto cleanup;
2500             }
2501
2502           /* Enforce F03:C627.  */
2503           if (ts.kind != tail->expr->ts.kind)
2504             {
2505               gfc_error ("Kind type parameter for entity at %L differs from "
2506                          "the kind type parameter of the typespec",
2507                          &tail->expr->where);
2508               goto cleanup;
2509             }
2510         }
2511
2512       if (tail->expr->ts.type == BT_DERIVED)
2513         tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
2514
2515       /* FIXME: disable the checking on derived types and arrays.  */
2516       b1 = !(tail->expr->ref
2517            && (tail->expr->ref->type == REF_COMPONENT
2518                 || tail->expr->ref->type == REF_ARRAY));
2519       b2 = tail->expr->symtree->n.sym
2520            && !(tail->expr->symtree->n.sym->attr.allocatable
2521                 || tail->expr->symtree->n.sym->attr.pointer
2522                 || tail->expr->symtree->n.sym->attr.proc_pointer);
2523       b3 = tail->expr->symtree->n.sym
2524            && tail->expr->symtree->n.sym->ns
2525            && tail->expr->symtree->n.sym->ns->proc_name
2526            && (tail->expr->symtree->n.sym->ns->proc_name->attr.allocatable
2527                 || tail->expr->symtree->n.sym->ns->proc_name->attr.pointer
2528                 || tail->expr->symtree->n.sym->ns->proc_name->attr.proc_pointer);
2529       if (b1 && b2 && !b3)
2530         {
2531           gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2532                      "or an allocatable variable");
2533           goto cleanup;
2534         }
2535
2536       if (gfc_match_char (',') != MATCH_YES)
2537         break;
2538
2539 alloc_opt_list:
2540
2541       m = gfc_match (" stat = %v", &tmp);
2542       if (m == MATCH_ERROR)
2543         goto cleanup;
2544       if (m == MATCH_YES)
2545         {
2546           /* Enforce C630.  */
2547           if (saw_stat)
2548             {
2549               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2550               goto cleanup;
2551             }
2552
2553           stat = tmp;
2554           saw_stat = true;
2555
2556           if (gfc_check_do_variable (stat->symtree))
2557             goto cleanup;
2558
2559           if (gfc_match_char (',') == MATCH_YES)
2560             goto alloc_opt_list;
2561         }
2562
2563       m = gfc_match (" errmsg = %v", &tmp);
2564       if (m == MATCH_ERROR)
2565         goto cleanup;
2566       if (m == MATCH_YES)
2567         {
2568           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
2569                               &tmp->where) == FAILURE)
2570             goto cleanup;
2571
2572           /* Enforce C630.  */
2573           if (saw_errmsg)
2574             {
2575               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2576               goto cleanup;
2577             }
2578
2579           errmsg = tmp;
2580           saw_errmsg = true;
2581
2582           if (gfc_match_char (',') == MATCH_YES)
2583             goto alloc_opt_list;
2584         }
2585
2586       m = gfc_match (" source = %e", &tmp);
2587       if (m == MATCH_ERROR)
2588         goto cleanup;
2589       if (m == MATCH_YES)
2590         {
2591           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
2592                               &tmp->where) == FAILURE)
2593             goto cleanup;
2594
2595           /* Enforce C630.  */
2596           if (saw_source)
2597             {
2598               gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
2599               goto cleanup;
2600             }
2601
2602           /* The next 3 conditionals check C631.  */
2603           if (ts.type != BT_UNKNOWN)
2604             {
2605               gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
2606                          &tmp->where, &old_locus);
2607               goto cleanup;
2608             }
2609
2610           if (head->next)
2611             {
2612               gfc_error ("SOURCE tag at %L requires only a single entity in "
2613                          "the allocation-list", &tmp->where);
2614               goto cleanup;
2615             }
2616
2617           gfc_resolve_expr (tmp);
2618
2619           if (head->expr->ts.type != tmp->ts.type)
2620             {
2621               gfc_error ("Type of entity at %L is type incompatible with "
2622                          "source-expr at %L", &head->expr->where, &tmp->where);
2623               goto cleanup;
2624             }
2625
2626           /* Check C633.  */
2627           if (tmp->ts.kind != head->expr->ts.kind)
2628             {
2629               gfc_error ("The allocate-object at %L and the source-expr at %L "
2630                          "shall have the same kind type parameter",
2631                          &head->expr->where, &tmp->where);
2632               goto cleanup;
2633             }
2634
2635           /* Check C632 and restriction following Note 6.18.  */
2636           if (tmp->rank > 0 && conformable_arrays (tmp, head->expr) == FAILURE)
2637             goto cleanup;
2638
2639           source = tmp;
2640           saw_source = true;
2641
2642           if (gfc_match_char (',') == MATCH_YES)
2643             goto alloc_opt_list;
2644         }
2645
2646         gfc_gobble_whitespace ();
2647
2648         if (gfc_peek_char () == ')')
2649           break;
2650     }
2651
2652
2653   if (gfc_match (" )%t") != MATCH_YES)
2654     goto syntax;
2655
2656   new_st.op = EXEC_ALLOCATE;
2657   new_st.expr1 = stat;
2658   new_st.expr2 = errmsg;
2659   new_st.expr3 = source;
2660   new_st.ext.alloc_list = head;
2661
2662   return MATCH_YES;
2663
2664 syntax:
2665   gfc_syntax_error (ST_ALLOCATE);
2666
2667 cleanup:
2668   gfc_free_expr (errmsg);
2669   gfc_free_expr (source);
2670   gfc_free_expr (stat);
2671   gfc_free_expr (tmp);
2672   gfc_free_alloc_list (head);
2673   return MATCH_ERROR;
2674 }
2675
2676
2677 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2678    a set of pointer assignments to intrinsic NULL().  */
2679
2680 match
2681 gfc_match_nullify (void)
2682 {
2683   gfc_code *tail;
2684   gfc_expr *e, *p;
2685   match m;
2686
2687   tail = NULL;
2688
2689   if (gfc_match_char ('(') != MATCH_YES)
2690     goto syntax;
2691
2692   for (;;)
2693     {
2694       m = gfc_match_variable (&p, 0);
2695       if (m == MATCH_ERROR)
2696         goto cleanup;
2697       if (m == MATCH_NO)
2698         goto syntax;
2699
2700       if (gfc_check_do_variable (p->symtree))
2701         goto cleanup;
2702
2703       if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
2704         {
2705           gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2706           goto cleanup;
2707         }
2708
2709       /* build ' => NULL() '.  */
2710       e = gfc_get_expr ();
2711       e->where = gfc_current_locus;
2712       e->expr_type = EXPR_NULL;
2713       e->ts.type = BT_UNKNOWN;
2714
2715       /* Chain to list.  */
2716       if (tail == NULL)
2717         tail = &new_st;
2718       else
2719         {
2720           tail->next = gfc_get_code ();
2721           tail = tail->next;
2722         }
2723
2724       tail->op = EXEC_POINTER_ASSIGN;
2725       tail->expr1 = p;
2726       tail->expr2 = e;
2727
2728       if (gfc_match (" )%t") == MATCH_YES)
2729         break;
2730       if (gfc_match_char (',') != MATCH_YES)
2731         goto syntax;
2732     }
2733
2734   return MATCH_YES;
2735
2736 syntax:
2737   gfc_syntax_error (ST_NULLIFY);
2738
2739 cleanup:
2740   gfc_free_statements (new_st.next);
2741   new_st.next = NULL;
2742   gfc_free_expr (new_st.expr1);
2743   new_st.expr1 = NULL;
2744   gfc_free_expr (new_st.expr2);
2745   new_st.expr2 = NULL;
2746   return MATCH_ERROR;
2747 }
2748
2749
2750 /* Match a DEALLOCATE statement.  */
2751
2752 match
2753 gfc_match_deallocate (void)
2754 {
2755   gfc_alloc *head, *tail;
2756   gfc_expr *stat, *errmsg, *tmp;
2757   match m;
2758   bool saw_stat, saw_errmsg;
2759
2760   head = tail = NULL;
2761   stat = errmsg = tmp = NULL;
2762   saw_stat = saw_errmsg = false;
2763
2764   if (gfc_match_char ('(') != MATCH_YES)
2765     goto syntax;
2766
2767   for (;;)
2768     {
2769       if (head == NULL)
2770         head = tail = gfc_get_alloc ();
2771       else
2772         {
2773           tail->next = gfc_get_alloc ();
2774           tail = tail->next;
2775         }
2776
2777       m = gfc_match_variable (&tail->expr, 0);
2778       if (m == MATCH_ERROR)
2779         goto cleanup;
2780       if (m == MATCH_NO)
2781         goto syntax;
2782
2783       if (gfc_check_do_variable (tail->expr->symtree))
2784         goto cleanup;
2785
2786       if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2787         {
2788           gfc_error ("Illegal allocate-object at %C for a PURE procedure");
2789           goto cleanup;
2790         }
2791
2792       /* FIXME: disable the checking on derived types.  */
2793       if (!(tail->expr->ref
2794            && (tail->expr->ref->type == REF_COMPONENT
2795                || tail->expr->ref->type == REF_ARRAY))
2796           && tail->expr->symtree->n.sym
2797           && !(tail->expr->symtree->n.sym->attr.allocatable
2798                || tail->expr->symtree->n.sym->attr.pointer
2799                || tail->expr->symtree->n.sym->attr.proc_pointer))
2800         {
2801           gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2802                      "or an allocatable variable");
2803           goto cleanup;
2804         }
2805
2806       if (gfc_match_char (',') != MATCH_YES)
2807         break;
2808
2809 dealloc_opt_list:
2810
2811       m = gfc_match (" stat = %v", &tmp);
2812       if (m == MATCH_ERROR)
2813         goto cleanup;
2814       if (m == MATCH_YES)
2815         {
2816           if (saw_stat)
2817             {
2818               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2819               gfc_free_expr (tmp);
2820               goto cleanup;
2821             }
2822
2823           stat = tmp;
2824           saw_stat = true;
2825
2826           if (gfc_check_do_variable (stat->symtree))
2827             goto cleanup;
2828
2829           if (gfc_match_char (',') == MATCH_YES)
2830             goto dealloc_opt_list;
2831         }
2832
2833       m = gfc_match (" errmsg = %v", &tmp);
2834       if (m == MATCH_ERROR)
2835         goto cleanup;
2836       if (m == MATCH_YES)
2837         {
2838           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
2839                               &tmp->where) == FAILURE)
2840             goto cleanup;
2841
2842           if (saw_errmsg)
2843             {
2844               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2845               gfc_free_expr (tmp);
2846               goto cleanup;
2847             }
2848
2849           errmsg = tmp;
2850           saw_errmsg = true;
2851
2852           if (gfc_match_char (',') == MATCH_YES)
2853             goto dealloc_opt_list;
2854         }
2855
2856         gfc_gobble_whitespace ();
2857
2858         if (gfc_peek_char () == ')')
2859           break;
2860     }
2861
2862   if (gfc_match (" )%t") != MATCH_YES)
2863     goto syntax;
2864
2865   new_st.op = EXEC_DEALLOCATE;
2866   new_st.expr1 = stat;
2867   new_st.expr2 = errmsg;
2868   new_st.ext.alloc_list = head;
2869
2870   return MATCH_YES;
2871
2872 syntax:
2873   gfc_syntax_error (ST_DEALLOCATE);
2874
2875 cleanup:
2876   gfc_free_expr (errmsg);
2877   gfc_free_expr (stat);
2878   gfc_free_alloc_list (head);
2879   return MATCH_ERROR;
2880 }
2881
2882
2883 /* Match a RETURN statement.  */
2884
2885 match
2886 gfc_match_return (void)
2887 {
2888   gfc_expr *e;
2889   match m;
2890   gfc_compile_state s;
2891
2892   e = NULL;
2893   if (gfc_match_eos () == MATCH_YES)
2894     goto done;
2895
2896   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2897     {
2898       gfc_error ("Alternate RETURN statement at %C is only allowed within "
2899                  "a SUBROUTINE");
2900       goto cleanup;
2901     }
2902
2903   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN "
2904                       "at %C") == FAILURE)
2905     return MATCH_ERROR;
2906
2907   if (gfc_current_form == FORM_FREE)
2908     {
2909       /* The following are valid, so we can't require a blank after the
2910         RETURN keyword:
2911           return+1
2912           return(1)  */
2913       char c = gfc_peek_ascii_char ();
2914       if (ISALPHA (c) || ISDIGIT (c))
2915         return MATCH_NO;
2916     }
2917
2918   m = gfc_match (" %e%t", &e);
2919   if (m == MATCH_YES)
2920     goto done;
2921   if (m == MATCH_ERROR)
2922     goto cleanup;
2923
2924   gfc_syntax_error (ST_RETURN);
2925
2926 cleanup:
2927   gfc_free_expr (e);
2928   return MATCH_ERROR;
2929
2930 done:
2931   gfc_enclosing_unit (&s);
2932   if (s == COMP_PROGRAM
2933       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2934                         "main program at %C") == FAILURE)
2935       return MATCH_ERROR;
2936
2937   new_st.op = EXEC_RETURN;
2938   new_st.expr1 = e;
2939
2940   return MATCH_YES;
2941 }
2942
2943
2944 /* Match the call of a type-bound procedure, if CALL%var has already been
2945    matched and var found to be a derived-type variable.  */
2946
2947 static match
2948 match_typebound_call (gfc_symtree* varst)
2949 {
2950   gfc_symbol* var;
2951   gfc_expr* base;
2952   match m;
2953
2954   var = varst->n.sym;
2955
2956   base = gfc_get_expr ();
2957   base->expr_type = EXPR_VARIABLE;
2958   base->symtree = varst;
2959   base->where = gfc_current_locus;
2960   gfc_set_sym_referenced (varst->n.sym);
2961
2962   m = gfc_match_varspec (base, 0, true, true);
2963   if (m == MATCH_NO)
2964     gfc_error ("Expected component reference at %C");
2965   if (m != MATCH_YES)
2966     return MATCH_ERROR;
2967
2968   if (gfc_match_eos () != MATCH_YES)
2969     {
2970       gfc_error ("Junk after CALL at %C");
2971       return MATCH_ERROR;
2972     }
2973
2974   if (base->expr_type == EXPR_COMPCALL)
2975     new_st.op = EXEC_COMPCALL;
2976   else if (base->expr_type == EXPR_PPC)
2977     new_st.op = EXEC_CALL_PPC;
2978   else
2979     {
2980       gfc_error ("Expected type-bound procedure or procedure pointer component "
2981                  "at %C");
2982       return MATCH_ERROR;
2983     }
2984   new_st.expr1 = base;
2985
2986   return MATCH_YES;
2987 }
2988
2989
2990 /* Match a CALL statement.  The tricky part here are possible
2991    alternate return specifiers.  We handle these by having all
2992    "subroutines" actually return an integer via a register that gives
2993    the return number.  If the call specifies alternate returns, we
2994    generate code for a SELECT statement whose case clauses contain
2995    GOTOs to the various labels.  */
2996
2997 match
2998 gfc_match_call (void)
2999 {
3000   char name[GFC_MAX_SYMBOL_LEN + 1];
3001   gfc_actual_arglist *a, *arglist;
3002   gfc_case *new_case;
3003   gfc_symbol *sym;
3004   gfc_symtree *st;
3005   gfc_code *c;
3006   match m;
3007   int i;
3008
3009   arglist = NULL;
3010
3011   m = gfc_match ("% %n", name);
3012   if (m == MATCH_NO)
3013     goto syntax;
3014   if (m != MATCH_YES)
3015     return m;
3016
3017   if (gfc_get_ha_sym_tree (name, &st))
3018     return MATCH_ERROR;
3019
3020   sym = st->n.sym;
3021
3022   /* If this is a variable of derived-type, it probably starts a type-bound
3023      procedure call.  */
3024   if (sym->attr.flavor != FL_PROCEDURE && sym->ts.type == BT_DERIVED)
3025     return match_typebound_call (st);
3026
3027   /* If it does not seem to be callable (include functions so that the
3028      right association is made.  They are thrown out in resolution.)
3029      ...  */
3030   if (!sym->attr.generic
3031         && !sym->attr.subroutine
3032         && !sym->attr.function)
3033     {
3034       if (!(sym->attr.external && !sym->attr.referenced))
3035         {
3036           /* ...create a symbol in this scope...  */
3037           if (sym->ns != gfc_current_ns
3038                 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
3039             return MATCH_ERROR;
3040
3041           if (sym != st->n.sym)
3042             sym = st->n.sym;
3043         }
3044
3045       /* ...and then to try to make the symbol into a subroutine.  */
3046       if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
3047         return MATCH_ERROR;
3048     }
3049
3050   gfc_set_sym_referenced (sym);
3051
3052   if (gfc_match_eos () != MATCH_YES)
3053     {
3054       m = gfc_match_actual_arglist (1, &arglist);
3055       if (m == MATCH_NO)
3056         goto syntax;
3057       if (m == MATCH_ERROR)
3058         goto cleanup;
3059
3060       if (gfc_match_eos () != MATCH_YES)
3061         goto syntax;
3062     }
3063
3064   /* If any alternate return labels were found, construct a SELECT
3065      statement that will jump to the right place.  */
3066
3067   i = 0;
3068   for (a = arglist; a; a = a->next)
3069     if (a->expr == NULL)
3070       i = 1;
3071
3072   if (i)
3073     {
3074       gfc_symtree *select_st;
3075       gfc_symbol *select_sym;
3076       char name[GFC_MAX_SYMBOL_LEN + 1];
3077
3078       new_st.next = c = gfc_get_code ();
3079       c->op = EXEC_SELECT;
3080       sprintf (name, "_result_%s", sym->name);
3081       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
3082
3083       select_sym = select_st->n.sym;
3084       select_sym->ts.type = BT_INTEGER;
3085       select_sym->ts.kind = gfc_default_integer_kind;
3086       gfc_set_sym_referenced (select_sym);
3087       c->expr1 = gfc_get_expr ();
3088       c->expr1->expr_type = EXPR_VARIABLE;
3089       c->expr1->symtree = select_st;
3090       c->expr1->ts = select_sym->ts;
3091       c->expr1->where = gfc_current_locus;
3092
3093       i = 0;
3094       for (a = arglist; a; a = a->next)
3095         {
3096           if (a->expr != NULL)
3097             continue;
3098
3099           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
3100             continue;
3101
3102           i++;
3103
3104           c->block = gfc_get_code ();
3105           c = c->block;
3106           c->op = EXEC_SELECT;
3107
3108           new_case = gfc_get_case ();
3109           new_case->high = new_case->low = gfc_int_expr (i);
3110           c->ext.case_list = new_case;
3111
3112           c->next = gfc_get_code ();
3113           c->next->op = EXEC_GOTO;
3114           c->next->label1 = a->label;
3115         }
3116     }
3117
3118   new_st.op = EXEC_CALL;
3119   new_st.symtree = st;
3120   new_st.ext.actual = arglist;
3121
3122   return MATCH_YES;
3123
3124 syntax:
3125   gfc_syntax_error (ST_CALL);
3126
3127 cleanup:
3128   gfc_free_actual_arglist (arglist);
3129   return MATCH_ERROR;
3130 }
3131
3132
3133 /* Given a name, return a pointer to the common head structure,
3134    creating it if it does not exist. If FROM_MODULE is nonzero, we
3135    mangle the name so that it doesn't interfere with commons defined
3136    in the using namespace.
3137    TODO: Add to global symbol tree.  */
3138
3139 gfc_common_head *
3140 gfc_get_common (const char *name, int from_module)
3141 {
3142   gfc_symtree *st;
3143   static int serial = 0;
3144   char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
3145
3146   if (from_module)
3147     {
3148       /* A use associated common block is only needed to correctly layout
3149          the variables it contains.  */
3150       snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
3151       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
3152     }
3153   else
3154     {
3155       st = gfc_find_symtree (gfc_current_ns->common_root, name);
3156
3157       if (st == NULL)
3158         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
3159     }
3160
3161   if (st->n.common == NULL)
3162     {
3163       st->n.common = gfc_get_common_head ();
3164       st->n.common->where = gfc_current_locus;
3165       strcpy (st->n.common->name, name);
3166     }
3167
3168   return st->n.common;
3169 }
3170
3171
3172 /* Match a common block name.  */
3173
3174 match match_common_name (char *name)
3175 {
3176   match m;
3177
3178   if (gfc_match_char ('/') == MATCH_NO)
3179     {
3180       name[0] = '\0';
3181       return MATCH_YES;
3182     }
3183
3184   if (gfc_match_char ('/') == MATCH_YES)
3185     {
3186       name[0] = '\0';
3187       return MATCH_YES;
3188     }
3189
3190   m = gfc_match_name (name);
3191
3192   if (m == MATCH_ERROR)
3193     return MATCH_ERROR;
3194   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
3195     return MATCH_YES;
3196
3197   gfc_error ("Syntax error in common block name at %C");
3198   return MATCH_ERROR;
3199 }
3200
3201
3202 /* Match a COMMON statement.  */
3203
3204 match
3205 gfc_match_common (void)
3206 {
3207   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
3208   char name[GFC_MAX_SYMBOL_LEN + 1];
3209   gfc_common_head *t;
3210   gfc_array_spec *as;
3211   gfc_equiv *e1, *e2;
3212   match m;
3213   gfc_gsymbol *gsym;
3214
3215   old_blank_common = gfc_current_ns->blank_common.head;
3216   if (old_blank_common)
3217     {
3218       while (old_blank_common->common_next)
3219         old_blank_common = old_blank_common->common_next;
3220     }
3221
3222   as = NULL;
3223
3224   for (;;)
3225     {
3226       m = match_common_name (name);
3227       if (m == MATCH_ERROR)
3228         goto cleanup;
3229
3230       gsym = gfc_get_gsymbol (name);
3231       if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
3232         {
3233           gfc_error ("Symbol '%s' at %C is already an external symbol that "
3234                      "is not COMMON", name);
3235           goto cleanup;
3236         }
3237
3238       if (gsym->type == GSYM_UNKNOWN)
3239         {
3240           gsym->type = GSYM_COMMON;
3241           gsym->where = gfc_current_locus;
3242           gsym->defined = 1;
3243         }
3244
3245       gsym->used = 1;
3246
3247       if (name[0] == '\0')
3248         {
3249           t = &gfc_current_ns->blank_common;
3250           if (t->head == NULL)
3251             t->where = gfc_current_locus;
3252         }
3253       else
3254         {
3255           t = gfc_get_common (name, 0);
3256         }
3257       head = &t->head;
3258
3259       if (*head == NULL)
3260         tail = NULL;
3261       else
3262         {
3263           tail = *head;
3264           while (tail->common_next)
3265             tail = tail->common_next;
3266         }
3267
3268       /* Grab the list of symbols.  */
3269       for (;;)
3270         {
3271           m = gfc_match_symbol (&sym, 0);
3272           if (m == MATCH_ERROR)
3273             goto cleanup;
3274           if (m == MATCH_NO)
3275             goto syntax;
3276
3277           /* Store a ref to the common block for error checking.  */
3278           sym->common_block = t;
3279
3280           /* See if we know the current common block is bind(c), and if
3281              so, then see if we can check if the symbol is (which it'll
3282              need to be).  This can happen if the bind(c) attr stmt was
3283              applied to the common block, and the variable(s) already
3284              defined, before declaring the common block.  */
3285           if (t->is_bind_c == 1)
3286             {
3287               if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
3288                 {
3289                   /* If we find an error, just print it and continue,
3290                      cause it's just semantic, and we can see if there
3291                      are more errors.  */
3292                   gfc_error_now ("Variable '%s' at %L in common block '%s' "
3293                                  "at %C must be declared with a C "
3294                                  "interoperable kind since common block "
3295                                  "'%s' is bind(c)",
3296                                  sym->name, &(sym->declared_at), t->name,
3297                                  t->name);
3298                 }
3299
3300               if (sym->attr.is_bind_c == 1)
3301                 gfc_error_now ("Variable '%s' in common block "
3302                                "'%s' at %C can not be bind(c) since "
3303                                "it is not global", sym->name, t->name);
3304             }
3305
3306           if (sym->attr.in_common)
3307             {
3308               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
3309                          sym->name);
3310               goto cleanup;
3311             }
3312
3313           if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
3314                || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
3315             {
3316               if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
3317                                                "can only be COMMON in "
3318                                                "BLOCK DATA", sym->name)
3319                   == FAILURE)
3320                 goto cleanup;
3321             }
3322
3323           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
3324             goto cleanup;
3325
3326           if (tail != NULL)
3327             tail->common_next = sym;
3328           else
3329             *head = sym;
3330
3331           tail = sym;
3332
3333           /* Deal with an optional array specification after the
3334              symbol name.  */
3335           m = gfc_match_array_spec (&as);
3336           if (m == MATCH_ERROR)
3337             goto cleanup;
3338
3339           if (m == MATCH_YES)
3340             {
3341               if (as->type != AS_EXPLICIT)
3342                 {
3343                   gfc_error ("Array specification for symbol '%s' in COMMON "
3344                              "at %C must be explicit", sym->name);
3345                   goto cleanup;
3346                 }
3347
3348               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
3349                 goto cleanup;
3350
3351               if (sym->attr.pointer)
3352                 {
3353                   gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3354                              "POINTER array", sym->name);
3355                   goto cleanup;
3356                 }
3357
3358               sym->as = as;
3359               as = NULL;
3360
3361             }
3362
3363           sym->common_head = t;
3364
3365           /* Check to see if the symbol is already in an equivalence group.
3366              If it is, set the other members as being in common.  */
3367           if (sym->attr.in_equivalence)
3368             {
3369               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
3370                 {
3371                   for (e2 = e1; e2; e2 = e2->eq)
3372                     if (e2->expr->symtree->n.sym == sym)
3373                       goto equiv_found;
3374
3375                   continue;
3376
3377           equiv_found:
3378
3379                   for (e2 = e1; e2; e2 = e2->eq)
3380                     {
3381                       other = e2->expr->symtree->n.sym;
3382                       if (other->common_head
3383                           && other->common_head != sym->common_head)
3384                         {
3385                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
3386                                      "%C is being indirectly equivalenced to "
3387                                      "another COMMON block '%s'",
3388                                      sym->name, sym->common_head->name,
3389                                      other->common_head->name);
3390                             goto cleanup;
3391                         }
3392                       other->attr.in_common = 1;
3393                       other->common_head = t;
3394                     }
3395                 }
3396             }
3397
3398
3399           gfc_gobble_whitespace ();
3400           if (gfc_match_eos () == MATCH_YES)
3401             goto done;
3402           if (gfc_peek_ascii_char () == '/')
3403             break;
3404           if (gfc_match_char (',') != MATCH_YES)
3405             goto syntax;
3406           gfc_gobble_whitespace ();
3407           if (gfc_peek_ascii_char () == '/')
3408             break;
3409         }
3410     }
3411
3412 done:
3413   return MATCH_YES;
3414
3415 syntax:
3416   gfc_syntax_error (ST_COMMON);
3417
3418 cleanup:
3419   if (old_blank_common)
3420     old_blank_common->common_next = NULL;
3421   else
3422     gfc_current_ns->blank_common.head = NULL;
3423   gfc_free_array_spec (as);
3424   return MATCH_ERROR;
3425 }
3426
3427
3428 /* Match a BLOCK DATA program unit.  */
3429
3430 match
3431 gfc_match_block_data (void)
3432 {
3433   char name[GFC_MAX_SYMBOL_LEN + 1];
3434   gfc_symbol *sym;
3435   match m;
3436
3437   if (gfc_match_eos () == MATCH_YES)
3438     {
3439       gfc_new_block = NULL;
3440       return MATCH_YES;
3441     }
3442
3443   m = gfc_match ("% %n%t", name);
3444   if (m != MATCH_YES)
3445     return MATCH_ERROR;
3446
3447   if (gfc_get_symbol (name, NULL, &sym))
3448     return MATCH_ERROR;
3449
3450   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
3451     return MATCH_ERROR;
3452
3453   gfc_new_block = sym;
3454
3455   return MATCH_YES;
3456 }
3457
3458
3459 /* Free a namelist structure.  */
3460
3461 void
3462 gfc_free_namelist (gfc_namelist *name)
3463 {
3464   gfc_namelist *n;
3465
3466   for (; name; name = n)
3467     {
3468       n = name->next;
3469       gfc_free (name);
3470     }
3471 }
3472
3473
3474 /* Match a NAMELIST statement.  */
3475
3476 match
3477 gfc_match_namelist (void)
3478 {
3479   gfc_symbol *group_name, *sym;
3480   gfc_namelist *nl;
3481   match m, m2;
3482
3483   m = gfc_match (" / %s /", &group_name);
3484   if (m == MATCH_NO)
3485     goto syntax;
3486   if (m == MATCH_ERROR)
3487     goto error;
3488
3489   for (;;)
3490     {
3491       if (group_name->ts.type != BT_UNKNOWN)
3492         {
3493           gfc_error ("Namelist group name '%s' at %C already has a basic "
3494                      "type of %s", group_name->name,
3495                      gfc_typename (&group_name->ts));
3496           return MATCH_ERROR;
3497         }
3498
3499       if (group_name->attr.flavor == FL_NAMELIST
3500           && group_name->attr.use_assoc
3501           && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
3502                              "at %C already is USE associated and can"
3503                              "not be respecified.", group_name->name)
3504              == FAILURE)
3505         return MATCH_ERROR;
3506
3507       if (group_name->attr.flavor != FL_NAMELIST
3508           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
3509                              group_name->name, NULL) == FAILURE)
3510         return MATCH_ERROR;
3511
3512       for (;;)
3513         {
3514           m = gfc_match_symbol (&sym, 1);
3515           if (m == MATCH_NO)
3516             goto syntax;
3517           if (m == MATCH_ERROR)
3518             goto error;
3519
3520           if (sym->attr.in_namelist == 0
3521               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
3522             goto error;
3523
3524           /* Use gfc_error_check here, rather than goto error, so that
3525              these are the only errors for the next two lines.  */
3526           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3527             {
3528               gfc_error ("Assumed size array '%s' in namelist '%s' at "
3529                          "%C is not allowed", sym->name, group_name->name);
3530               gfc_error_check ();
3531             }
3532
3533           if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl->length == NULL)
3534             {
3535               gfc_error ("Assumed character length '%s' in namelist '%s' at "
3536                          "%C is not allowed", sym->name, group_name->name);
3537               gfc_error_check ();
3538             }
3539
3540           nl = gfc_get_namelist ();
3541           nl->sym = sym;
3542           sym->refs++;
3543
3544           if (group_name->namelist == NULL)
3545             group_name->namelist = group_name->namelist_tail = nl;
3546           else
3547             {
3548               group_name->namelist_tail->next = nl;
3549               group_name->namelist_tail = nl;
3550             }
3551
3552           if (gfc_match_eos () == MATCH_YES)
3553             goto done;
3554
3555           m = gfc_match_char (',');
3556
3557           if (gfc_match_char ('/') == MATCH_YES)
3558             {
3559               m2 = gfc_match (" %s /", &group_name);
3560               if (m2 == MATCH_YES)
3561                 break;
3562               if (m2 == MATCH_ERROR)
3563                 goto error;
3564               goto syntax;
3565             }
3566
3567           if (m != MATCH_YES)
3568             goto syntax;
3569         }
3570     }
3571
3572 done:
3573   return MATCH_YES;
3574
3575 syntax:
3576   gfc_syntax_error (ST_NAMELIST);
3577
3578 error:
3579   return MATCH_ERROR;
3580 }
3581
3582
3583 /* Match a MODULE statement.  */
3584
3585 match
3586 gfc_match_module (void)
3587 {
3588   match m;
3589
3590   m = gfc_match (" %s%t", &gfc_new_block);
3591   if (m != MATCH_YES)
3592     return m;
3593
3594   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
3595                       gfc_new_block->name, NULL) == FAILURE)
3596     return MATCH_ERROR;
3597
3598   return MATCH_YES;
3599 }
3600
3601
3602 /* Free equivalence sets and lists.  Recursively is the easiest way to
3603    do this.  */
3604
3605 void
3606 gfc_free_equiv (gfc_equiv *eq)
3607 {
3608   if (eq == NULL)
3609     return;
3610
3611   gfc_free_equiv (eq->eq);
3612   gfc_free_equiv (eq->next);
3613   gfc_free_expr (eq->expr);
3614   gfc_free (eq);
3615 }
3616
3617
3618 /* Match an EQUIVALENCE statement.  */
3619
3620 match
3621 gfc_match_equivalence (void)
3622 {
3623   gfc_equiv *eq, *set, *tail;
3624   gfc_ref *ref;
3625   gfc_symbol *sym;
3626   match m;
3627   gfc_common_head *common_head = NULL;
3628   bool common_flag;
3629   int cnt;
3630
3631   tail = NULL;
3632
3633   for (;;)
3634     {
3635       eq = gfc_get_equiv ();
3636       if (tail == NULL)
3637         tail = eq;
3638
3639       eq->next = gfc_current_ns->equiv;
3640       gfc_current_ns->equiv = eq;
3641
3642       if (gfc_match_char ('(') != MATCH_YES)
3643         goto syntax;
3644
3645       set = eq;
3646       common_flag = FALSE;
3647       cnt = 0;
3648
3649       for (;;)
3650         {
3651           m = gfc_match_equiv_variable (&set->expr);
3652           if (m == MATCH_ERROR)
3653             goto cleanup;
3654           if (m == MATCH_NO)
3655             goto syntax;
3656
3657           /*  count the number of objects.  */
3658           cnt++;
3659
3660           if (gfc_match_char ('%') == MATCH_YES)
3661             {
3662               gfc_error ("Derived type component %C is not a "
3663                          "permitted EQUIVALENCE member");
3664               goto cleanup;
3665             }
3666
3667           for (ref = set->expr->ref; ref; ref = ref->next)
3668             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3669               {
3670                 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3671                            "be an array section");
3672                 goto cleanup;
3673               }
3674
3675           sym = set->expr->symtree->n.sym;
3676
3677           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
3678             goto cleanup;
3679
3680           if (sym->attr.in_common)
3681             {
3682               common_flag = TRUE;
3683               common_head = sym->common_head;
3684             }
3685
3686           if (gfc_match_char (')') == MATCH_YES)
3687             break;
3688
3689           if (gfc_match_char (',') != MATCH_YES)
3690             goto syntax;
3691
3692           set->eq = gfc_get_equiv ();
3693           set = set->eq;
3694         }
3695
3696       if (cnt < 2)
3697         {
3698           gfc_error ("EQUIVALENCE at %C requires two or more objects");
3699           goto cleanup;
3700         }
3701
3702       /* If one of the members of an equivalence is in common, then
3703          mark them all as being in common.  Before doing this, check
3704          that members of the equivalence group are not in different
3705          common blocks.  */
3706       if (common_flag)
3707         for (set = eq; set; set = set->eq)
3708           {
3709             sym = set->expr->symtree->n.sym;
3710             if (sym->common_head && sym->common_head != common_head)
3711               {
3712                 gfc_error ("Attempt to indirectly overlap COMMON "
3713                            "blocks %s and %s by EQUIVALENCE at %C",
3714                            sym->common_head->name, common_head->name);
3715                 goto cleanup;
3716               }
3717             sym->attr.in_common = 1;
3718             sym->common_head = common_head;
3719           }
3720
3721       if (gfc_match_eos () == MATCH_YES)
3722         break;
3723       if (gfc_match_char (',') != MATCH_YES)
3724         goto syntax;
3725     }
3726
3727   return MATCH_YES;
3728
3729 syntax:
3730   gfc_syntax_error (ST_EQUIVALENCE);
3731
3732 cleanup:
3733   eq = tail->next;
3734   tail->next = NULL;
3735
3736   gfc_free_equiv (gfc_current_ns->equiv);
3737   gfc_current_ns->equiv = eq;
3738
3739   return MATCH_ERROR;
3740 }
3741
3742
3743 /* Check that a statement function is not recursive. This is done by looking
3744    for the statement function symbol(sym) by looking recursively through its
3745    expression(e).  If a reference to sym is found, true is returned.
3746    12.5.4 requires that any variable of function that is implicitly typed
3747    shall have that type confirmed by any subsequent type declaration.  The
3748    implicit typing is conveniently done here.  */
3749 static bool
3750 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
3751
3752 static bool
3753 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
3754 {
3755
3756   if (e == NULL)
3757     return false;
3758
3759   switch (e->expr_type)
3760     {
3761     case EXPR_FUNCTION:
3762       if (e->symtree == NULL)
3763         return false;
3764
3765       /* Check the name before testing for nested recursion!  */
3766       if (sym->name == e->symtree->n.sym->name)
3767         return true;
3768
3769       /* Catch recursion via other statement functions.  */
3770       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
3771           && e->symtree->n.sym->value
3772           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
3773         return true;
3774
3775       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3776         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3777
3778       break;
3779
3780     case EXPR_VARIABLE:
3781       if (e->symtree && sym->name == e->symtree->n.sym->name)
3782         return true;
3783
3784       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3785         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3786       break;
3787
3788     default:
3789       break;
3790     }
3791
3792   return false;
3793 }
3794
3795
3796 static bool
3797 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
3798 {
3799   return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
3800 }
3801
3802
3803 /* Match a statement function declaration.  It is so easy to match
3804    non-statement function statements with a MATCH_ERROR as opposed to
3805    MATCH_NO that we suppress error message in most cases.  */
3806
3807 match
3808 gfc_match_st_function (void)
3809 {
3810   gfc_error_buf old_error;
3811   gfc_symbol *sym;
3812   gfc_expr *expr;
3813   match m;
3814
3815   m = gfc_match_symbol (&sym, 0);
3816   if (m != MATCH_YES)
3817     return m;
3818
3819   gfc_push_error (&old_error);
3820
3821   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
3822                          sym->name, NULL) == FAILURE)
3823     goto undo_error;
3824
3825   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
3826     goto undo_error;
3827
3828   m = gfc_match (" = %e%t", &expr);
3829   if (m == MATCH_NO)
3830     goto undo_error;
3831
3832   gfc_free_error (&old_error);
3833   if (m == MATCH_ERROR)
3834     return m;
3835
3836   if (recursive_stmt_fcn (expr, sym))
3837     {
3838       gfc_error ("Statement function at %L is recursive", &expr->where);
3839       return MATCH_ERROR;
3840     }
3841
3842   sym->value = expr;
3843
3844   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
3845                       "Statement function at %C") == FAILURE)
3846     return MATCH_ERROR;
3847
3848   return MATCH_YES;
3849
3850 undo_error:
3851   gfc_pop_error (&old_error);
3852   return MATCH_NO;
3853 }
3854
3855
3856 /***************** SELECT CASE subroutines ******************/
3857
3858 /* Free a single case structure.  */
3859
3860 static void
3861 free_case (gfc_case *p)
3862 {
3863   if (p->low == p->high)
3864     p->high = NULL;
3865   gfc_free_expr (p->low);
3866   gfc_free_expr (p->high);
3867   gfc_free (p);
3868 }
3869
3870
3871 /* Free a list of case structures.  */
3872
3873 void
3874 gfc_free_case_list (gfc_case *p)
3875 {
3876   gfc_case *q;
3877
3878   for (; p; p = q)
3879     {
3880       q = p->next;
3881       free_case (p);
3882     }
3883 }
3884
3885
3886 /* Match a single case selector.  */
3887
3888 static match
3889 match_case_selector (gfc_case **cp)
3890 {
3891   gfc_case *c;
3892   match m;
3893
3894   c = gfc_get_case ();
3895   c->where = gfc_current_locus;
3896
3897   if (gfc_match_char (':') == MATCH_YES)
3898     {
3899       m = gfc_match_init_expr (&c->high);
3900       if (m == MATCH_NO)
3901         goto need_expr;
3902       if (m == MATCH_ERROR)
3903         goto cleanup;
3904     }
3905   else
3906     {
3907       m = gfc_match_init_expr (&c->low);
3908       if (m == MATCH_ERROR)
3909         goto cleanup;
3910       if (m == MATCH_NO)
3911         goto need_expr;
3912
3913       /* If we're not looking at a ':' now, make a range out of a single
3914          target.  Else get the upper bound for the case range.  */
3915       if (gfc_match_char (':') != MATCH_YES)
3916         c->high = c->low;
3917       else
3918         {
3919           m = gfc_match_init_expr (&c->high);
3920           if (m == MATCH_ERROR)
3921             goto cleanup;
3922           /* MATCH_NO is fine.  It's OK if nothing is there!  */
3923         }
3924     }
3925
3926   *cp = c;
3927   return MATCH_YES;
3928
3929 need_expr:
3930   gfc_error ("Expected initialization expression in CASE at %C");
3931
3932 cleanup:
3933   free_case (c);
3934   return MATCH_ERROR;
3935 }
3936
3937
3938 /* Match the end of a case statement.  */
3939
3940 static match
3941 match_case_eos (void)
3942 {
3943   char name[GFC_MAX_SYMBOL_LEN + 1];
3944   match m;
3945
3946   if (gfc_match_eos () == MATCH_YES)
3947     return MATCH_YES;
3948
3949   /* If the case construct doesn't have a case-construct-name, we
3950      should have matched the EOS.  */
3951   if (!gfc_current_block ())
3952     {
3953       gfc_error ("Expected the name of the SELECT CASE construct at %C");
3954       return MATCH_ERROR;
3955     }
3956
3957   gfc_gobble_whitespace ();
3958
3959   m = gfc_match_name (name);
3960   if (m != MATCH_YES)
3961     return m;
3962
3963   if (strcmp (name, gfc_current_block ()->name) != 0)
3964     {
3965       gfc_error ("Expected case name of '%s' at %C",
3966                  gfc_current_block ()->name);
3967       return MATCH_ERROR;
3968     }
3969
3970   return gfc_match_eos ();
3971 }
3972
3973
3974 /* Match a SELECT statement.  */
3975
3976 match
3977 gfc_match_select (void)
3978 {
3979   gfc_expr *expr;
3980   match m;
3981
3982   m = gfc_match_label ();
3983   if (m == MATCH_ERROR)
3984     return m;
3985
3986   m = gfc_match (" select case ( %e )%t", &expr);
3987   if (m != MATCH_YES)
3988     return m;
3989
3990   new_st.op = EXEC_SELECT;
3991   new_st.expr1 = expr;
3992
3993   return MATCH_YES;
3994 }
3995
3996
3997 /* Match a CASE statement.  */
3998
3999 match
4000 gfc_match_case (void)
4001 {
4002   gfc_case *c, *head, *tail;
4003   match m;
4004
4005   head = tail = NULL;
4006
4007   if (gfc_current_state () != COMP_SELECT)
4008     {
4009       gfc_error ("Unexpected CASE statement at %C");
4010       return MATCH_ERROR;
4011     }
4012
4013   if (gfc_match ("% default") == MATCH_YES)
4014     {
4015       m = match_case_eos ();
4016       if (m == MATCH_NO)
4017         goto syntax;
4018       if (m == MATCH_ERROR)
4019         goto cleanup;
4020
4021       new_st.op = EXEC_SELECT;
4022       c = gfc_get_case ();
4023       c->where = gfc_current_locus;
4024       new_st.ext.case_list = c;
4025       return MATCH_YES;
4026     }
4027
4028   if (gfc_match_char ('(') != MATCH_YES)
4029     goto syntax;
4030
4031   for (;;)
4032     {
4033       if (match_case_selector (&c) == MATCH_ERROR)
4034         goto cleanup;
4035
4036       if (head == NULL)
4037         head = c;
4038       else
4039         tail->next = c;
4040
4041       tail = c;
4042
4043       if (gfc_match_char (')') == MATCH_YES)
4044         break;
4045       if (gfc_match_char (',') != MATCH_YES)
4046         goto syntax;
4047     }
4048
4049   m = match_case_eos ();
4050   if (m == MATCH_NO)
4051     goto syntax;
4052   if (m == MATCH_ERROR)
4053     goto cleanup;
4054
4055   new_st.op = EXEC_SELECT;
4056   new_st.ext.case_list = head;
4057
4058   return MATCH_YES;
4059
4060 syntax:
4061   gfc_error ("Syntax error in CASE-specification at %C");
4062
4063 cleanup:
4064   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
4065   return MATCH_ERROR;
4066 }
4067
4068 /********************* WHERE subroutines ********************/
4069
4070 /* Match the rest of a simple WHERE statement that follows an IF statement.
4071  */
4072
4073 static match
4074 match_simple_where (void)
4075 {
4076   gfc_expr *expr;
4077   gfc_code *c;
4078   match m;
4079
4080   m = gfc_match (" ( %e )", &expr);
4081   if (m != MATCH_YES)
4082     return m;
4083
4084   m = gfc_match_assignment ();
4085   if (m == MATCH_NO)
4086     goto syntax;
4087   if (m == MATCH_ERROR)
4088     goto cleanup;
4089
4090   if (gfc_match_eos () != MATCH_YES)
4091     goto syntax;
4092
4093   c = gfc_get_code ();
4094
4095   c->op = EXEC_WHERE;
4096   c->expr1 = expr;
4097   c->next = gfc_get_code ();
4098
4099   *c->next = new_st;
4100   gfc_clear_new_st ();
4101
4102   new_st.op = EXEC_WHERE;
4103   new_st.block = c;
4104
4105   return MATCH_YES;
4106
4107 syntax:
4108   gfc_syntax_error (ST_WHERE);
4109
4110 cleanup:
4111   gfc_free_expr (expr);
4112   return MATCH_ERROR;
4113 }
4114
4115
4116 /* Match a WHERE statement.  */
4117
4118 match
4119 gfc_match_where (gfc_statement *st)
4120 {
4121   gfc_expr *expr;
4122   match m0, m;
4123   gfc_code *c;
4124
4125   m0 = gfc_match_label ();
4126   if (m0 == MATCH_ERROR)
4127     return m0;
4128
4129   m = gfc_match (" where ( %e )", &expr);
4130   if (m != MATCH_YES)
4131     return m;
4132
4133   if (gfc_match_eos () == MATCH_YES)
4134     {
4135       *st = ST_WHERE_BLOCK;
4136       new_st.op = EXEC_WHERE;
4137       new_st.expr1 = expr;
4138       return MATCH_YES;
4139     }
4140
4141   m = gfc_match_assignment ();
4142   if (m == MATCH_NO)
4143     gfc_syntax_error (ST_WHERE);
4144
4145   if (m != MATCH_YES)
4146     {
4147       gfc_free_expr (expr);
4148       return MATCH_ERROR;
4149     }
4150
4151   /* We've got a simple WHERE statement.  */
4152   *st = ST_WHERE;
4153   c = gfc_get_code ();
4154
4155   c->op = EXEC_WHERE;
4156   c->expr1 = expr;
4157   c->next = gfc_get_code ();
4158
4159   *c->next = new_st;
4160   gfc_clear_new_st ();
4161
4162   new_st.op = EXEC_WHERE;
4163   new_st.block = c;
4164
4165   return MATCH_YES;
4166 }
4167
4168
4169 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
4170    new_st if successful.  */
4171
4172 match
4173 gfc_match_elsewhere (void)
4174 {
4175   char name[GFC_MAX_SYMBOL_LEN + 1];
4176   gfc_expr *expr;
4177   match m;
4178
4179   if (gfc_current_state () != COMP_WHERE)
4180     {
4181       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
4182       return MATCH_ERROR;
4183     }
4184
4185   expr = NULL;
4186
4187   if (gfc_match_char ('(') == MATCH_YES)
4188     {
4189       m = gfc_match_expr (&expr);
4190       if (m == MATCH_NO)
4191         goto syntax;
4192       if (m == MATCH_ERROR)
4193         return MATCH_ERROR;
4194
4195       if (gfc_match_char (')') != MATCH_YES)
4196         goto syntax;
4197     }
4198
4199   if (gfc_match_eos () != MATCH_YES)
4200     {
4201       /* Only makes sense if we have a where-construct-name.  */
4202       if (!gfc_current_block ())
4203         {
4204           m = MATCH_ERROR;
4205           goto cleanup;
4206         }
4207       /* Better be a name at this point.  */
4208       m = gfc_match_name (name);
4209       if (m == MATCH_NO)
4210         goto syntax;
4211       if (m == MATCH_ERROR)
4212         goto cleanup;
4213
4214       if (gfc_match_eos () != MATCH_YES)
4215         goto syntax;
4216
4217       if (strcmp (name, gfc_current_block ()->name) != 0)
4218         {
4219           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
4220                      name, gfc_current_block ()->name);
4221           goto cleanup;
4222         }
4223     }
4224
4225   new_st.op = EXEC_WHERE;
4226   new_st.expr1 = expr;
4227   return MATCH_YES;
4228
4229 syntax:
4230   gfc_syntax_error (ST_ELSEWHERE);
4231
4232 cleanup:
4233   gfc_free_expr (expr);
4234   return MATCH_ERROR;
4235 }
4236
4237
4238 /******************** FORALL subroutines ********************/
4239
4240 /* Free a list of FORALL iterators.  */
4241
4242 void
4243 gfc_free_forall_iterator (gfc_forall_iterator *iter)
4244 {
4245   gfc_forall_iterator *next;
4246
4247   while (iter)
4248     {
4249       next = iter->next;
4250       gfc_free_expr (iter->var);
4251       gfc_free_expr (iter->start);
4252       gfc_free_expr (iter->end);
4253       gfc_free_expr (iter->stride);
4254       gfc_free (iter);
4255       iter = next;
4256     }
4257 }
4258
4259
4260 /* Match an iterator as part of a FORALL statement.  The format is:
4261
4262      <var> = <start>:<end>[:<stride>]
4263
4264    On MATCH_NO, the caller tests for the possibility that there is a
4265    scalar mask expression.  */
4266
4267 static match
4268 match_forall_iterator (gfc_forall_iterator **result)
4269 {
4270   gfc_forall_iterator *iter;
4271   locus where;
4272   match m;
4273
4274   where = gfc_current_locus;
4275   iter = XCNEW (gfc_forall_iterator);
4276
4277   m = gfc_match_expr (&iter->var);
4278   if (m != MATCH_YES)
4279     goto cleanup;
4280
4281   if (gfc_match_char ('=') != MATCH_YES
4282       || iter->var->expr_type != EXPR_VARIABLE)
4283     {
4284       m = MATCH_NO;
4285       goto cleanup;
4286     }
4287
4288   m = gfc_match_expr (&iter->start);
4289   if (m != MATCH_YES)
4290     goto cleanup;
4291
4292   if (gfc_match_char (':') != MATCH_YES)
4293     goto syntax;
4294
4295   m = gfc_match_expr (&iter->end);
4296   if (m == MATCH_NO)
4297     goto syntax;
4298   if (m == MATCH_ERROR)
4299     goto cleanup;
4300
4301   if (gfc_match_char (':') == MATCH_NO)
4302     iter->stride = gfc_int_expr (1);
4303   else
4304     {
4305       m = gfc_match_expr (&iter->stride);
4306       if (m == MATCH_NO)
4307         goto syntax;
4308       if (m == MATCH_ERROR)
4309         goto cleanup;
4310     }
4311
4312   /* Mark the iteration variable's symbol as used as a FORALL index.  */
4313   iter->var->symtree->n.sym->forall_index = true;
4314
4315   *result = iter;
4316   return MATCH_YES;
4317
4318 syntax:
4319   gfc_error ("Syntax error in FORALL iterator at %C");
4320   m = MATCH_ERROR;
4321
4322 cleanup:
4323
4324   gfc_current_locus = where;
4325   gfc_free_forall_iterator (iter);
4326   return m;
4327 }
4328
4329
4330 /* Match the header of a FORALL statement.  */
4331
4332 static match
4333 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
4334 {
4335   gfc_forall_iterator *head, *tail, *new_iter;
4336   gfc_expr *msk;
4337   match m;
4338
4339   gfc_gobble_whitespace ();
4340
4341   head = tail = NULL;
4342   msk = NULL;
4343
4344   if (gfc_match_char ('(') != MATCH_YES)
4345     return MATCH_NO;
4346
4347   m = match_forall_iterator (&new_iter);
4348   if (m == MATCH_ERROR)
4349     goto cleanup;
4350   if (m == MATCH_NO)
4351     goto syntax;
4352
4353   head = tail = new_iter;
4354
4355   for (;;)
4356     {
4357       if (gfc_match_char (',') != MATCH_YES)
4358         break;
4359
4360       m = match_forall_iterator (&new_iter);
4361       if (m == MATCH_ERROR)
4362         goto cleanup;
4363
4364       if (m == MATCH_YES)
4365         {
4366           tail->next = new_iter;
4367           tail = new_iter;
4368           continue;
4369         }
4370
4371       /* Have to have a mask expression.  */
4372
4373       m = gfc_match_expr (&msk);
4374       if (m == MATCH_NO)
4375         goto syntax;
4376       if (m == MATCH_ERROR)
4377         goto cleanup;
4378
4379       break;
4380     }
4381
4382   if (gfc_match_char (')') == MATCH_NO)
4383     goto syntax;
4384
4385   *phead = head;
4386   *mask = msk;
4387   return MATCH_YES;
4388
4389 syntax:
4390   gfc_syntax_error (ST_FORALL);
4391
4392 cleanup:
4393   gfc_free_expr (msk);
4394   gfc_free_forall_iterator (head);
4395
4396   return MATCH_ERROR;
4397 }
4398
4399 /* Match the rest of a simple FORALL statement that follows an
4400    IF statement.  */
4401
4402 static match
4403 match_simple_forall (void)
4404 {
4405   gfc_forall_iterator *head;
4406   gfc_expr *mask;
4407   gfc_code *c;
4408   match m;
4409
4410   mask = NULL;
4411   head = NULL;
4412   c = NULL;
4413
4414   m = match_forall_header (&head, &mask);
4415
4416   if (m == MATCH_NO)
4417     goto syntax;
4418   if (m != MATCH_YES)
4419     goto cleanup;
4420
4421   m = gfc_match_assignment ();
4422
4423   if (m == MATCH_ERROR)
4424     goto cleanup;
4425   if (m == MATCH_NO)
4426     {
4427       m = gfc_match_pointer_assignment ();
4428       if (m == MATCH_ERROR)
4429         goto cleanup;
4430       if (m == MATCH_NO)
4431         goto syntax;
4432     }
4433
4434   c = gfc_get_code ();
4435   *c = new_st;
4436   c->loc = gfc_current_locus;
4437
4438   if (gfc_match_eos () != MATCH_YES)
4439     goto syntax;
4440
4441   gfc_clear_new_st ();
4442   new_st.op = EXEC_FORALL;
4443   new_st.expr1 = mask;
4444   new_st.ext.forall_iterator = head;
4445   new_st.block = gfc_get_code ();
4446
4447   new_st.block->op = EXEC_FORALL;
4448   new_st.block->next = c;
4449
4450   return MATCH_YES;
4451
4452 syntax:
4453   gfc_syntax_error (ST_FORALL);
4454
4455 cleanup:
4456   gfc_free_forall_iterator (head);
4457   gfc_free_expr (mask);
4458
4459   return MATCH_ERROR;
4460 }
4461
4462
4463 /* Match a FORALL statement.  */
4464
4465 match
4466 gfc_match_forall (gfc_statement *st)
4467 {
4468   gfc_forall_iterator *head;
4469   gfc_expr *mask;
4470   gfc_code *c;
4471   match m0, m;
4472
4473   head = NULL;
4474   mask = NULL;
4475   c = NULL;
4476
4477   m0 = gfc_match_label ();
4478   if (m0 == MATCH_ERROR)
4479     return MATCH_ERROR;
4480
4481   m = gfc_match (" forall");
4482   if (m != MATCH_YES)
4483     return m;
4484
4485   m = match_forall_header (&head, &mask);
4486   if (m == MATCH_ERROR)
4487     goto cleanup;
4488   if (m == MATCH_NO)
4489     goto syntax;
4490
4491   if (gfc_match_eos () == MATCH_YES)
4492     {
4493       *st = ST_FORALL_BLOCK;
4494       new_st.op = EXEC_FORALL;
4495       new_st.expr1 = mask;
4496       new_st.ext.forall_iterator = head;
4497       return MATCH_YES;
4498     }
4499
4500   m = gfc_match_assignment ();
4501   if (m == MATCH_ERROR)
4502     goto cleanup;
4503   if (m == MATCH_NO)
4504     {
4505       m = gfc_match_pointer_assignment ();
4506       if (m == MATCH_ERROR)
4507         goto cleanup;
4508       if (m == MATCH_NO)
4509         goto syntax;
4510     }
4511
4512   c = gfc_get_code ();
4513   *c = new_st;
4514   c->loc = gfc_current_locus;
4515
4516   gfc_clear_new_st ();
4517   new_st.op = EXEC_FORALL;
4518   new_st.expr1 = mask;
4519   new_st.ext.forall_iterator = head;
4520   new_st.block = gfc_get_code ();
4521   new_st.block->op = EXEC_FORALL;
4522   new_st.block->next = c;
4523
4524   *st = ST_FORALL;
4525   return MATCH_YES;
4526
4527 syntax:
4528   gfc_syntax_error (ST_FORALL);
4529
4530 cleanup:
4531   gfc_free_forall_iterator (head);
4532   gfc_free_expr (mask);
4533   gfc_free_statements (c);
4534   return MATCH_NO;
4535 }