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),
  48     minit ("==", INTRINSIC_EQ),
  49     minit (".ne.", INTRINSIC_NE),
  50     minit ("/=", INTRINSIC_NE),
  51     minit (".ge.", INTRINSIC_GE),
  52     minit (">=", INTRINSIC_GE),
  53     minit (".le.", INTRINSIC_LE),
  54     minit ("<=", INTRINSIC_LE),
  55     minit (".lt.", INTRINSIC_LT),
  56     minit ("<", INTRINSIC_LT),
  57     minit (".gt.", INTRINSIC_GT),
  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   gfc_check_do_variable (iter.var->symtree);
1504
1505   if (gfc_match_eos () != MATCH_YES)
1506     {
1507       gfc_syntax_error (ST_DO);
1508       goto cleanup;
1509     }
1510
1511   new_st.op = EXEC_DO;
1512
1513 done:
1514   if (label != NULL
1515       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1516     goto cleanup;
1517
1518   new_st.label = label;
1519
1520   if (new_st.op == EXEC_DO_WHILE)
1521     new_st.expr = iter.end;
1522   else
1523     {
1524       new_st.ext.iterator = ip = gfc_get_iterator ();
1525       *ip = iter;
1526     }
1527
1528   return MATCH_YES;
1529
1530 cleanup:
1531   gfc_free_iterator (&iter, 0);
1532
1533   return MATCH_ERROR;
1534 }
1535
1536
1537 /* Match an EXIT or CYCLE statement.  */
1538
1539 static match
1540 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1541 {
1542   gfc_state_data *p, *o;
1543   gfc_symbol *sym;
1544   match m;
1545
1546   if (gfc_match_eos () == MATCH_YES)
1547     sym = NULL;
1548   else
1549     {
1550       m = gfc_match ("% %s%t", &sym);
1551       if (m == MATCH_ERROR)
1552         return MATCH_ERROR;
1553       if (m == MATCH_NO)
1554         {
1555           gfc_syntax_error (st);
1556           return MATCH_ERROR;
1557         }
1558
1559       if (sym->attr.flavor != FL_LABEL)
1560         {
1561           gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1562                      sym->name, gfc_ascii_statement (st));
1563           return MATCH_ERROR;
1564         }
1565     }
1566
1567   /* Find the loop mentioned specified by the label (or lack of a label).  */
1568   for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1569     if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1570       break;
1571     else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1572       o = p;
1573
1574   if (p == NULL)
1575     {
1576       if (sym == NULL)
1577         gfc_error ("%s statement at %C is not within a loop",
1578                    gfc_ascii_statement (st));
1579       else
1580         gfc_error ("%s statement at %C is not within loop '%s'",
1581                    gfc_ascii_statement (st), sym->name);
1582
1583       return MATCH_ERROR;
1584     }
1585
1586   if (o != NULL)
1587     {
1588       gfc_error ("%s statement at %C leaving OpenMP structured block",
1589                  gfc_ascii_statement (st));
1590       return MATCH_ERROR;
1591     }
1592   else if (st == ST_EXIT
1593            && p->previous != NULL
1594            && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1595            && (p->previous->head->op == EXEC_OMP_DO
1596                || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1597     {
1598       gcc_assert (p->previous->head->next != NULL);
1599       gcc_assert (p->previous->head->next->op == EXEC_DO
1600                   || p->previous->head->next->op == EXEC_DO_WHILE);
1601       gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1602       return MATCH_ERROR;
1603     }
1604
1605   /* Save the first statement in the loop - needed by the backend.  */
1606   new_st.ext.whichloop = p->head;
1607
1608   new_st.op = op;
1609
1610   return MATCH_YES;
1611 }
1612
1613
1614 /* Match the EXIT statement.  */
1615
1616 match
1617 gfc_match_exit (void)
1618 {
1619   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1620 }
1621
1622
1623 /* Match the CYCLE statement.  */
1624
1625 match
1626 gfc_match_cycle (void)
1627 {
1628   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1629 }
1630
1631
1632 /* Match a number or character constant after a STOP or PAUSE statement.  */
1633
1634 static match
1635 gfc_match_stopcode (gfc_statement st)
1636 {
1637   int stop_code;
1638   gfc_expr *e;
1639   match m;
1640   int cnt;
1641
1642   stop_code = -1;
1643   e = NULL;
1644
1645   if (gfc_match_eos () != MATCH_YES)
1646     {
1647       m = gfc_match_small_literal_int (&stop_code, &cnt);
1648       if (m == MATCH_ERROR)
1649         goto cleanup;
1650
1651       if (m == MATCH_YES && cnt > 5)
1652         {
1653           gfc_error ("Too many digits in STOP code at %C");
1654           goto cleanup;
1655         }
1656
1657       if (m == MATCH_NO)
1658         {
1659           /* Try a character constant.  */
1660           m = gfc_match_expr (&e);
1661           if (m == MATCH_ERROR)
1662             goto cleanup;
1663           if (m == MATCH_NO)
1664             goto syntax;
1665           if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1666             goto syntax;
1667         }
1668
1669       if (gfc_match_eos () != MATCH_YES)
1670         goto syntax;
1671     }
1672
1673   if (gfc_pure (NULL))
1674     {
1675       gfc_error ("%s statement not allowed in PURE procedure at %C",
1676                  gfc_ascii_statement (st));
1677       goto cleanup;
1678     }
1679
1680   new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1681   new_st.expr = e;
1682   new_st.ext.stop_code = stop_code;
1683
1684   return MATCH_YES;
1685
1686 syntax:
1687   gfc_syntax_error (st);
1688
1689 cleanup:
1690
1691   gfc_free_expr (e);
1692   return MATCH_ERROR;
1693 }
1694
1695
1696 /* Match the (deprecated) PAUSE statement.  */
1697
1698 match
1699 gfc_match_pause (void)
1700 {
1701   match m;
1702
1703   m = gfc_match_stopcode (ST_PAUSE);
1704   if (m == MATCH_YES)
1705     {
1706       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
1707           " at %C")
1708           == FAILURE)
1709         m = MATCH_ERROR;
1710     }
1711   return m;
1712 }
1713
1714
1715 /* Match the STOP statement.  */
1716
1717 match
1718 gfc_match_stop (void)
1719 {
1720   return gfc_match_stopcode (ST_STOP);
1721 }
1722
1723
1724 /* Match a CONTINUE statement.  */
1725
1726 match
1727 gfc_match_continue (void)
1728 {
1729   if (gfc_match_eos () != MATCH_YES)
1730     {
1731       gfc_syntax_error (ST_CONTINUE);
1732       return MATCH_ERROR;
1733     }
1734
1735   new_st.op = EXEC_CONTINUE;
1736   return MATCH_YES;
1737 }
1738
1739
1740 /* Match the (deprecated) ASSIGN statement.  */
1741
1742 match
1743 gfc_match_assign (void)
1744 {
1745   gfc_expr *expr;
1746   gfc_st_label *label;
1747
1748   if (gfc_match (" %l", &label) == MATCH_YES)
1749     {
1750       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
1751         return MATCH_ERROR;
1752       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
1753         {
1754           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
1755                               "statement at %C")
1756               == FAILURE)
1757             return MATCH_ERROR;
1758
1759           expr->symtree->n.sym->attr.assign = 1;
1760
1761           new_st.op = EXEC_LABEL_ASSIGN;
1762           new_st.label = label;
1763           new_st.expr = expr;
1764           return MATCH_YES;
1765         }
1766     }
1767   return MATCH_NO;
1768 }
1769
1770
1771 /* Match the GO TO statement.  As a computed GOTO statement is
1772    matched, it is transformed into an equivalent SELECT block.  No
1773    tree is necessary, and the resulting jumps-to-jumps are
1774    specifically optimized away by the back end.  */
1775
1776 match
1777 gfc_match_goto (void)
1778 {
1779   gfc_code *head, *tail;
1780   gfc_expr *expr;
1781   gfc_case *cp;
1782   gfc_st_label *label;
1783   int i;
1784   match m;
1785
1786   if (gfc_match (" %l%t", &label) == MATCH_YES)
1787     {
1788       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1789         return MATCH_ERROR;
1790
1791       new_st.op = EXEC_GOTO;
1792       new_st.label = label;
1793       return MATCH_YES;
1794     }
1795
1796   /* The assigned GO TO statement.  */
1797
1798   if (gfc_match_variable (&expr, 0) == MATCH_YES)
1799     {
1800       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
1801                           "statement at %C")
1802           == FAILURE)
1803         return MATCH_ERROR;
1804
1805       new_st.op = EXEC_GOTO;
1806       new_st.expr = expr;
1807
1808       if (gfc_match_eos () == MATCH_YES)
1809         return MATCH_YES;
1810
1811       /* Match label list.  */
1812       gfc_match_char (',');
1813       if (gfc_match_char ('(') != MATCH_YES)
1814         {
1815           gfc_syntax_error (ST_GOTO);
1816           return MATCH_ERROR;
1817         }
1818       head = tail = NULL;
1819
1820       do
1821         {
1822           m = gfc_match_st_label (&label);
1823           if (m != MATCH_YES)
1824             goto syntax;
1825
1826           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1827             goto cleanup;
1828
1829           if (head == NULL)
1830             head = tail = gfc_get_code ();
1831           else
1832             {
1833               tail->block = gfc_get_code ();
1834               tail = tail->block;
1835             }
1836
1837           tail->label = label;
1838           tail->op = EXEC_GOTO;
1839         }
1840       while (gfc_match_char (',') == MATCH_YES);
1841
1842       if (gfc_match (")%t") != MATCH_YES)
1843         goto syntax;
1844
1845       if (head == NULL)
1846         {
1847            gfc_error ("Statement label list in GOTO at %C cannot be empty");
1848            goto syntax;
1849         }
1850       new_st.block = head;
1851
1852       return MATCH_YES;
1853     }
1854
1855   /* Last chance is a computed GO TO statement.  */
1856   if (gfc_match_char ('(') != MATCH_YES)
1857     {
1858       gfc_syntax_error (ST_GOTO);
1859       return MATCH_ERROR;
1860     }
1861
1862   head = tail = NULL;
1863   i = 1;
1864
1865   do
1866     {
1867       m = gfc_match_st_label (&label);
1868       if (m != MATCH_YES)
1869         goto syntax;
1870
1871       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1872         goto cleanup;
1873
1874       if (head == NULL)
1875         head = tail = gfc_get_code ();
1876       else
1877         {
1878           tail->block = gfc_get_code ();
1879           tail = tail->block;
1880         }
1881
1882       cp = gfc_get_case ();
1883       cp->low = cp->high = gfc_int_expr (i++);
1884
1885       tail->op = EXEC_SELECT;
1886       tail->ext.case_list = cp;
1887
1888       tail->next = gfc_get_code ();
1889       tail->next->op = EXEC_GOTO;
1890       tail->next->label = label;
1891     }
1892   while (gfc_match_char (',') == MATCH_YES);
1893
1894   if (gfc_match_char (')') != MATCH_YES)
1895     goto syntax;
1896
1897   if (head == NULL)
1898     {
1899       gfc_error ("Statement label list in GOTO at %C cannot be empty");
1900       goto syntax;
1901     }
1902
1903   /* Get the rest of the statement.  */
1904   gfc_match_char (',');
1905
1906   if (gfc_match (" %e%t", &expr) != MATCH_YES)
1907     goto syntax;
1908
1909   /* At this point, a computed GOTO has been fully matched and an
1910      equivalent SELECT statement constructed.  */
1911
1912   new_st.op = EXEC_SELECT;
1913   new_st.expr = NULL;
1914
1915   /* Hack: For a "real" SELECT, the expression is in expr. We put
1916      it in expr2 so we can distinguish then and produce the correct
1917      diagnostics.  */
1918   new_st.expr2 = expr;
1919   new_st.block = head;
1920   return MATCH_YES;
1921
1922 syntax:
1923   gfc_syntax_error (ST_GOTO);
1924 cleanup:
1925   gfc_free_statements (head);
1926   return MATCH_ERROR;
1927 }
1928
1929
1930 /* Frees a list of gfc_alloc structures.  */
1931
1932 void
1933 gfc_free_alloc_list (gfc_alloc *p)
1934 {
1935   gfc_alloc *q;
1936
1937   for (; p; p = q)
1938     {
1939       q = p->next;
1940       gfc_free_expr (p->expr);
1941       gfc_free (p);
1942     }
1943 }
1944
1945
1946 /* Match an ALLOCATE statement.  */
1947
1948 match
1949 gfc_match_allocate (void)
1950 {
1951   gfc_alloc *head, *tail;
1952   gfc_expr *stat;
1953   match m;
1954
1955   head = tail = NULL;
1956   stat = NULL;
1957
1958   if (gfc_match_char ('(') != MATCH_YES)
1959     goto syntax;
1960
1961   for (;;)
1962     {
1963       if (head == NULL)
1964         head = tail = gfc_get_alloc ();
1965       else
1966         {
1967           tail->next = gfc_get_alloc ();
1968           tail = tail->next;
1969         }
1970
1971       m = gfc_match_variable (&tail->expr, 0);
1972       if (m == MATCH_NO)
1973         goto syntax;
1974       if (m == MATCH_ERROR)
1975         goto cleanup;
1976
1977       if (gfc_check_do_variable (tail->expr->symtree))
1978         goto cleanup;
1979
1980       if (gfc_pure (NULL)
1981           && gfc_impure_variable (tail->expr->symtree->n.sym))
1982         {
1983           gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1984                      "PURE procedure");
1985           goto cleanup;
1986         }
1987
1988       if (tail->expr->ts.type == BT_DERIVED)
1989         tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
1990
1991       if (gfc_match_char (',') != MATCH_YES)
1992         break;
1993
1994       m = gfc_match (" stat = %v", &stat);
1995       if (m == MATCH_ERROR)
1996         goto cleanup;
1997       if (m == MATCH_YES)
1998         break;
1999     }
2000
2001   if (stat != NULL)
2002     {
2003       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
2004         {
2005           gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot "
2006                      "be INTENT(IN)", stat->symtree->n.sym->name);
2007           goto cleanup;
2008         }
2009
2010       if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
2011         {
2012           gfc_error ("Illegal STAT variable in ALLOCATE statement at %C "
2013                      "for a PURE procedure");
2014           goto cleanup;
2015         }
2016
2017       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
2018         {
2019           gfc_error ("STAT expression at %C must be a variable");
2020           goto cleanup;
2021         }
2022
2023       gfc_check_do_variable(stat->symtree);
2024     }
2025
2026   if (gfc_match (" )%t") != MATCH_YES)
2027     goto syntax;
2028
2029   new_st.op = EXEC_ALLOCATE;
2030   new_st.expr = stat;
2031   new_st.ext.alloc_list = head;
2032
2033   return MATCH_YES;
2034
2035 syntax:
2036   gfc_syntax_error (ST_ALLOCATE);
2037
2038 cleanup:
2039   gfc_free_expr (stat);
2040   gfc_free_alloc_list (head);
2041   return MATCH_ERROR;
2042 }
2043
2044
2045 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2046    a set of pointer assignments to intrinsic NULL().  */
2047
2048 match
2049 gfc_match_nullify (void)
2050 {
2051   gfc_code *tail;
2052   gfc_expr *e, *p;
2053   match m;
2054
2055   tail = NULL;
2056
2057   if (gfc_match_char ('(') != MATCH_YES)
2058     goto syntax;
2059
2060   for (;;)
2061     {
2062       m = gfc_match_variable (&p, 0);
2063       if (m == MATCH_ERROR)
2064         goto cleanup;
2065       if (m == MATCH_NO)
2066         goto syntax;
2067
2068       if (gfc_check_do_variable (p->symtree))
2069         goto cleanup;
2070
2071       if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
2072         {
2073           gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2074           goto cleanup;
2075         }
2076
2077       /* build ' => NULL() '.  */
2078       e = gfc_get_expr ();
2079       e->where = gfc_current_locus;
2080       e->expr_type = EXPR_NULL;
2081       e->ts.type = BT_UNKNOWN;
2082
2083       /* Chain to list.  */
2084       if (tail == NULL)
2085         tail = &new_st;
2086       else
2087         {
2088           tail->next = gfc_get_code ();
2089           tail = tail->next;
2090         }
2091
2092       tail->op = EXEC_POINTER_ASSIGN;
2093       tail->expr = p;
2094       tail->expr2 = e;
2095
2096       if (gfc_match (" )%t") == MATCH_YES)
2097         break;
2098       if (gfc_match_char (',') != MATCH_YES)
2099         goto syntax;
2100     }
2101
2102   return MATCH_YES;
2103
2104 syntax:
2105   gfc_syntax_error (ST_NULLIFY);
2106
2107 cleanup:
2108   gfc_free_statements (new_st.next);
2109   return MATCH_ERROR;
2110 }
2111
2112
2113 /* Match a DEALLOCATE statement.  */
2114
2115 match
2116 gfc_match_deallocate (void)
2117 {
2118   gfc_alloc *head, *tail;
2119   gfc_expr *stat;
2120   match m;
2121
2122   head = tail = NULL;
2123   stat = NULL;
2124
2125   if (gfc_match_char ('(') != MATCH_YES)
2126     goto syntax;
2127
2128   for (;;)
2129     {
2130       if (head == NULL)
2131         head = tail = gfc_get_alloc ();
2132       else
2133         {
2134           tail->next = gfc_get_alloc ();
2135           tail = tail->next;
2136         }
2137
2138       m = gfc_match_variable (&tail->expr, 0);
2139       if (m == MATCH_ERROR)
2140         goto cleanup;
2141       if (m == MATCH_NO)
2142         goto syntax;
2143
2144       if (gfc_check_do_variable (tail->expr->symtree))
2145         goto cleanup;
2146
2147       if (gfc_pure (NULL)
2148           && gfc_impure_variable (tail->expr->symtree->n.sym))
2149         {
2150           gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
2151                      "for a PURE procedure");
2152           goto cleanup;
2153         }
2154
2155       if (gfc_match_char (',') != MATCH_YES)
2156         break;
2157
2158       m = gfc_match (" stat = %v", &stat);
2159       if (m == MATCH_ERROR)
2160         goto cleanup;
2161       if (m == MATCH_YES)
2162         break;
2163     }
2164
2165   if (stat != NULL)
2166     {
2167       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
2168         {
2169           gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
2170                      "cannot be INTENT(IN)", stat->symtree->n.sym->name);
2171           goto cleanup;
2172         }
2173
2174       if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
2175         {
2176           gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
2177                      "for a PURE procedure");
2178           goto cleanup;
2179         }
2180
2181       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
2182         {
2183           gfc_error ("STAT expression at %C must be a variable");
2184           goto cleanup;
2185         }
2186
2187       gfc_check_do_variable(stat->symtree);
2188     }
2189
2190   if (gfc_match (" )%t") != MATCH_YES)
2191     goto syntax;
2192
2193   new_st.op = EXEC_DEALLOCATE;
2194   new_st.expr = stat;
2195   new_st.ext.alloc_list = head;
2196
2197   return MATCH_YES;
2198
2199 syntax:
2200   gfc_syntax_error (ST_DEALLOCATE);
2201
2202 cleanup:
2203   gfc_free_expr (stat);
2204   gfc_free_alloc_list (head);
2205   return MATCH_ERROR;
2206 }
2207
2208
2209 /* Match a RETURN statement.  */
2210
2211 match
2212 gfc_match_return (void)
2213 {
2214   gfc_expr *e;
2215   match m;
2216   gfc_compile_state s;
2217   int c;
2218
2219   e = NULL;
2220   if (gfc_match_eos () == MATCH_YES)
2221     goto done;
2222
2223   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2224     {
2225       gfc_error ("Alternate RETURN statement at %C is only allowed within "
2226                  "a SUBROUTINE");
2227       goto cleanup;
2228     }
2229
2230   if (gfc_current_form == FORM_FREE)
2231     {
2232       /* The following are valid, so we can't require a blank after the
2233         RETURN keyword:
2234           return+1
2235           return(1)  */
2236       c = gfc_peek_char ();
2237       if (ISALPHA (c) || ISDIGIT (c))
2238         return MATCH_NO;
2239     }
2240
2241   m = gfc_match (" %e%t", &e);
2242   if (m == MATCH_YES)
2243     goto done;
2244   if (m == MATCH_ERROR)
2245     goto cleanup;
2246
2247   gfc_syntax_error (ST_RETURN);
2248
2249 cleanup:
2250   gfc_free_expr (e);
2251   return MATCH_ERROR;
2252
2253 done:
2254   gfc_enclosing_unit (&s);
2255   if (s == COMP_PROGRAM
2256       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2257                         "main program at %C") == FAILURE)
2258       return MATCH_ERROR;
2259
2260   new_st.op = EXEC_RETURN;
2261   new_st.expr = e;
2262
2263   return MATCH_YES;
2264 }
2265
2266
2267 /* Match a CALL statement.  The tricky part here are possible
2268    alternate return specifiers.  We handle these by having all
2269    "subroutines" actually return an integer via a register that gives
2270    the return number.  If the call specifies alternate returns, we
2271    generate code for a SELECT statement whose case clauses contain
2272    GOTOs to the various labels.  */
2273
2274 match
2275 gfc_match_call (void)
2276 {
2277   char name[GFC_MAX_SYMBOL_LEN + 1];
2278   gfc_actual_arglist *a, *arglist;
2279   gfc_case *new_case;
2280   gfc_symbol *sym;
2281   gfc_symtree *st;
2282   gfc_code *c;
2283   match m;
2284   int i;
2285
2286   arglist = NULL;
2287
2288   m = gfc_match ("% %n", name);
2289   if (m == MATCH_NO)
2290     goto syntax;
2291   if (m != MATCH_YES)
2292     return m;
2293
2294   if (gfc_get_ha_sym_tree (name, &st))
2295     return MATCH_ERROR;
2296
2297   sym = st->n.sym;
2298
2299   if (sym->ns != gfc_current_ns
2300         && !sym->attr.generic
2301         && !sym->attr.subroutine
2302         && gfc_get_sym_tree (name, NULL, &st) == 1)
2303     return MATCH_ERROR;
2304
2305   sym = st->n.sym;
2306
2307   if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2308     return MATCH_ERROR;
2309
2310   gfc_set_sym_referenced (sym);
2311
2312   if (gfc_match_eos () != MATCH_YES)
2313     {
2314       m = gfc_match_actual_arglist (1, &arglist);
2315       if (m == MATCH_NO)
2316         goto syntax;
2317       if (m == MATCH_ERROR)
2318         goto cleanup;
2319
2320       if (gfc_match_eos () != MATCH_YES)
2321         goto syntax;
2322     }
2323
2324   /* If any alternate return labels were found, construct a SELECT
2325      statement that will jump to the right place.  */
2326
2327   i = 0;
2328   for (a = arglist; a; a = a->next)
2329     if (a->expr == NULL)
2330       i = 1;
2331
2332   if (i)
2333     {
2334       gfc_symtree *select_st;
2335       gfc_symbol *select_sym;
2336       char name[GFC_MAX_SYMBOL_LEN + 1];
2337
2338       new_st.next = c = gfc_get_code ();
2339       c->op = EXEC_SELECT;
2340       sprintf (name, "_result_%s", sym->name);
2341       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
2342
2343       select_sym = select_st->n.sym;
2344       select_sym->ts.type = BT_INTEGER;
2345       select_sym->ts.kind = gfc_default_integer_kind;
2346       gfc_set_sym_referenced (select_sym);
2347       c->expr = gfc_get_expr ();
2348       c->expr->expr_type = EXPR_VARIABLE;
2349       c->expr->symtree = select_st;
2350       c->expr->ts = select_sym->ts;
2351       c->expr->where = gfc_current_locus;
2352
2353       i = 0;
2354       for (a = arglist; a; a = a->next)
2355         {
2356           if (a->expr != NULL)
2357             continue;
2358
2359           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2360             continue;
2361
2362           i++;
2363
2364           c->block = gfc_get_code ();
2365           c = c->block;
2366           c->op = EXEC_SELECT;
2367
2368           new_case = gfc_get_case ();
2369           new_case->high = new_case->low = gfc_int_expr (i);
2370           c->ext.case_list = new_case;
2371
2372           c->next = gfc_get_code ();
2373           c->next->op = EXEC_GOTO;
2374           c->next->label = a->label;
2375         }
2376     }
2377
2378   new_st.op = EXEC_CALL;
2379   new_st.symtree = st;
2380   new_st.ext.actual = arglist;
2381
2382   return MATCH_YES;
2383
2384 syntax:
2385   gfc_syntax_error (ST_CALL);
2386
2387 cleanup:
2388   gfc_free_actual_arglist (arglist);
2389   return MATCH_ERROR;
2390 }
2391
2392
2393 /* Given a name, return a pointer to the common head structure,
2394    creating it if it does not exist. If FROM_MODULE is nonzero, we
2395    mangle the name so that it doesn't interfere with commons defined
2396    in the using namespace.
2397    TODO: Add to global symbol tree.  */
2398
2399 gfc_common_head *
2400 gfc_get_common (const char *name, int from_module)
2401 {
2402   gfc_symtree *st;
2403   static int serial = 0;
2404   char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
2405
2406   if (from_module)
2407     {
2408       /* A use associated common block is only needed to correctly layout
2409          the variables it contains.  */
2410       snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2411       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2412     }
2413   else
2414     {
2415       st = gfc_find_symtree (gfc_current_ns->common_root, name);
2416
2417       if (st == NULL)
2418         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2419     }
2420
2421   if (st->n.common == NULL)
2422     {
2423       st->n.common = gfc_get_common_head ();
2424       st->n.common->where = gfc_current_locus;
2425       strcpy (st->n.common->name, name);
2426     }
2427
2428   return st->n.common;
2429 }
2430
2431
2432 /* Match a common block name.  */
2433
2434 match match_common_name (char *name)
2435 {
2436   match m;
2437
2438   if (gfc_match_char ('/') == MATCH_NO)
2439     {
2440       name[0] = '\0';
2441       return MATCH_YES;
2442     }
2443
2444   if (gfc_match_char ('/') == MATCH_YES)
2445     {
2446       name[0] = '\0';
2447       return MATCH_YES;
2448     }
2449
2450   m = gfc_match_name (name);
2451
2452   if (m == MATCH_ERROR)
2453     return MATCH_ERROR;
2454   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2455     return MATCH_YES;
2456
2457   gfc_error ("Syntax error in common block name at %C");
2458   return MATCH_ERROR;
2459 }
2460
2461
2462 /* Match a COMMON statement.  */
2463
2464 match
2465 gfc_match_common (void)
2466 {
2467   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2468   char name[GFC_MAX_SYMBOL_LEN + 1];
2469   gfc_common_head *t;
2470   gfc_array_spec *as;
2471   gfc_equiv *e1, *e2;
2472   match m;
2473   gfc_gsymbol *gsym;
2474
2475   old_blank_common = gfc_current_ns->blank_common.head;
2476   if (old_blank_common)
2477     {
2478       while (old_blank_common->common_next)
2479         old_blank_common = old_blank_common->common_next;
2480     }
2481
2482   as = NULL;
2483
2484   for (;;)
2485     {
2486       m = match_common_name (name);
2487       if (m == MATCH_ERROR)
2488         goto cleanup;
2489
2490       gsym = gfc_get_gsymbol (name);
2491       if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
2492         {
2493           gfc_error ("Symbol '%s' at %C is already an external symbol that "
2494                      "is not COMMON", name);
2495           goto cleanup;
2496         }
2497
2498       if (gsym->type == GSYM_UNKNOWN)
2499         {
2500           gsym->type = GSYM_COMMON;
2501           gsym->where = gfc_current_locus;
2502           gsym->defined = 1;
2503         }
2504
2505       gsym->used = 1;
2506
2507       if (name[0] == '\0')
2508         {
2509           if (gfc_current_ns->is_block_data)
2510             {
2511               gfc_warning ("BLOCK DATA unit cannot contain blank COMMON "
2512                            "at %C");
2513             }
2514           t = &gfc_current_ns->blank_common;
2515           if (t->head == NULL)
2516             t->where = gfc_current_locus;
2517         }
2518       else
2519         {
2520           t = gfc_get_common (name, 0);
2521         }
2522       head = &t->head;
2523
2524       if (*head == NULL)
2525         tail = NULL;
2526       else
2527         {
2528           tail = *head;
2529           while (tail->common_next)
2530             tail = tail->common_next;
2531         }
2532
2533       /* Grab the list of symbols.  */
2534       for (;;)
2535         {
2536           m = gfc_match_symbol (&sym, 0);
2537           if (m == MATCH_ERROR)
2538             goto cleanup;
2539           if (m == MATCH_NO)
2540             goto syntax;
2541
2542           /* Store a ref to the common block for error checking.  */
2543           sym->common_block = t;
2544
2545           /* See if we know the current common block is bind(c), and if
2546              so, then see if we can check if the symbol is (which it'll
2547              need to be).  This can happen if the bind(c) attr stmt was
2548              applied to the common block, and the variable(s) already
2549              defined, before declaring the common block.  */
2550           if (t->is_bind_c == 1)
2551             {
2552               if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
2553                 {
2554                   /* If we find an error, just print it and continue,
2555                      cause it's just semantic, and we can see if there
2556                      are more errors.  */
2557                   gfc_error_now ("Variable '%s' at %L in common block '%s' "
2558                                  "at %C must be declared with a C "
2559                                  "interoperable kind since common block "
2560                                  "'%s' is bind(c)",
2561                                  sym->name, &(sym->declared_at), t->name,
2562                                  t->name);
2563                 }
2564
2565               if (sym->attr.is_bind_c == 1)
2566                 gfc_error_now ("Variable '%s' in common block "
2567                                "'%s' at %C can not be bind(c) since "
2568                                "it is not global", sym->name, t->name);
2569             }
2570
2571           if (sym->attr.in_common)
2572             {
2573               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2574                          sym->name);
2575               goto cleanup;
2576             }
2577
2578           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2579             goto cleanup;
2580
2581           if (sym->value != NULL && sym->value->expr_type != EXPR_NULL
2582               && (name[0] == '\0' || !sym->attr.data))
2583             {
2584               if (name[0] == '\0')
2585                 gfc_error ("Previously initialized symbol '%s' in "
2586                            "blank COMMON block at %C", sym->name);
2587               else
2588                 gfc_error ("Previously initialized symbol '%s' in "
2589                            "COMMON block '%s' at %C", sym->name, name);
2590               goto cleanup;
2591             }
2592
2593           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2594             goto cleanup;
2595
2596           /* Derived type names must have the SEQUENCE attribute.  */
2597           if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2598             {
2599               gfc_error ("Derived type variable in COMMON at %C does not "
2600                          "have the SEQUENCE attribute");
2601               goto cleanup;
2602             }
2603
2604           if (tail != NULL)
2605             tail->common_next = sym;
2606           else
2607             *head = sym;
2608
2609           tail = sym;
2610
2611           /* Deal with an optional array specification after the
2612              symbol name.  */
2613           m = gfc_match_array_spec (&as);
2614           if (m == MATCH_ERROR)
2615             goto cleanup;
2616
2617           if (m == MATCH_YES)
2618             {
2619               if (as->type != AS_EXPLICIT)
2620                 {
2621                   gfc_error ("Array specification for symbol '%s' in COMMON "
2622                              "at %C must be explicit", sym->name);
2623                   goto cleanup;
2624                 }
2625
2626               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2627                 goto cleanup;
2628
2629               if (sym->attr.pointer)
2630                 {
2631                   gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
2632                              "POINTER array", sym->name);
2633                   goto cleanup;
2634                 }
2635
2636               sym->as = as;
2637               as = NULL;
2638
2639             }
2640
2641           sym->common_head = t;
2642
2643           /* Check to see if the symbol is already in an equivalence group.
2644              If it is, set the other members as being in common.  */
2645           if (sym->attr.in_equivalence)
2646             {
2647               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2648                 {
2649                   for (e2 = e1; e2; e2 = e2->eq)
2650                     if (e2->expr->symtree->n.sym == sym)
2651                       goto equiv_found;
2652
2653                   continue;
2654
2655           equiv_found:
2656
2657                   for (e2 = e1; e2; e2 = e2->eq)
2658                     {
2659                       other = e2->expr->symtree->n.sym;
2660                       if (other->common_head
2661                           && other->common_head != sym->common_head)
2662                         {
2663                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
2664                                      "%C is being indirectly equivalenced to "
2665                                      "another COMMON block '%s'",
2666                                      sym->name, sym->common_head->name,
2667                                      other->common_head->name);
2668                             goto cleanup;
2669                         }
2670                       other->attr.in_common = 1;
2671                       other->common_head = t;
2672                     }
2673                 }
2674             }
2675
2676
2677           gfc_gobble_whitespace ();
2678           if (gfc_match_eos () == MATCH_YES)
2679             goto done;
2680           if (gfc_peek_char () == '/')
2681             break;
2682           if (gfc_match_char (',') != MATCH_YES)
2683             goto syntax;
2684           gfc_gobble_whitespace ();
2685           if (gfc_peek_char () == '/')
2686             break;
2687         }
2688     }
2689
2690 done:
2691   return MATCH_YES;
2692
2693 syntax:
2694   gfc_syntax_error (ST_COMMON);
2695
2696 cleanup:
2697   if (old_blank_common)
2698     old_blank_common->common_next = NULL;
2699   else
2700     gfc_current_ns->blank_common.head = NULL;
2701   gfc_free_array_spec (as);
2702   return MATCH_ERROR;
2703 }
2704
2705
2706 /* Match a BLOCK DATA program unit.  */
2707
2708 match
2709 gfc_match_block_data (void)
2710 {
2711   char name[GFC_MAX_SYMBOL_LEN + 1];
2712   gfc_symbol *sym;
2713   match m;
2714
2715   if (gfc_match_eos () == MATCH_YES)
2716     {
2717       gfc_new_block = NULL;
2718       return MATCH_YES;
2719     }
2720
2721   m = gfc_match ("% %n%t", name);
2722   if (m != MATCH_YES)
2723     return MATCH_ERROR;
2724
2725   if (gfc_get_symbol (name, NULL, &sym))
2726     return MATCH_ERROR;
2727
2728   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2729     return MATCH_ERROR;
2730
2731   gfc_new_block = sym;
2732
2733   return MATCH_YES;
2734 }
2735
2736
2737 /* Free a namelist structure.  */
2738
2739 void
2740 gfc_free_namelist (gfc_namelist *name)
2741 {
2742   gfc_namelist *n;
2743
2744   for (; name; name = n)
2745     {
2746       n = name->next;
2747       gfc_free (name);
2748     }
2749 }
2750
2751
2752 /* Match a NAMELIST statement.  */
2753
2754 match
2755 gfc_match_namelist (void)
2756 {
2757   gfc_symbol *group_name, *sym;
2758   gfc_namelist *nl;
2759   match m, m2;
2760
2761   m = gfc_match (" / %s /", &group_name);
2762   if (m == MATCH_NO)
2763     goto syntax;
2764   if (m == MATCH_ERROR)
2765     goto error;
2766
2767   for (;;)
2768     {
2769       if (group_name->ts.type != BT_UNKNOWN)
2770         {
2771           gfc_error ("Namelist group name '%s' at %C already has a basic "
2772                      "type of %s", group_name->name,
2773                      gfc_typename (&group_name->ts));
2774           return MATCH_ERROR;
2775         }
2776
2777       if (group_name->attr.flavor == FL_NAMELIST
2778           && group_name->attr.use_assoc
2779           && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
2780                              "at %C already is USE associated and can"
2781                              "not be respecified.", group_name->name)
2782              == FAILURE)
2783         return MATCH_ERROR;
2784
2785       if (group_name->attr.flavor != FL_NAMELIST
2786           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2787                              group_name->name, NULL) == FAILURE)
2788         return MATCH_ERROR;
2789
2790       for (;;)
2791         {
2792           m = gfc_match_symbol (&sym, 1);
2793           if (m == MATCH_NO)
2794             goto syntax;
2795           if (m == MATCH_ERROR)
2796             goto error;
2797
2798           if (sym->attr.in_namelist == 0
2799               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
2800             goto error;
2801
2802           /* Use gfc_error_check here, rather than goto error, so that
2803              these are the only errors for the next two lines.  */
2804           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
2805             {
2806               gfc_error ("Assumed size array '%s' in namelist '%s' at "
2807                          "%C is not allowed", sym->name, group_name->name);
2808               gfc_error_check ();
2809             }
2810
2811           if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
2812             {
2813               gfc_error ("Assumed character length '%s' in namelist '%s' at "
2814                          "%C is not allowed", sym->name, group_name->name);
2815               gfc_error_check ();
2816             }
2817
2818           if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
2819               && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
2820                                  "namelist '%s' at %C is an extension.",
2821                                  sym->name, group_name->name) == FAILURE)
2822             gfc_error_check ();
2823
2824           nl = gfc_get_namelist ();
2825           nl->sym = sym;
2826           sym->refs++;
2827
2828           if (group_name->namelist == NULL)
2829             group_name->namelist = group_name->namelist_tail = nl;
2830           else
2831             {
2832               group_name->namelist_tail->next = nl;
2833               group_name->namelist_tail = nl;
2834             }
2835
2836           if (gfc_match_eos () == MATCH_YES)
2837             goto done;
2838
2839           m = gfc_match_char (',');
2840
2841           if (gfc_match_char ('/') == MATCH_YES)
2842             {
2843               m2 = gfc_match (" %s /", &group_name);
2844               if (m2 == MATCH_YES)
2845                 break;
2846               if (m2 == MATCH_ERROR)
2847                 goto error;
2848               goto syntax;
2849             }
2850
2851           if (m != MATCH_YES)
2852             goto syntax;
2853         }
2854     }
2855
2856 done:
2857   return MATCH_YES;
2858
2859 syntax:
2860   gfc_syntax_error (ST_NAMELIST);
2861
2862 error:
2863   return MATCH_ERROR;
2864 }
2865
2866
2867 /* Match a MODULE statement.  */
2868
2869 match
2870 gfc_match_module (void)
2871 {
2872   match m;
2873
2874   m = gfc_match (" %s%t", &gfc_new_block);
2875   if (m != MATCH_YES)
2876     return m;
2877
2878   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2879                       gfc_new_block->name, NULL) == FAILURE)
2880     return MATCH_ERROR;
2881
2882   return MATCH_YES;
2883 }
2884
2885
2886 /* Free equivalence sets and lists.  Recursively is the easiest way to
2887    do this.  */
2888
2889 void
2890 gfc_free_equiv (gfc_equiv *eq)
2891 {
2892   if (eq == NULL)
2893     return;
2894
2895   gfc_free_equiv (eq->eq);
2896   gfc_free_equiv (eq->next);
2897   gfc_free_expr (eq->expr);
2898   gfc_free (eq);
2899 }
2900
2901
2902 /* Match an EQUIVALENCE statement.  */
2903
2904 match
2905 gfc_match_equivalence (void)
2906 {
2907   gfc_equiv *eq, *set, *tail;
2908   gfc_ref *ref;
2909   gfc_symbol *sym;
2910   match m;
2911   gfc_common_head *common_head = NULL;
2912   bool common_flag;
2913   int cnt;
2914
2915   tail = NULL;
2916
2917   for (;;)
2918     {
2919       eq = gfc_get_equiv ();
2920       if (tail == NULL)
2921         tail = eq;
2922
2923       eq->next = gfc_current_ns->equiv;
2924       gfc_current_ns->equiv = eq;
2925
2926       if (gfc_match_char ('(') != MATCH_YES)
2927         goto syntax;
2928
2929       set = eq;
2930       common_flag = FALSE;
2931       cnt = 0;
2932
2933       for (;;)
2934         {
2935           m = gfc_match_equiv_variable (&set->expr);
2936           if (m == MATCH_ERROR)
2937             goto cleanup;
2938           if (m == MATCH_NO)
2939             goto syntax;
2940
2941           /*  count the number of objects.  */
2942           cnt++;
2943
2944           if (gfc_match_char ('%') == MATCH_YES)
2945             {
2946               gfc_error ("Derived type component %C is not a "
2947                          "permitted EQUIVALENCE member");
2948               goto cleanup;
2949             }
2950
2951           for (ref = set->expr->ref; ref; ref = ref->next)
2952             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2953               {
2954                 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
2955                            "be an array section");
2956                 goto cleanup;
2957               }
2958
2959           sym = set->expr->symtree->n.sym;
2960
2961           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
2962             goto cleanup;
2963
2964           if (sym->attr.in_common)
2965             {
2966               common_flag = TRUE;
2967               common_head = sym->common_head;
2968             }
2969
2970           if (gfc_match_char (')') == MATCH_YES)
2971             break;
2972
2973           if (gfc_match_char (',') != MATCH_YES)
2974             goto syntax;
2975
2976           set->eq = gfc_get_equiv ();
2977           set = set->eq;
2978         }
2979
2980       if (cnt < 2)
2981         {
2982           gfc_error ("EQUIVALENCE at %C requires two or more objects");
2983           goto cleanup;
2984         }
2985
2986       /* If one of the members of an equivalence is in common, then
2987          mark them all as being in common.  Before doing this, check
2988          that members of the equivalence group are not in different
2989          common blocks.  */
2990       if (common_flag)
2991         for (set = eq; set; set = set->eq)
2992           {
2993             sym = set->expr->symtree->n.sym;
2994             if (sym->common_head && sym->common_head != common_head)
2995               {
2996                 gfc_error ("Attempt to indirectly overlap COMMON "
2997                            "blocks %s and %s by EQUIVALENCE at %C",
2998                            sym->common_head->name, common_head->name);
2999                 goto cleanup;
3000               }
3001             sym->attr.in_common = 1;
3002             sym->common_head = common_head;
3003           }
3004
3005       if (gfc_match_eos () == MATCH_YES)
3006         break;
3007       if (gfc_match_char (',') != MATCH_YES)
3008         goto syntax;
3009     }
3010
3011   return MATCH_YES;
3012
3013 syntax:
3014   gfc_syntax_error (ST_EQUIVALENCE);
3015
3016 cleanup:
3017   eq = tail->next;
3018   tail->next = NULL;
3019
3020   gfc_free_equiv (gfc_current_ns->equiv);
3021   gfc_current_ns->equiv = eq;
3022
3023   return MATCH_ERROR;
3024 }
3025
3026
3027 /* Check that a statement function is not recursive. This is done by looking
3028    for the statement function symbol(sym) by looking recursively through its
3029    expression(e).  If a reference to sym is found, true is returned.
3030    12.5.4 requires that any variable of function that is implicitly typed
3031    shall have that type confirmed by any subsequent type declaration.  The
3032    implicit typing is conveniently done here.  */
3033
3034 static bool
3035 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
3036 {
3037   gfc_actual_arglist *arg;
3038   gfc_ref *ref;
3039   int i;
3040
3041   if (e == NULL)
3042     return false;
3043
3044   switch (e->expr_type)
3045     {
3046     case EXPR_FUNCTION:
3047       for (arg = e->value.function.actual; arg; arg = arg->next)
3048         {
3049           if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym))
3050             return true;
3051         }
3052
3053       if (e->symtree == NULL)
3054         return false;
3055
3056       /* Check the name before testing for nested recursion!  */
3057       if (sym->name == e->symtree->n.sym->name)
3058         return true;
3059
3060       /* Catch recursion via other statement functions.  */
3061       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
3062           && e->symtree->n.sym->value
3063           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
3064         return true;
3065
3066       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3067         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3068
3069       break;
3070
3071     case EXPR_VARIABLE:
3072       if (e->symtree && sym->name == e->symtree->n.sym->name)
3073         return true;
3074
3075       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3076         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3077       break;
3078
3079     case EXPR_OP:
3080       if (recursive_stmt_fcn (e->value.op.op1, sym)
3081           || recursive_stmt_fcn (e->value.op.op2, sym))
3082         return true;
3083       break;
3084
3085     default:
3086       break;
3087     }
3088
3089   /* Component references do not need to be checked.  */
3090   if (e->ref)
3091     {
3092       for (ref = e->ref; ref; ref = ref->next)
3093         {
3094           switch (ref->type)
3095             {
3096             case REF_ARRAY:
3097               for (i = 0; i < ref->u.ar.dimen; i++)
3098                 {
3099                   if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
3100                       || recursive_stmt_fcn (ref->u.ar.end[i], sym)
3101                       || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
3102                     return true;
3103                 }
3104               break;
3105
3106             case REF_SUBSTRING:
3107               if (recursive_stmt_fcn (ref->u.ss.start, sym)
3108                   || recursive_stmt_fcn (ref->u.ss.end, sym))
3109                 return true;
3110
3111               break;
3112
3113             default:
3114               break;
3115             }
3116         }
3117     }
3118   return false;
3119 }
3120
3121
3122 /* Match a statement function declaration.  It is so easy to match
3123    non-statement function statements with a MATCH_ERROR as opposed to
3124    MATCH_NO that we suppress error message in most cases.  */
3125
3126 match
3127 gfc_match_st_function (void)
3128 {
3129   gfc_error_buf old_error;
3130   gfc_symbol *sym;
3131   gfc_expr *expr;
3132   match m;
3133
3134   m = gfc_match_symbol (&sym, 0);
3135   if (m != MATCH_YES)
3136     return m;
3137
3138   gfc_push_error (&old_error);
3139
3140   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
3141                          sym->name, NULL) == FAILURE)
3142     goto undo_error;
3143
3144   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
3145     goto undo_error;
3146
3147   m = gfc_match (" = %e%t", &expr);
3148   if (m == MATCH_NO)
3149     goto undo_error;
3150
3151   gfc_free_error (&old_error);
3152   if (m == MATCH_ERROR)
3153     return m;
3154
3155   if (recursive_stmt_fcn (expr, sym))
3156     {
3157       gfc_error ("Statement function at %L is recursive", &expr->where);
3158       return MATCH_ERROR;
3159     }
3160
3161   sym->value = expr;
3162
3163   return MATCH_YES;
3164
3165 undo_error:
3166   gfc_pop_error (&old_error);
3167   return MATCH_NO;
3168 }
3169
3170
3171 /***************** SELECT CASE subroutines ******************/
3172
3173 /* Free a single case structure.  */
3174
3175 static void
3176 free_case (gfc_case *p)
3177 {
3178   if (p->low == p->high)
3179     p->high = NULL;
3180   gfc_free_expr (p->low);
3181   gfc_free_expr (p->high);
3182   gfc_free (p);
3183 }
3184
3185
3186 /* Free a list of case structures.  */
3187
3188 void
3189 gfc_free_case_list (gfc_case *p)
3190 {
3191   gfc_case *q;
3192
3193   for (; p; p = q)
3194     {
3195       q = p->next;
3196       free_case (p);
3197     }
3198 }
3199
3200
3201 /* Match a single case selector.  */
3202
3203 static match
3204 match_case_selector (gfc_case **cp)
3205 {
3206   gfc_case *c;
3207   match m;
3208
3209   c = gfc_get_case ();
3210   c->where = gfc_current_locus;
3211
3212   if (gfc_match_char (':') == MATCH_YES)
3213     {
3214       m = gfc_match_init_expr (&c->high);
3215       if (m == MATCH_NO)
3216         goto need_expr;
3217       if (m == MATCH_ERROR)
3218         goto cleanup;
3219     }
3220   else
3221     {
3222       m = gfc_match_init_expr (&c->low);
3223       if (m == MATCH_ERROR)
3224         goto cleanup;
3225       if (m == MATCH_NO)
3226         goto need_expr;
3227
3228       /* If we're not looking at a ':' now, make a range out of a single
3229          target.  Else get the upper bound for the case range.  */
3230       if (gfc_match_char (':') != MATCH_YES)
3231         c->high = c->low;
3232       else
3233         {
3234           m = gfc_match_init_expr (&c->high);
3235           if (m == MATCH_ERROR)
3236             goto cleanup;
3237           /* MATCH_NO is fine.  It's OK if nothing is there!  */
3238         }
3239     }
3240
3241   *cp = c;
3242   return MATCH_YES;
3243
3244 need_expr:
3245   gfc_error ("Expected initialization expression in CASE at %C");
3246
3247 cleanup:
3248   free_case (c);
3249   return MATCH_ERROR;
3250 }
3251
3252
3253 /* Match the end of a case statement.  */
3254
3255 static match
3256 match_case_eos (void)
3257 {
3258   char name[GFC_MAX_SYMBOL_LEN + 1];
3259   match m;
3260
3261   if (gfc_match_eos () == MATCH_YES)
3262     return MATCH_YES;
3263
3264   /* If the case construct doesn't have a case-construct-name, we
3265      should have matched the EOS.  */
3266   if (!gfc_current_block ())
3267     {
3268       gfc_error ("Expected the name of the SELECT CASE construct at %C");
3269       return MATCH_ERROR;
3270     }
3271
3272   gfc_gobble_whitespace ();
3273
3274   m = gfc_match_name (name);
3275   if (m != MATCH_YES)
3276     return m;
3277
3278   if (strcmp (name, gfc_current_block ()->name) != 0)
3279     {
3280       gfc_error ("Expected case name of '%s' at %C",
3281                  gfc_current_block ()->name);
3282       return MATCH_ERROR;
3283     }
3284
3285   return gfc_match_eos ();
3286 }
3287
3288
3289 /* Match a SELECT statement.  */
3290
3291 match
3292 gfc_match_select (void)
3293 {
3294   gfc_expr *expr;
3295   match m;
3296
3297   m = gfc_match_label ();
3298   if (m == MATCH_ERROR)
3299     return m;
3300
3301   m = gfc_match (" select case ( %e )%t", &expr);
3302   if (m != MATCH_YES)
3303     return m;
3304
3305   new_st.op = EXEC_SELECT;
3306   new_st.expr = expr;
3307
3308   return MATCH_YES;
3309 }
3310
3311
3312 /* Match a CASE statement.  */
3313
3314 match
3315 gfc_match_case (void)
3316 {
3317   gfc_case *c, *head, *tail;
3318   match m;
3319
3320   head = tail = NULL;
3321
3322   if (gfc_current_state () != COMP_SELECT)
3323     {
3324       gfc_error ("Unexpected CASE statement at %C");
3325       return MATCH_ERROR;
3326     }
3327
3328   if (gfc_match ("% default") == MATCH_YES)
3329     {
3330       m = match_case_eos ();
3331       if (m == MATCH_NO)
3332         goto syntax;
3333       if (m == MATCH_ERROR)
3334         goto cleanup;
3335
3336       new_st.op = EXEC_SELECT;
3337       c = gfc_get_case ();
3338       c->where = gfc_current_locus;
3339       new_st.ext.case_list = c;
3340       return MATCH_YES;
3341     }
3342
3343   if (gfc_match_char ('(') != MATCH_YES)
3344     goto syntax;
3345
3346   for (;;)
3347     {
3348       if (match_case_selector (&c) == MATCH_ERROR)
3349         goto cleanup;
3350
3351       if (head == NULL)
3352         head = c;
3353       else
3354         tail->next = c;
3355
3356       tail = c;
3357
3358       if (gfc_match_char (')') == MATCH_YES)
3359         break;
3360       if (gfc_match_char (',') != MATCH_YES)
3361         goto syntax;
3362     }
3363
3364   m = match_case_eos ();
3365   if (m == MATCH_NO)
3366     goto syntax;
3367   if (m == MATCH_ERROR)
3368     goto cleanup;
3369
3370   new_st.op = EXEC_SELECT;
3371   new_st.ext.case_list = head;
3372
3373   return MATCH_YES;
3374
3375 syntax:
3376   gfc_error ("Syntax error in CASE-specification at %C");
3377
3378 cleanup:
3379   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
3380   return MATCH_ERROR;
3381 }
3382
3383 /********************* WHERE subroutines ********************/
3384
3385 /* Match the rest of a simple WHERE statement that follows an IF statement.
3386  */
3387
3388 static match
3389 match_simple_where (void)
3390 {
3391   gfc_expr *expr;
3392   gfc_code *c;
3393   match m;
3394
3395   m = gfc_match (" ( %e )", &expr);
3396   if (m != MATCH_YES)
3397     return m;
3398
3399   m = gfc_match_assignment ();
3400   if (m == MATCH_NO)
3401     goto syntax;
3402   if (m == MATCH_ERROR)
3403     goto cleanup;
3404
3405   if (gfc_match_eos () != MATCH_YES)
3406     goto syntax;
3407
3408   c = gfc_get_code ();
3409
3410   c->op = EXEC_WHERE;
3411   c->expr = expr;
3412   c->next = gfc_get_code ();
3413
3414   *c->next = new_st;
3415   gfc_clear_new_st ();
3416
3417   new_st.op = EXEC_WHERE;
3418   new_st.block = c;
3419
3420   return MATCH_YES;
3421
3422 syntax:
3423   gfc_syntax_error (ST_WHERE);
3424
3425 cleanup:
3426   gfc_free_expr (expr);
3427   return MATCH_ERROR;
3428 }
3429
3430
3431 /* Match a WHERE statement.  */
3432
3433 match
3434 gfc_match_where (gfc_statement *st)
3435 {
3436   gfc_expr *expr;
3437   match m0, m;
3438   gfc_code *c;
3439
3440   m0 = gfc_match_label ();
3441   if (m0 == MATCH_ERROR)
3442     return m0;
3443
3444   m = gfc_match (" where ( %e )", &expr);
3445   if (m != MATCH_YES)
3446     return m;
3447
3448   if (gfc_match_eos () == MATCH_YES)
3449     {
3450       *st = ST_WHERE_BLOCK;
3451       new_st.op = EXEC_WHERE;
3452       new_st.expr = expr;
3453       return MATCH_YES;
3454     }
3455
3456   m = gfc_match_assignment ();
3457   if (m == MATCH_NO)
3458     gfc_syntax_error (ST_WHERE);
3459
3460   if (m != MATCH_YES)
3461     {
3462       gfc_free_expr (expr);
3463       return MATCH_ERROR;
3464     }
3465
3466   /* We've got a simple WHERE statement.  */
3467   *st = ST_WHERE;
3468   c = gfc_get_code ();
3469
3470   c->op = EXEC_WHERE;
3471   c->expr = expr;
3472   c->next = gfc_get_code ();
3473
3474   *c->next = new_st;
3475   gfc_clear_new_st ();
3476
3477   new_st.op = EXEC_WHERE;
3478   new_st.block = c;
3479
3480   return MATCH_YES;
3481 }
3482
3483
3484 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
3485    new_st if successful.  */
3486
3487 match
3488 gfc_match_elsewhere (void)
3489 {
3490   char name[GFC_MAX_SYMBOL_LEN + 1];
3491   gfc_expr *expr;
3492   match m;
3493
3494   if (gfc_current_state () != COMP_WHERE)
3495     {
3496       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3497       return MATCH_ERROR;
3498     }
3499
3500   expr = NULL;
3501
3502   if (gfc_match_char ('(') == MATCH_YES)
3503     {
3504       m = gfc_match_expr (&expr);
3505       if (m == MATCH_NO)
3506         goto syntax;
3507       if (m == MATCH_ERROR)
3508         return MATCH_ERROR;
3509
3510       if (gfc_match_char (')') != MATCH_YES)
3511         goto syntax;
3512     }
3513
3514   if (gfc_match_eos () != MATCH_YES)
3515     {
3516       /* Only makes sense if we have a where-construct-name.  */
3517       if (!gfc_current_block ())
3518         {
3519           m = MATCH_ERROR;
3520           goto cleanup;
3521         }
3522       /* Better be a name at this point.  */
3523       m = gfc_match_name (name);
3524       if (m == MATCH_NO)
3525         goto syntax;
3526       if (m == MATCH_ERROR)
3527         goto cleanup;
3528
3529       if (gfc_match_eos () != MATCH_YES)
3530         goto syntax;
3531
3532       if (strcmp (name, gfc_current_block ()->name) != 0)
3533         {
3534           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3535                      name, gfc_current_block ()->name);
3536           goto cleanup;
3537         }
3538     }
3539
3540   new_st.op = EXEC_WHERE;
3541   new_st.expr = expr;
3542   return MATCH_YES;
3543
3544 syntax:
3545   gfc_syntax_error (ST_ELSEWHERE);
3546
3547 cleanup:
3548   gfc_free_expr (expr);
3549   return MATCH_ERROR;
3550 }
3551
3552
3553 /******************** FORALL subroutines ********************/
3554
3555 /* Free a list of FORALL iterators.  */
3556
3557 void
3558 gfc_free_forall_iterator (gfc_forall_iterator *iter)
3559 {
3560   gfc_forall_iterator *next;
3561
3562   while (iter)
3563     {
3564       next = iter->next;
3565       gfc_free_expr (iter->var);
3566       gfc_free_expr (iter->start);
3567       gfc_free_expr (iter->end);
3568       gfc_free_expr (iter->stride);
3569       gfc_free (iter);
3570       iter = next;
3571     }
3572 }
3573
3574
3575 /* Match an iterator as part of a FORALL statement.  The format is:
3576
3577      <var> = <start>:<end>[:<stride>]
3578
3579    On MATCH_NO, the caller tests for the possibility that there is a
3580    scalar mask expression.  */
3581
3582 static match
3583 match_forall_iterator (gfc_forall_iterator **result)
3584 {
3585   gfc_forall_iterator *iter;
3586   locus where;
3587   match m;
3588
3589   where = gfc_current_locus;
3590   iter = gfc_getmem (sizeof (gfc_forall_iterator));
3591
3592   m = gfc_match_expr (&iter->var);
3593   if (m != MATCH_YES)
3594     goto cleanup;
3595
3596   if (gfc_match_char ('=') != MATCH_YES
3597       || iter->var->expr_type != EXPR_VARIABLE)
3598     {
3599       m = MATCH_NO;
3600       goto cleanup;
3601     }
3602
3603   m = gfc_match_expr (&iter->start);
3604   if (m != MATCH_YES)
3605     goto cleanup;
3606
3607   if (gfc_match_char (':') != MATCH_YES)
3608     goto syntax;
3609
3610   m = gfc_match_expr (&iter->end);
3611   if (m == MATCH_NO)
3612     goto syntax;
3613   if (m == MATCH_ERROR)
3614     goto cleanup;
3615
3616   if (gfc_match_char (':') == MATCH_NO)
3617     iter->stride = gfc_int_expr (1);
3618   else
3619     {
3620       m = gfc_match_expr (&iter->stride);
3621       if (m == MATCH_NO)
3622         goto syntax;
3623       if (m == MATCH_ERROR)
3624         goto cleanup;
3625     }
3626
3627   /* Mark the iteration variable's symbol as used as a FORALL index.  */
3628   iter->var->symtree->n.sym->forall_index = true;
3629
3630   *result = iter;
3631   return MATCH_YES;
3632
3633 syntax:
3634   gfc_error ("Syntax error in FORALL iterator at %C");
3635   m = MATCH_ERROR;
3636
3637 cleanup:
3638
3639   gfc_current_locus = where;
3640   gfc_free_forall_iterator (iter);
3641   return m;
3642 }
3643
3644
3645 /* Match the header of a FORALL statement.  */
3646
3647 static match
3648 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
3649 {
3650   gfc_forall_iterator *head, *tail, *new;
3651   gfc_expr *msk;
3652   match m;
3653
3654   gfc_gobble_whitespace ();
3655
3656   head = tail = NULL;
3657   msk = NULL;
3658
3659   if (gfc_match_char ('(') != MATCH_YES)
3660     return MATCH_NO;
3661
3662   m = match_forall_iterator (&new);
3663   if (m == MATCH_ERROR)
3664     goto cleanup;
3665   if (m == MATCH_NO)
3666     goto syntax;
3667
3668   head = tail = new;
3669
3670   for (;;)
3671     {
3672       if (gfc_match_char (',') != MATCH_YES)
3673         break;
3674
3675       m = match_forall_iterator (&new);
3676       if (m == MATCH_ERROR)
3677         goto cleanup;
3678
3679       if (m == MATCH_YES)
3680         {
3681           tail->next = new;
3682           tail = new;
3683           continue;
3684         }
3685
3686       /* Have to have a mask expression.  */
3687
3688       m = gfc_match_expr (&msk);
3689       if (m == MATCH_NO)
3690         goto syntax;
3691       if (m == MATCH_ERROR)
3692         goto cleanup;
3693
3694       break;
3695     }
3696
3697   if (gfc_match_char (')') == MATCH_NO)
3698     goto syntax;
3699
3700   *phead = head;
3701   *mask = msk;
3702   return MATCH_YES;
3703
3704 syntax:
3705   gfc_syntax_error (ST_FORALL);
3706
3707 cleanup:
3708   gfc_free_expr (msk);
3709   gfc_free_forall_iterator (head);
3710
3711   return MATCH_ERROR;
3712 }
3713
3714 /* Match the rest of a simple FORALL statement that follows an
3715    IF statement.  */
3716
3717 static match
3718 match_simple_forall (void)
3719 {
3720   gfc_forall_iterator *head;
3721   gfc_expr *mask;
3722   gfc_code *c;
3723   match m;
3724
3725   mask = NULL;
3726   head = NULL;
3727   c = NULL;
3728
3729   m = match_forall_header (&head, &mask);
3730
3731   if (m == MATCH_NO)
3732     goto syntax;
3733   if (m != MATCH_YES)
3734     goto cleanup;
3735
3736   m = gfc_match_assignment ();
3737
3738   if (m == MATCH_ERROR)
3739     goto cleanup;
3740   if (m == MATCH_NO)
3741     {
3742       m = gfc_match_pointer_assignment ();
3743       if (m == MATCH_ERROR)
3744         goto cleanup;
3745       if (m == MATCH_NO)
3746         goto syntax;
3747     }
3748
3749   c = gfc_get_code ();
3750   *c = new_st;
3751   c->loc = gfc_current_locus;
3752
3753   if (gfc_match_eos () != MATCH_YES)
3754     goto syntax;
3755
3756   gfc_clear_new_st ();
3757   new_st.op = EXEC_FORALL;
3758   new_st.expr = mask;
3759   new_st.ext.forall_iterator = head;
3760   new_st.block = gfc_get_code ();
3761
3762   new_st.block->op = EXEC_FORALL;
3763   new_st.block->next = c;
3764
3765   return MATCH_YES;
3766
3767 syntax:
3768   gfc_syntax_error (ST_FORALL);
3769
3770 cleanup:
3771   gfc_free_forall_iterator (head);
3772   gfc_free_expr (mask);
3773
3774   return MATCH_ERROR;
3775 }
3776
3777
3778 /* Match a FORALL statement.  */
3779
3780 match
3781 gfc_match_forall (gfc_statement *st)
3782 {
3783   gfc_forall_iterator *head;
3784   gfc_expr *mask;
3785   gfc_code *c;
3786   match m0, m;
3787
3788   head = NULL;
3789   mask = NULL;
3790   c = NULL;
3791
3792   m0 = gfc_match_label ();
3793   if (m0 == MATCH_ERROR)
3794     return MATCH_ERROR;
3795
3796   m = gfc_match (" forall");
3797   if (m != MATCH_YES)
3798     return m;
3799
3800   m = match_forall_header (&head, &mask);
3801   if (m == MATCH_ERROR)
3802     goto cleanup;
3803   if (m == MATCH_NO)
3804     goto syntax;
3805
3806   if (gfc_match_eos () == MATCH_YES)
3807     {
3808       *st = ST_FORALL_BLOCK;
3809       new_st.op = EXEC_FORALL;
3810       new_st.expr = mask;
3811       new_st.ext.forall_iterator = head;
3812       return MATCH_YES;
3813     }
3814
3815   m = gfc_match_assignment ();
3816   if (m == MATCH_ERROR)
3817     goto cleanup;
3818   if (m == MATCH_NO)
3819     {
3820       m = gfc_match_pointer_assignment ();
3821       if (m == MATCH_ERROR)
3822         goto cleanup;
3823       if (m == MATCH_NO)
3824         goto syntax;
3825     }
3826
3827   c = gfc_get_code ();
3828   *c = new_st;
3829   c->loc = gfc_current_locus;
3830
3831   gfc_clear_new_st ();
3832   new_st.op = EXEC_FORALL;
3833   new_st.expr = mask;
3834   new_st.ext.forall_iterator = head;
3835   new_st.block = gfc_get_code ();
3836   new_st.block->op = EXEC_FORALL;
3837   new_st.block->next = c;
3838
3839   *st = ST_FORALL;
3840   return MATCH_YES;
3841
3842 syntax:
3843   gfc_syntax_error (ST_FORALL);
3844
3845 cleanup:
3846   gfc_free_forall_iterator (head);
3847   gfc_free_expr (mask);
3848   gfc_free_statements (c);
3849   return MATCH_NO;
3850 }