gcc/fortran/match.c

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