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