gcc/fortran/match.c

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