gcc/fortran/match.c

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