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   if (lvalue->symtree->n.sym->attr.flavor == FL_PARAMETER)
 839     {
 840       gfc_error ("Cannot assign to a PARAMETER variable at %C");
 841       m = MATCH_ERROR;
 842       goto cleanup;
 843     }
 844
 845   m = gfc_match (" %e%t", &rvalue);
 846   if (m != MATCH_YES)
 847     goto cleanup;
 848
 849   gfc_set_sym_referenced (lvalue->symtree->n.sym);
 850
 851   new_st.op = EXEC_ASSIGN;
 852   new_st.expr = lvalue;
 853   new_st.expr2 = rvalue;
 854
 855   gfc_check_do_variable (lvalue->symtree);
 856
 857   return MATCH_YES;
 858
 859 cleanup:
 860   gfc_current_locus = old_loc;
 861   gfc_free_expr (lvalue);
 862   gfc_free_expr (rvalue);
 863   return m;
 864 }
 865
 866
 867 /* Match a pointer assignment statement.  */
 868
 869 match
 870 gfc_match_pointer_assignment (void)
 871 {
 872   gfc_expr *lvalue, *rvalue;
 873   locus old_loc;
 874   match m;
 875
 876   old_loc = gfc_current_locus;
 877
 878   lvalue = rvalue = NULL;
 879
 880   m = gfc_match (" %v =>", &lvalue);
 881   if (m != MATCH_YES)
 882     {
 883       m = MATCH_NO;
 884       goto cleanup;
 885     }
 886
 887   m = gfc_match (" %e%t", &rvalue);
 888   if (m != MATCH_YES)
 889     goto cleanup;
 890
 891   new_st.op = EXEC_POINTER_ASSIGN;
 892   new_st.expr = lvalue;
 893   new_st.expr2 = rvalue;
 894
 895   return MATCH_YES;
 896
 897 cleanup:
 898   gfc_current_locus = old_loc;
 899   gfc_free_expr (lvalue);
 900   gfc_free_expr (rvalue);
 901   return m;
 902 }
 903
 904
 905 /* The IF statement is a bit of a pain.  First of all, there are three
 906    forms of it, the simple IF, the IF that starts a block and the
 907    arithmetic IF.
 908
 909    There is a problem with the simple IF and that is the fact that we
 910    only have a single level of undo information on symbols.  What this
 911    means is for a simple IF, we must re-match the whole IF statement
 912    multiple times in order to guarantee that the symbol table ends up
 913    in the proper state.  */
 914
 915 match
 916 gfc_match_if (gfc_statement * if_type)
 917 {
 918   gfc_expr *expr;
 919   gfc_st_label *l1, *l2, *l3;
 920   locus old_loc;
 921   gfc_code *p;
 922   match m, n;
 923
 924   n = gfc_match_label ();
 925   if (n == MATCH_ERROR)
 926     return n;
 927
 928   old_loc = gfc_current_locus;
 929
 930   m = gfc_match (" if ( %e", &expr);
 931   if (m != MATCH_YES)
 932     return m;
 933
 934   if (gfc_match_char (')') != MATCH_YES)
 935     {
 936       gfc_error ("Syntax error in IF-expression at %C");
 937       gfc_free_expr (expr);
 938       return MATCH_ERROR;
 939     }
 940
 941   m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
 942
 943   if (m == MATCH_YES)
 944     {
 945       if (n == MATCH_YES)
 946         {
 947           gfc_error
 948             ("Block label not appropriate for arithmetic IF statement "
 949              "at %C");
 950
 951           gfc_free_expr (expr);
 952           return MATCH_ERROR;
 953         }
 954
 955       if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
 956           || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
 957           || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
 958         {
 959
 960           gfc_free_expr (expr);
 961           return MATCH_ERROR;
 962         }
 963
 964       new_st.op = EXEC_ARITHMETIC_IF;
 965       new_st.expr = expr;
 966       new_st.label = l1;
 967       new_st.label2 = l2;
 968       new_st.label3 = l3;
 969
 970       *if_type = ST_ARITHMETIC_IF;
 971       return MATCH_YES;
 972     }
 973
 974   if (gfc_match (" then %t") == MATCH_YES)
 975     {
 976       new_st.op = EXEC_IF;
 977       new_st.expr = expr;
 978
 979       *if_type = ST_IF_BLOCK;
 980       return MATCH_YES;
 981     }
 982
 983   if (n == MATCH_YES)
 984     {
 985       gfc_error ("Block label is not appropriate IF statement at %C");
 986
 987       gfc_free_expr (expr);
 988       return MATCH_ERROR;
 989     }
 990
 991   /* At this point the only thing left is a simple IF statement.  At
 992      this point, n has to be MATCH_NO, so we don't have to worry about
 993      re-matching a block label.  From what we've got so far, try
 994      matching an assignment.  */
 995
 996   *if_type = ST_SIMPLE_IF;
 997
 998   m = gfc_match_assignment ();
 999   if (m == MATCH_YES)
1000     goto got_match;
1001
1002   gfc_free_expr (expr);
1003   gfc_undo_symbols ();
1004   gfc_current_locus = old_loc;
1005
1006   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match */
1007
1008   m = gfc_match_pointer_assignment ();
1009   if (m == MATCH_YES)
1010     goto got_match;
1011
1012   gfc_free_expr (expr);
1013   gfc_undo_symbols ();
1014   gfc_current_locus = old_loc;
1015
1016   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match */
1017
1018   /* Look at the next keyword to see which matcher to call.  Matching
1019      the keyword doesn't affect the symbol table, so we don't have to
1020      restore between tries.  */
1021
1022 #define match(string, subr, statement) \
1023   if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1024
1025   gfc_clear_error ();
1026
1027   match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1028     match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1029     match ("call", gfc_match_call, ST_CALL)
1030     match ("close", gfc_match_close, ST_CLOSE)
1031     match ("continue", gfc_match_continue, ST_CONTINUE)
1032     match ("cycle", gfc_match_cycle, ST_CYCLE)
1033     match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1034     match ("end file", gfc_match_endfile, ST_END_FILE)
1035     match ("exit", gfc_match_exit, ST_EXIT)
1036     match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1037     match ("go to", gfc_match_goto, ST_GOTO)
1038     match ("inquire", gfc_match_inquire, ST_INQUIRE)
1039     match ("nullify", gfc_match_nullify, ST_NULLIFY)
1040     match ("open", gfc_match_open, ST_OPEN)
1041     match ("pause", gfc_match_pause, ST_NONE)
1042     match ("print", gfc_match_print, ST_WRITE)
1043     match ("read", gfc_match_read, ST_READ)
1044     match ("return", gfc_match_return, ST_RETURN)
1045     match ("rewind", gfc_match_rewind, ST_REWIND)
1046     match ("pause", gfc_match_stop, ST_PAUSE)
1047     match ("stop", gfc_match_stop, ST_STOP)
1048     match ("write", gfc_match_write, ST_WRITE)
1049
1050   /* All else has failed, so give up.  See if any of the matchers has
1051      stored an error message of some sort.  */
1052     if (gfc_error_check () == 0)
1053     gfc_error ("Unclassifiable statement in IF-clause at %C");
1054
1055   gfc_free_expr (expr);
1056   return MATCH_ERROR;
1057
1058 got_match:
1059   if (m == MATCH_NO)
1060     gfc_error ("Syntax error in IF-clause at %C");
1061   if (m != MATCH_YES)
1062     {
1063       gfc_free_expr (expr);
1064       return MATCH_ERROR;
1065     }
1066
1067   /* At this point, we've matched the single IF and the action clause
1068      is in new_st.  Rearrange things so that the IF statement appears
1069      in new_st.  */
1070
1071   p = gfc_get_code ();
1072   p->next = gfc_get_code ();
1073   *p->next = new_st;
1074   p->next->loc = gfc_current_locus;
1075
1076   p->expr = expr;
1077   p->op = EXEC_IF;
1078
1079   gfc_clear_new_st ();
1080
1081   new_st.op = EXEC_IF;
1082   new_st.block = p;
1083
1084   return MATCH_YES;
1085 }
1086
1087 #undef match
1088
1089
1090 /* Match an ELSE statement.  */
1091
1092 match
1093 gfc_match_else (void)
1094 {
1095   char name[GFC_MAX_SYMBOL_LEN + 1];
1096
1097   if (gfc_match_eos () == MATCH_YES)
1098     return MATCH_YES;
1099
1100   if (gfc_match_name (name) != MATCH_YES
1101       || gfc_current_block () == NULL
1102       || gfc_match_eos () != MATCH_YES)
1103     {
1104       gfc_error ("Unexpected junk after ELSE statement at %C");
1105       return MATCH_ERROR;
1106     }
1107
1108   if (strcmp (name, gfc_current_block ()->name) != 0)
1109     {
1110       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1111                  name, gfc_current_block ()->name);
1112       return MATCH_ERROR;
1113     }
1114
1115   return MATCH_YES;
1116 }
1117
1118
1119 /* Match an ELSE IF statement.  */
1120
1121 match
1122 gfc_match_elseif (void)
1123 {
1124   char name[GFC_MAX_SYMBOL_LEN + 1];
1125   gfc_expr *expr;
1126   match m;
1127
1128   m = gfc_match (" ( %e ) then", &expr);
1129   if (m != MATCH_YES)
1130     return m;
1131
1132   if (gfc_match_eos () == MATCH_YES)
1133     goto done;
1134
1135   if (gfc_match_name (name) != MATCH_YES
1136       || gfc_current_block () == NULL
1137       || gfc_match_eos () != MATCH_YES)
1138     {
1139       gfc_error ("Unexpected junk after ELSE IF statement at %C");
1140       goto cleanup;
1141     }
1142
1143   if (strcmp (name, gfc_current_block ()->name) != 0)
1144     {
1145       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1146                  name, gfc_current_block ()->name);
1147       goto cleanup;
1148     }
1149
1150 done:
1151   new_st.op = EXEC_IF;
1152   new_st.expr = expr;
1153   return MATCH_YES;
1154
1155 cleanup:
1156   gfc_free_expr (expr);
1157   return MATCH_ERROR;
1158 }
1159
1160
1161 /* Free a gfc_iterator structure.  */
1162
1163 void
1164 gfc_free_iterator (gfc_iterator * iter, int flag)
1165 {
1166
1167   if (iter == NULL)
1168     return;
1169
1170   gfc_free_expr (iter->var);
1171   gfc_free_expr (iter->start);
1172   gfc_free_expr (iter->end);
1173   gfc_free_expr (iter->step);
1174
1175   if (flag)
1176     gfc_free (iter);
1177 }
1178
1179
1180 /* Match a DO statement.  */
1181
1182 match
1183 gfc_match_do (void)
1184 {
1185   gfc_iterator iter, *ip;
1186   locus old_loc;
1187   gfc_st_label *label;
1188   match m;
1189
1190   old_loc = gfc_current_locus;
1191
1192   label = NULL;
1193   iter.var = iter.start = iter.end = iter.step = NULL;
1194
1195   m = gfc_match_label ();
1196   if (m == MATCH_ERROR)
1197     return m;
1198
1199   if (gfc_match (" do") != MATCH_YES)
1200     return MATCH_NO;
1201
1202   m = gfc_match_st_label (&label, 0);
1203   if (m == MATCH_ERROR)
1204     goto cleanup;
1205
1206 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1207
1208   if (gfc_match_eos () == MATCH_YES)
1209     {
1210       iter.end = gfc_logical_expr (1, NULL);
1211       new_st.op = EXEC_DO_WHILE;
1212       goto done;
1213     }
1214
1215   /* match an optional comma, if no comma is found a space is obligatory.  */
1216   if (gfc_match_char(',') != MATCH_YES
1217       && gfc_match ("% ") != MATCH_YES)
1218     return MATCH_NO;
1219
1220   /* See if we have a DO WHILE.  */
1221   if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1222     {
1223       new_st.op = EXEC_DO_WHILE;
1224       goto done;
1225     }
1226
1227   /* The abortive DO WHILE may have done something to the symbol
1228      table, so we start over: */
1229   gfc_undo_symbols ();
1230   gfc_current_locus = old_loc;
1231
1232   gfc_match_label ();           /* This won't error */
1233   gfc_match (" do ");           /* This will work */
1234
1235   gfc_match_st_label (&label, 0);       /* Can't error out */
1236   gfc_match_char (',');         /* Optional comma */
1237
1238   m = gfc_match_iterator (&iter, 0);
1239   if (m == MATCH_NO)
1240     return MATCH_NO;
1241   if (m == MATCH_ERROR)
1242     goto cleanup;
1243
1244   gfc_check_do_variable (iter.var->symtree);
1245
1246   if (gfc_match_eos () != MATCH_YES)
1247     {
1248       gfc_syntax_error (ST_DO);
1249       goto cleanup;
1250     }
1251
1252   new_st.op = EXEC_DO;
1253
1254 done:
1255   if (label != NULL
1256       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1257     goto cleanup;
1258
1259   new_st.label = label;
1260
1261   if (new_st.op == EXEC_DO_WHILE)
1262     new_st.expr = iter.end;
1263   else
1264     {
1265       new_st.ext.iterator = ip = gfc_get_iterator ();
1266       *ip = iter;
1267     }
1268
1269   return MATCH_YES;
1270
1271 cleanup:
1272   gfc_free_iterator (&iter, 0);
1273
1274   return MATCH_ERROR;
1275 }
1276
1277
1278 /* Match an EXIT or CYCLE statement.  */
1279
1280 static match
1281 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1282 {
1283   gfc_state_data *p;
1284   gfc_symbol *sym;
1285   match m;
1286
1287   if (gfc_match_eos () == MATCH_YES)
1288     sym = NULL;
1289   else
1290     {
1291       m = gfc_match ("% %s%t", &sym);
1292       if (m == MATCH_ERROR)
1293         return MATCH_ERROR;
1294       if (m == MATCH_NO)
1295         {
1296           gfc_syntax_error (st);
1297           return MATCH_ERROR;
1298         }
1299
1300       if (sym->attr.flavor != FL_LABEL)
1301         {
1302           gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1303                      sym->name, gfc_ascii_statement (st));
1304           return MATCH_ERROR;
1305         }
1306     }
1307
1308   /* Find the loop mentioned specified by the label (or lack of a
1309      label).  */
1310   for (p = gfc_state_stack; p; p = p->previous)
1311     if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1312       break;
1313
1314   if (p == NULL)
1315     {
1316       if (sym == NULL)
1317         gfc_error ("%s statement at %C is not within a loop",
1318                    gfc_ascii_statement (st));
1319       else
1320         gfc_error ("%s statement at %C is not within loop '%s'",
1321                    gfc_ascii_statement (st), sym->name);
1322
1323       return MATCH_ERROR;
1324     }
1325
1326   /* Save the first statement in the loop - needed by the backend.  */
1327   new_st.ext.whichloop = p->head;
1328
1329   new_st.op = op;
1330 /*  new_st.sym = sym;*/
1331
1332   return MATCH_YES;
1333 }
1334
1335
1336 /* Match the EXIT statement.  */
1337
1338 match
1339 gfc_match_exit (void)
1340 {
1341
1342   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1343 }
1344
1345
1346 /* Match the CYCLE statement.  */
1347
1348 match
1349 gfc_match_cycle (void)
1350 {
1351
1352   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1353 }
1354
1355
1356 /* Match a number or character constant after a STOP or PAUSE statement.  */
1357
1358 static match
1359 gfc_match_stopcode (gfc_statement st)
1360 {
1361   int stop_code;
1362   gfc_expr *e;
1363   match m;
1364
1365   stop_code = 0;
1366   e = NULL;
1367
1368   if (gfc_match_eos () != MATCH_YES)
1369     {
1370       m = gfc_match_small_literal_int (&stop_code);
1371       if (m == MATCH_ERROR)
1372         goto cleanup;
1373
1374       if (m == MATCH_YES && stop_code > 99999)
1375         {
1376           gfc_error ("STOP code out of range at %C");
1377           goto cleanup;
1378         }
1379
1380       if (m == MATCH_NO)
1381         {
1382           /* Try a character constant.  */
1383           m = gfc_match_expr (&e);
1384           if (m == MATCH_ERROR)
1385             goto cleanup;
1386           if (m == MATCH_NO)
1387             goto syntax;
1388           if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1389             goto syntax;
1390         }
1391
1392       if (gfc_match_eos () != MATCH_YES)
1393         goto syntax;
1394     }
1395
1396   if (gfc_pure (NULL))
1397     {
1398       gfc_error ("%s statement not allowed in PURE procedure at %C",
1399                  gfc_ascii_statement (st));
1400       goto cleanup;
1401     }
1402
1403   new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1404   new_st.expr = e;
1405   new_st.ext.stop_code = stop_code;
1406
1407   return MATCH_YES;
1408
1409 syntax:
1410   gfc_syntax_error (st);
1411
1412 cleanup:
1413
1414   gfc_free_expr (e);
1415   return MATCH_ERROR;
1416 }
1417
1418 /* Match the (deprecated) PAUSE statement.  */
1419
1420 match
1421 gfc_match_pause (void)
1422 {
1423   match m;
1424
1425   m = gfc_match_stopcode (ST_PAUSE);
1426   if (m == MATCH_YES)
1427     {
1428       if (gfc_notify_std (GFC_STD_F95_DEL,
1429             "Obsolete: PAUSE statement at %C")
1430           == FAILURE)
1431         m = MATCH_ERROR;
1432     }
1433   return m;
1434 }
1435
1436
1437 /* Match the STOP statement.  */
1438
1439 match
1440 gfc_match_stop (void)
1441 {
1442   return gfc_match_stopcode (ST_STOP);
1443 }
1444
1445
1446 /* Match a CONTINUE statement.  */
1447
1448 match
1449 gfc_match_continue (void)
1450 {
1451
1452   if (gfc_match_eos () != MATCH_YES)
1453     {
1454       gfc_syntax_error (ST_CONTINUE);
1455       return MATCH_ERROR;
1456     }
1457
1458   new_st.op = EXEC_CONTINUE;
1459   return MATCH_YES;
1460 }
1461
1462
1463 /* Match the (deprecated) ASSIGN statement.  */
1464
1465 match
1466 gfc_match_assign (void)
1467 {
1468   gfc_expr *expr;
1469   gfc_st_label *label;
1470
1471   if (gfc_match (" %l", &label) == MATCH_YES)
1472     {
1473       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
1474         return MATCH_ERROR;
1475       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
1476         {
1477           if (gfc_notify_std (GFC_STD_F95_DEL,
1478                 "Obsolete: ASSIGN statement at %C")
1479               == FAILURE)
1480             return MATCH_ERROR;
1481
1482           expr->symtree->n.sym->attr.assign = 1;
1483
1484           new_st.op = EXEC_LABEL_ASSIGN;
1485           new_st.label = label;
1486           new_st.expr = expr;
1487           return MATCH_YES;
1488         }
1489     }
1490   return MATCH_NO;
1491 }
1492
1493
1494 /* Match the GO TO statement.  As a computed GOTO statement is
1495    matched, it is transformed into an equivalent SELECT block.  No
1496    tree is necessary, and the resulting jumps-to-jumps are
1497    specifically optimized away by the back end.  */
1498
1499 match
1500 gfc_match_goto (void)
1501 {
1502   gfc_code *head, *tail;
1503   gfc_expr *expr;
1504   gfc_case *cp;
1505   gfc_st_label *label;
1506   int i;
1507   match m;
1508
1509   if (gfc_match (" %l%t", &label) == MATCH_YES)
1510     {
1511       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1512         return MATCH_ERROR;
1513
1514       new_st.op = EXEC_GOTO;
1515       new_st.label = label;
1516       return MATCH_YES;
1517     }
1518
1519   /* The assigned GO TO statement.  */
1520
1521   if (gfc_match_variable (&expr, 0) == MATCH_YES)
1522     {
1523       if (gfc_notify_std (GFC_STD_F95_DEL,
1524                           "Obsolete: Assigned GOTO statement at %C")
1525           == FAILURE)
1526         return MATCH_ERROR;
1527
1528       expr->symtree->n.sym->attr.assign = 1;
1529       new_st.op = EXEC_GOTO;
1530       new_st.expr = expr;
1531
1532       if (gfc_match_eos () == MATCH_YES)
1533         return MATCH_YES;
1534
1535       /* Match label list.  */
1536       gfc_match_char (',');
1537       if (gfc_match_char ('(') != MATCH_YES)
1538         {
1539           gfc_syntax_error (ST_GOTO);
1540           return MATCH_ERROR;
1541         }
1542       head = tail = NULL;
1543
1544       do
1545         {
1546           m = gfc_match_st_label (&label, 0);
1547           if (m != MATCH_YES)
1548             goto syntax;
1549
1550           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1551             goto cleanup;
1552
1553           if (head == NULL)
1554             head = tail = gfc_get_code ();
1555           else
1556             {
1557               tail->block = gfc_get_code ();
1558               tail = tail->block;
1559             }
1560
1561           tail->label = label;
1562           tail->op = EXEC_GOTO;
1563         }
1564       while (gfc_match_char (',') == MATCH_YES);
1565
1566       if (gfc_match (")%t") != MATCH_YES)
1567         goto syntax;
1568
1569       if (head == NULL)
1570         {
1571            gfc_error (
1572                "Statement label list in GOTO at %C cannot be empty");
1573            goto syntax;
1574         }
1575       new_st.block = head;
1576
1577       return MATCH_YES;
1578     }
1579
1580   /* Last chance is a computed GO TO statement.  */
1581   if (gfc_match_char ('(') != MATCH_YES)
1582     {
1583       gfc_syntax_error (ST_GOTO);
1584       return MATCH_ERROR;
1585     }
1586
1587   head = tail = NULL;
1588   i = 1;
1589
1590   do
1591     {
1592       m = gfc_match_st_label (&label, 0);
1593       if (m != MATCH_YES)
1594         goto syntax;
1595
1596       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1597         goto cleanup;
1598
1599       if (head == NULL)
1600         head = tail = gfc_get_code ();
1601       else
1602         {
1603           tail->block = gfc_get_code ();
1604           tail = tail->block;
1605         }
1606
1607       cp = gfc_get_case ();
1608       cp->low = cp->high = gfc_int_expr (i++);
1609
1610       tail->op = EXEC_SELECT;
1611       tail->ext.case_list = cp;
1612
1613       tail->next = gfc_get_code ();
1614       tail->next->op = EXEC_GOTO;
1615       tail->next->label = label;
1616     }
1617   while (gfc_match_char (',') == MATCH_YES);
1618
1619   if (gfc_match_char (')') != MATCH_YES)
1620     goto syntax;
1621
1622   if (head == NULL)
1623     {
1624       gfc_error ("Statement label list in GOTO at %C cannot be empty");
1625       goto syntax;
1626     }
1627
1628   /* Get the rest of the statement.  */
1629   gfc_match_char (',');
1630
1631   if (gfc_match (" %e%t", &expr) != MATCH_YES)
1632     goto syntax;
1633
1634   /* At this point, a computed GOTO has been fully matched and an
1635      equivalent SELECT statement constructed.  */
1636
1637   new_st.op = EXEC_SELECT;
1638   new_st.expr = NULL;
1639
1640   /* Hack: For a "real" SELECT, the expression is in expr. We put
1641      it in expr2 so we can distinguish then and produce the correct
1642      diagnostics.  */
1643   new_st.expr2 = expr;
1644   new_st.block = head;
1645   return MATCH_YES;
1646
1647 syntax:
1648   gfc_syntax_error (ST_GOTO);
1649 cleanup:
1650   gfc_free_statements (head);
1651   return MATCH_ERROR;
1652 }
1653
1654
1655 /* Frees a list of gfc_alloc structures.  */
1656
1657 void
1658 gfc_free_alloc_list (gfc_alloc * p)
1659 {
1660   gfc_alloc *q;
1661
1662   for (; p; p = q)
1663     {
1664       q = p->next;
1665       gfc_free_expr (p->expr);
1666       gfc_free (p);
1667     }
1668 }
1669
1670
1671 /* Match an ALLOCATE statement.  */
1672
1673 match
1674 gfc_match_allocate (void)
1675 {
1676   gfc_alloc *head, *tail;
1677   gfc_expr *stat;
1678   match m;
1679
1680   head = tail = NULL;
1681   stat = NULL;
1682
1683   if (gfc_match_char ('(') != MATCH_YES)
1684     goto syntax;
1685
1686   for (;;)
1687     {
1688       if (head == NULL)
1689         head = tail = gfc_get_alloc ();
1690       else
1691         {
1692           tail->next = gfc_get_alloc ();
1693           tail = tail->next;
1694         }
1695
1696       m = gfc_match_variable (&tail->expr, 0);
1697       if (m == MATCH_NO)
1698         goto syntax;
1699       if (m == MATCH_ERROR)
1700         goto cleanup;
1701
1702       if (gfc_check_do_variable (tail->expr->symtree))
1703         goto cleanup;
1704
1705       if (gfc_pure (NULL)
1706           && gfc_impure_variable (tail->expr->symtree->n.sym))
1707         {
1708           gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1709                      "PURE procedure");
1710           goto cleanup;
1711         }
1712
1713       if (gfc_match_char (',') != MATCH_YES)
1714         break;
1715
1716       m = gfc_match (" stat = %v", &stat);
1717       if (m == MATCH_ERROR)
1718         goto cleanup;
1719       if (m == MATCH_YES)
1720         break;
1721     }
1722
1723   if (stat != NULL)
1724     {
1725       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1726         {
1727           gfc_error
1728             ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1729              "INTENT(IN)", stat->symtree->n.sym->name);
1730           goto cleanup;
1731         }
1732
1733       if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
1734         {
1735           gfc_error
1736             ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1737              "procedure");
1738           goto cleanup;
1739         }
1740
1741       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1742         {
1743           gfc_error("STAT expression at %C must be a variable");
1744           goto cleanup;
1745         }
1746
1747       gfc_check_do_variable(stat->symtree);
1748     }
1749
1750   if (gfc_match (" )%t") != MATCH_YES)
1751     goto syntax;
1752
1753   new_st.op = EXEC_ALLOCATE;
1754   new_st.expr = stat;
1755   new_st.ext.alloc_list = head;
1756
1757   return MATCH_YES;
1758
1759 syntax:
1760   gfc_syntax_error (ST_ALLOCATE);
1761
1762 cleanup:
1763   gfc_free_expr (stat);
1764   gfc_free_alloc_list (head);
1765   return MATCH_ERROR;
1766 }
1767
1768
1769 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1770    a set of pointer assignments to intrinsic NULL().  */
1771
1772 match
1773 gfc_match_nullify (void)
1774 {
1775   gfc_code *tail;
1776   gfc_expr *e, *p;
1777   match m;
1778
1779   tail = NULL;
1780
1781   if (gfc_match_char ('(') != MATCH_YES)
1782     goto syntax;
1783
1784   for (;;)
1785     {
1786       m = gfc_match_variable (&p, 0);
1787       if (m == MATCH_ERROR)
1788         goto cleanup;
1789       if (m == MATCH_NO)
1790         goto syntax;
1791
1792       if (gfc_check_do_variable(p->symtree))
1793         goto cleanup;
1794
1795       if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
1796         {
1797           gfc_error
1798             ("Illegal variable in NULLIFY at %C for a PURE procedure");
1799           goto cleanup;
1800         }
1801
1802       /* build ' => NULL() ' */
1803       e = gfc_get_expr ();
1804       e->where = gfc_current_locus;
1805       e->expr_type = EXPR_NULL;
1806       e->ts.type = BT_UNKNOWN;
1807
1808       /* Chain to list */
1809       if (tail == NULL)
1810         tail = &new_st;
1811       else
1812         {
1813           tail->next = gfc_get_code ();
1814           tail = tail->next;
1815         }
1816
1817       tail->op = EXEC_POINTER_ASSIGN;
1818       tail->expr = p;
1819       tail->expr2 = e;
1820
1821       if (gfc_match_char (')') == MATCH_YES)
1822         break;
1823       if (gfc_match_char (',') != MATCH_YES)
1824         goto syntax;
1825     }
1826
1827   return MATCH_YES;
1828
1829 syntax:
1830   gfc_syntax_error (ST_NULLIFY);
1831
1832 cleanup:
1833   gfc_free_statements (tail);
1834   return MATCH_ERROR;
1835 }
1836
1837
1838 /* Match a DEALLOCATE statement.  */
1839
1840 match
1841 gfc_match_deallocate (void)
1842 {
1843   gfc_alloc *head, *tail;
1844   gfc_expr *stat;
1845   match m;
1846
1847   head = tail = NULL;
1848   stat = NULL;
1849
1850   if (gfc_match_char ('(') != MATCH_YES)
1851     goto syntax;
1852
1853   for (;;)
1854     {
1855       if (head == NULL)
1856         head = tail = gfc_get_alloc ();
1857       else
1858         {
1859           tail->next = gfc_get_alloc ();
1860           tail = tail->next;
1861         }
1862
1863       m = gfc_match_variable (&tail->expr, 0);
1864       if (m == MATCH_ERROR)
1865         goto cleanup;
1866       if (m == MATCH_NO)
1867         goto syntax;
1868
1869       if (gfc_check_do_variable (tail->expr->symtree))
1870         goto cleanup;
1871
1872       if (gfc_pure (NULL)
1873           && gfc_impure_variable (tail->expr->symtree->n.sym))
1874         {
1875           gfc_error
1876             ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
1877              "procedure");
1878           goto cleanup;
1879         }
1880
1881       if (gfc_match_char (',') != MATCH_YES)
1882         break;
1883
1884       m = gfc_match (" stat = %v", &stat);
1885       if (m == MATCH_ERROR)
1886         goto cleanup;
1887       if (m == MATCH_YES)
1888         break;
1889     }
1890
1891   if (stat != NULL)
1892     {
1893       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1894         {
1895           gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
1896                      "cannot be INTENT(IN)", stat->symtree->n.sym->name);
1897           goto cleanup;
1898         }
1899
1900       if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
1901         {
1902           gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
1903                      "for a PURE procedure");
1904           goto cleanup;
1905         }
1906
1907       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1908         {
1909           gfc_error("STAT expression at %C must be a variable");
1910           goto cleanup;
1911         }
1912
1913       gfc_check_do_variable(stat->symtree);
1914     }
1915
1916   if (gfc_match (" )%t") != MATCH_YES)
1917     goto syntax;
1918
1919   new_st.op = EXEC_DEALLOCATE;
1920   new_st.expr = stat;
1921   new_st.ext.alloc_list = head;
1922
1923   return MATCH_YES;
1924
1925 syntax:
1926   gfc_syntax_error (ST_DEALLOCATE);
1927
1928 cleanup:
1929   gfc_free_expr (stat);
1930   gfc_free_alloc_list (head);
1931   return MATCH_ERROR;
1932 }
1933
1934
1935 /* Match a RETURN statement.  */
1936
1937 match
1938 gfc_match_return (void)
1939 {
1940   gfc_expr *e;
1941   match m;
1942   gfc_compile_state s;
1943
1944   gfc_enclosing_unit (&s);
1945   if (s == COMP_PROGRAM
1946       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
1947                          "main program at %C") == FAILURE)
1948       return MATCH_ERROR;
1949
1950   e = NULL;
1951   if (gfc_match_eos () == MATCH_YES)
1952     goto done;
1953
1954   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
1955     {
1956       gfc_error ("Alternate RETURN statement at %C is only allowed within "
1957                  "a SUBROUTINE");
1958       goto cleanup;
1959     }
1960
1961   m = gfc_match ("% %e%t", &e);
1962   if (m == MATCH_YES)
1963     goto done;
1964   if (m == MATCH_ERROR)
1965     goto cleanup;
1966
1967   gfc_syntax_error (ST_RETURN);
1968
1969 cleanup:
1970   gfc_free_expr (e);
1971   return MATCH_ERROR;
1972
1973 done:
1974   new_st.op = EXEC_RETURN;
1975   new_st.expr = e;
1976
1977   return MATCH_YES;
1978 }
1979
1980
1981 /* Match a CALL statement.  The tricky part here are possible
1982    alternate return specifiers.  We handle these by having all
1983    "subroutines" actually return an integer via a register that gives
1984    the return number.  If the call specifies alternate returns, we
1985    generate code for a SELECT statement whose case clauses contain
1986    GOTOs to the various labels.  */
1987
1988 match
1989 gfc_match_call (void)
1990 {
1991   char name[GFC_MAX_SYMBOL_LEN + 1];
1992   gfc_actual_arglist *a, *arglist;
1993   gfc_case *new_case;
1994   gfc_symbol *sym;
1995   gfc_symtree *st;
1996   gfc_code *c;
1997   match m;
1998   int i;
1999
2000   arglist = NULL;
2001
2002   m = gfc_match ("% %n", name);
2003   if (m == MATCH_NO)
2004     goto syntax;
2005   if (m != MATCH_YES)
2006     return m;
2007
2008   if (gfc_get_ha_sym_tree (name, &st))
2009     return MATCH_ERROR;
2010
2011   sym = st->n.sym;
2012   gfc_set_sym_referenced (sym);
2013
2014   if (!sym->attr.generic
2015       && !sym->attr.subroutine
2016       && gfc_add_subroutine (&sym->attr, NULL) == FAILURE)
2017     return MATCH_ERROR;
2018
2019   if (gfc_match_eos () != MATCH_YES)
2020     {
2021       m = gfc_match_actual_arglist (1, &arglist);
2022       if (m == MATCH_NO)
2023         goto syntax;
2024       if (m == MATCH_ERROR)
2025         goto cleanup;
2026
2027       if (gfc_match_eos () != MATCH_YES)
2028         goto syntax;
2029     }
2030
2031   /* If any alternate return labels were found, construct a SELECT
2032      statement that will jump to the right place.  */
2033
2034   i = 0;
2035   for (a = arglist; a; a = a->next)
2036     if (a->expr == NULL)
2037         i = 1;
2038
2039   if (i)
2040     {
2041       gfc_symtree *select_st;
2042       gfc_symbol *select_sym;
2043       char name[GFC_MAX_SYMBOL_LEN + 1];
2044
2045       new_st.next = c = gfc_get_code ();
2046       c->op = EXEC_SELECT;
2047       sprintf (name, "_result_%s",sym->name);
2048       gfc_get_ha_sym_tree (name, &select_st);  /* Can't fail */
2049
2050       select_sym = select_st->n.sym;
2051       select_sym->ts.type = BT_INTEGER;
2052       select_sym->ts.kind = gfc_default_integer_kind ();
2053       gfc_set_sym_referenced (select_sym);
2054       c->expr = gfc_get_expr ();
2055       c->expr->expr_type = EXPR_VARIABLE;
2056       c->expr->symtree = select_st;
2057       c->expr->ts = select_sym->ts;
2058       c->expr->where = gfc_current_locus;
2059
2060       i = 0;
2061       for (a = arglist; a; a = a->next)
2062         {
2063           if (a->expr != NULL)
2064             continue;
2065
2066           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2067             continue;
2068
2069           i++;
2070
2071           c->block = gfc_get_code ();
2072           c = c->block;
2073           c->op = EXEC_SELECT;
2074
2075           new_case = gfc_get_case ();
2076           new_case->high = new_case->low = gfc_int_expr (i);
2077           c->ext.case_list = new_case;
2078
2079           c->next = gfc_get_code ();
2080           c->next->op = EXEC_GOTO;
2081           c->next->label = a->label;
2082         }
2083     }
2084
2085   new_st.op = EXEC_CALL;
2086   new_st.symtree = st;
2087   new_st.ext.actual = arglist;
2088
2089   return MATCH_YES;
2090
2091 syntax:
2092   gfc_syntax_error (ST_CALL);
2093
2094 cleanup:
2095   gfc_free_actual_arglist (arglist);
2096   return MATCH_ERROR;
2097 }
2098
2099
2100 /* Given a name, return a pointer to the common head structure,
2101    creating it if it does not exist. If FROM_MODULE is non-zero, we
2102    mangle the name so that it doesn't interfere with commons defined
2103    in the using namespace.
2104    TODO: Add to global symbol tree.  */
2105
2106 gfc_common_head *
2107 gfc_get_common (const char *name, int from_module)
2108 {
2109   gfc_symtree *st;
2110   static int serial = 0;
2111   char mangled_name[GFC_MAX_SYMBOL_LEN+1];
2112
2113   if (from_module)
2114     {
2115       /* A use associated common block is only needed to correctly layout
2116          the variables it contains.  */
2117       snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2118       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2119     }
2120   else
2121     {
2122       st = gfc_find_symtree (gfc_current_ns->common_root, name);
2123
2124       if (st == NULL)
2125         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2126     }
2127
2128   if (st->n.common == NULL)
2129     {
2130       st->n.common = gfc_get_common_head ();
2131       st->n.common->where = gfc_current_locus;
2132       strcpy (st->n.common->name, name);
2133     }
2134
2135   return st->n.common;
2136 }
2137
2138
2139 /* Match a common block name.  */
2140
2141 static match
2142 match_common_name (char *name)
2143 {
2144   match m;
2145
2146   if (gfc_match_char ('/') == MATCH_NO)
2147     {
2148       name[0] = '\0';
2149       return MATCH_YES;
2150     }
2151
2152   if (gfc_match_char ('/') == MATCH_YES)
2153     {
2154       name[0] = '\0';
2155       return MATCH_YES;
2156     }
2157
2158   m = gfc_match_name (name);
2159
2160   if (m == MATCH_ERROR)
2161     return MATCH_ERROR;
2162   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2163     return MATCH_YES;
2164
2165   gfc_error ("Syntax error in common block name at %C");
2166   return MATCH_ERROR;
2167 }
2168
2169
2170 /* Match a COMMON statement.  */
2171
2172 match
2173 gfc_match_common (void)
2174 {
2175   gfc_symbol *sym, **head, *tail, *old_blank_common;
2176   char name[GFC_MAX_SYMBOL_LEN+1];
2177   gfc_common_head *t;
2178   gfc_array_spec *as;
2179   match m;
2180
2181   old_blank_common = gfc_current_ns->blank_common.head;
2182   if (old_blank_common)
2183     {
2184       while (old_blank_common->common_next)
2185         old_blank_common = old_blank_common->common_next;
2186     }
2187
2188   as = NULL;
2189
2190   if (gfc_match_eos () == MATCH_YES)
2191     goto syntax;
2192
2193   for (;;)
2194     {
2195       m = match_common_name (name);
2196       if (m == MATCH_ERROR)
2197         goto cleanup;
2198
2199       if (name[0] == '\0')
2200         {
2201           t = &gfc_current_ns->blank_common;
2202           if (t->head == NULL)
2203             t->where = gfc_current_locus;
2204           head = &t->head;
2205         }
2206       else
2207         {
2208           t = gfc_get_common (name, 0);
2209           head = &t->head;
2210         }
2211
2212       if (*head == NULL)
2213         tail = NULL;
2214       else
2215         {
2216           tail = *head;
2217           while (tail->common_next)
2218             tail = tail->common_next;
2219         }
2220
2221       /* Grab the list of symbols.  */
2222       if (gfc_match_eos () == MATCH_YES)
2223         goto done;
2224
2225       for (;;)
2226         {
2227           m = gfc_match_symbol (&sym, 0);
2228           if (m == MATCH_ERROR)
2229             goto cleanup;
2230           if (m == MATCH_NO)
2231             goto syntax;
2232
2233           if (sym->attr.in_common)
2234             {
2235               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2236                          sym->name);
2237               goto cleanup;
2238             }
2239
2240           if (gfc_add_in_common (&sym->attr, NULL) == FAILURE)
2241             goto cleanup;
2242
2243           if (sym->value != NULL
2244               && (name[0] == '\0' || !sym->attr.data))
2245             {
2246               if (name[0] == '\0')
2247                 gfc_error ("Previously initialized symbol '%s' in "
2248                            "blank COMMON block at %C", sym->name);
2249               else
2250                 gfc_error ("Previously initialized symbol '%s' in "
2251                            "COMMON block '%s' at %C", sym->name, name);
2252               goto cleanup;
2253             }
2254
2255           if (gfc_add_in_common (&sym->attr, NULL) == FAILURE)
2256             goto cleanup;
2257
2258           /* Derived type names must have the SEQUENCE attribute.  */
2259           if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2260             {
2261               gfc_error
2262                 ("Derived type variable in COMMON at %C does not have the "
2263                  "SEQUENCE attribute");
2264               goto cleanup;
2265             }
2266
2267           if (tail != NULL)
2268             tail->common_next = sym;
2269           else
2270             *head = sym;
2271
2272           tail = sym;
2273
2274           /* Deal with an optional array specification after the
2275              symbol name.  */
2276           m = gfc_match_array_spec (&as);
2277           if (m == MATCH_ERROR)
2278             goto cleanup;
2279
2280           if (m == MATCH_YES)
2281             {
2282               if (as->type != AS_EXPLICIT)
2283                 {
2284                   gfc_error
2285                     ("Array specification for symbol '%s' in COMMON at %C "
2286                      "must be explicit", sym->name);
2287                   goto cleanup;
2288                 }
2289
2290               if (gfc_add_dimension (&sym->attr, NULL) == FAILURE)
2291                 goto cleanup;
2292
2293               if (sym->attr.pointer)
2294                 {
2295                   gfc_error
2296                     ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2297                      sym->name);
2298                   goto cleanup;
2299                 }
2300
2301               sym->as = as;
2302               as = NULL;
2303             }
2304
2305           if (gfc_match_eos () == MATCH_YES)
2306             goto done;
2307           if (gfc_peek_char () == '/')
2308             break;
2309           if (gfc_match_char (',') != MATCH_YES)
2310             goto syntax;
2311           if (gfc_peek_char () == '/')
2312             break;
2313         }
2314     }
2315
2316 done:
2317   return MATCH_YES;
2318
2319 syntax:
2320   gfc_syntax_error (ST_COMMON);
2321
2322 cleanup:
2323   if (old_blank_common)
2324     old_blank_common->common_next = NULL;
2325   else
2326     gfc_current_ns->blank_common.head = NULL;
2327   gfc_free_array_spec (as);
2328   return MATCH_ERROR;
2329 }
2330
2331
2332 /* Match a BLOCK DATA program unit.  */
2333
2334 match
2335 gfc_match_block_data (void)
2336 {
2337   char name[GFC_MAX_SYMBOL_LEN + 1];
2338   gfc_symbol *sym;
2339   match m;
2340
2341   if (gfc_match_eos () == MATCH_YES)
2342     {
2343       gfc_new_block = NULL;
2344       return MATCH_YES;
2345     }
2346
2347   m = gfc_match ("% %n%t", name);
2348   if (m != MATCH_YES)
2349     return MATCH_ERROR;
2350
2351   if (gfc_get_symbol (name, NULL, &sym))
2352     return MATCH_ERROR;
2353
2354   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, NULL) == FAILURE)
2355     return MATCH_ERROR;
2356
2357   gfc_new_block = sym;
2358
2359   return MATCH_YES;
2360 }
2361
2362
2363 /* Free a namelist structure.  */
2364
2365 void
2366 gfc_free_namelist (gfc_namelist * name)
2367 {
2368   gfc_namelist *n;
2369
2370   for (; name; name = n)
2371     {
2372       n = name->next;
2373       gfc_free (name);
2374     }
2375 }
2376
2377
2378 /* Match a NAMELIST statement.  */
2379
2380 match
2381 gfc_match_namelist (void)
2382 {
2383   gfc_symbol *group_name, *sym;
2384   gfc_namelist *nl;
2385   match m, m2;
2386
2387   m = gfc_match (" / %s /", &group_name);
2388   if (m == MATCH_NO)
2389     goto syntax;
2390   if (m == MATCH_ERROR)
2391     goto error;
2392
2393   for (;;)
2394     {
2395       if (group_name->ts.type != BT_UNKNOWN)
2396         {
2397           gfc_error
2398             ("Namelist group name '%s' at %C already has a basic type "
2399              "of %s", group_name->name, gfc_typename (&group_name->ts));
2400           return MATCH_ERROR;
2401         }
2402
2403       if (group_name->attr.flavor != FL_NAMELIST
2404           && gfc_add_flavor (&group_name->attr, FL_NAMELIST, NULL) == FAILURE)
2405         return MATCH_ERROR;
2406
2407       for (;;)
2408         {
2409           m = gfc_match_symbol (&sym, 1);
2410           if (m == MATCH_NO)
2411             goto syntax;
2412           if (m == MATCH_ERROR)
2413             goto error;
2414
2415           if (sym->attr.in_namelist == 0
2416               && gfc_add_in_namelist (&sym->attr, NULL) == FAILURE)
2417             goto error;
2418
2419           /* TODO: worry about PRIVATE members of a PUBLIC namelist
2420              group.  */
2421
2422           nl = gfc_get_namelist ();
2423           nl->sym = sym;
2424
2425           if (group_name->namelist == NULL)
2426             group_name->namelist = group_name->namelist_tail = nl;
2427           else
2428             {
2429               group_name->namelist_tail->next = nl;
2430               group_name->namelist_tail = nl;
2431             }
2432
2433           if (gfc_match_eos () == MATCH_YES)
2434             goto done;
2435
2436           m = gfc_match_char (',');
2437
2438           if (gfc_match_char ('/') == MATCH_YES)
2439             {
2440               m2 = gfc_match (" %s /", &group_name);
2441               if (m2 == MATCH_YES)
2442                 break;
2443               if (m2 == MATCH_ERROR)
2444                 goto error;
2445               goto syntax;
2446             }
2447
2448           if (m != MATCH_YES)
2449             goto syntax;
2450         }
2451     }
2452
2453 done:
2454   return MATCH_YES;
2455
2456 syntax:
2457   gfc_syntax_error (ST_NAMELIST);
2458
2459 error:
2460   return MATCH_ERROR;
2461 }
2462
2463
2464 /* Match a MODULE statement.  */
2465
2466 match
2467 gfc_match_module (void)
2468 {
2469   match m;
2470
2471   m = gfc_match (" %s%t", &gfc_new_block);
2472   if (m != MATCH_YES)
2473     return m;
2474
2475   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, NULL) == FAILURE)
2476     return MATCH_ERROR;
2477
2478   return MATCH_YES;
2479 }
2480
2481
2482 /* Free equivalence sets and lists.  Recursively is the easiest way to
2483    do this.  */
2484
2485 void
2486 gfc_free_equiv (gfc_equiv * eq)
2487 {
2488
2489   if (eq == NULL)
2490     return;
2491
2492   gfc_free_equiv (eq->eq);
2493   gfc_free_equiv (eq->next);
2494
2495   gfc_free_expr (eq->expr);
2496   gfc_free (eq);
2497 }
2498
2499
2500 /* Match an EQUIVALENCE statement.  */
2501
2502 match
2503 gfc_match_equivalence (void)
2504 {
2505   gfc_equiv *eq, *set, *tail;
2506   gfc_ref *ref;
2507   match m;
2508
2509   tail = NULL;
2510
2511   for (;;)
2512     {
2513       eq = gfc_get_equiv ();
2514       if (tail == NULL)
2515         tail = eq;
2516
2517       eq->next = gfc_current_ns->equiv;
2518       gfc_current_ns->equiv = eq;
2519
2520       if (gfc_match_char ('(') != MATCH_YES)
2521         goto syntax;
2522
2523       set = eq;
2524
2525       for (;;)
2526         {
2527           m = gfc_match_variable (&set->expr, 1);
2528           if (m == MATCH_ERROR)
2529             goto cleanup;
2530           if (m == MATCH_NO)
2531             goto syntax;
2532
2533           for (ref = set->expr->ref; ref; ref = ref->next)
2534             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2535               {
2536                 gfc_error
2537                   ("Array reference in EQUIVALENCE at %C cannot be an "
2538                    "array section");
2539                 goto cleanup;
2540               }
2541
2542           if (gfc_match_char (')') == MATCH_YES)
2543             break;
2544           if (gfc_match_char (',') != MATCH_YES)
2545             goto syntax;
2546
2547           set->eq = gfc_get_equiv ();
2548           set = set->eq;
2549         }
2550
2551       if (gfc_match_eos () == MATCH_YES)
2552         break;
2553       if (gfc_match_char (',') != MATCH_YES)
2554         goto syntax;
2555     }
2556
2557   return MATCH_YES;
2558
2559 syntax:
2560   gfc_syntax_error (ST_EQUIVALENCE);
2561
2562 cleanup:
2563   eq = tail->next;
2564   tail->next = NULL;
2565
2566   gfc_free_equiv (gfc_current_ns->equiv);
2567   gfc_current_ns->equiv = eq;
2568
2569   return MATCH_ERROR;
2570 }
2571
2572
2573 /* Match a statement function declaration.  It is so easy to match
2574    non-statement function statements with a MATCH_ERROR as opposed to
2575    MATCH_NO that we suppress error message in most cases.  */
2576
2577 match
2578 gfc_match_st_function (void)
2579 {
2580   gfc_error_buf old_error;
2581   gfc_symbol *sym;
2582   gfc_expr *expr;
2583   match m;
2584
2585   m = gfc_match_symbol (&sym, 0);
2586   if (m != MATCH_YES)
2587     return m;
2588
2589   gfc_push_error (&old_error);
2590
2591   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, NULL) == FAILURE)
2592     goto undo_error;
2593
2594   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2595     goto undo_error;
2596
2597   m = gfc_match (" = %e%t", &expr);
2598   if (m == MATCH_NO)
2599     goto undo_error;
2600   if (m == MATCH_ERROR)
2601     return m;
2602
2603   sym->value = expr;
2604
2605   return MATCH_YES;
2606
2607 undo_error:
2608   gfc_pop_error (&old_error);
2609   return MATCH_NO;
2610 }
2611
2612
2613 /********************* DATA statement subroutines *********************/
2614
2615 /* Free a gfc_data_variable structure and everything beneath it.  */
2616
2617 static void
2618 free_variable (gfc_data_variable * p)
2619 {
2620   gfc_data_variable *q;
2621
2622   for (; p; p = q)
2623     {
2624       q = p->next;
2625       gfc_free_expr (p->expr);
2626       gfc_free_iterator (&p->iter, 0);
2627       free_variable (p->list);
2628
2629       gfc_free (p);
2630     }
2631 }
2632
2633
2634 /* Free a gfc_data_value structure and everything beneath it.  */
2635
2636 static void
2637 free_value (gfc_data_value * p)
2638 {
2639   gfc_data_value *q;
2640
2641   for (; p; p = q)
2642     {
2643       q = p->next;
2644       gfc_free_expr (p->expr);
2645       gfc_free (p);
2646     }
2647 }
2648
2649
2650 /* Free a list of gfc_data structures.  */
2651
2652 void
2653 gfc_free_data (gfc_data * p)
2654 {
2655   gfc_data *q;
2656
2657   for (; p; p = q)
2658     {
2659       q = p->next;
2660
2661       free_variable (p->var);
2662       free_value (p->value);
2663
2664       gfc_free (p);
2665     }
2666 }
2667
2668
2669 static match var_element (gfc_data_variable *);
2670
2671 /* Match a list of variables terminated by an iterator and a right
2672    parenthesis.  */
2673
2674 static match
2675 var_list (gfc_data_variable * parent)
2676 {
2677   gfc_data_variable *tail, var;
2678   match m;
2679
2680   m = var_element (&var);
2681   if (m == MATCH_ERROR)
2682     return MATCH_ERROR;
2683   if (m == MATCH_NO)
2684     goto syntax;
2685
2686   tail = gfc_get_data_variable ();
2687   *tail = var;
2688
2689   parent->list = tail;
2690
2691   for (;;)
2692     {
2693       if (gfc_match_char (',') != MATCH_YES)
2694         goto syntax;
2695
2696       m = gfc_match_iterator (&parent->iter, 1);
2697       if (m == MATCH_YES)
2698         break;
2699       if (m == MATCH_ERROR)
2700         return MATCH_ERROR;
2701
2702       m = var_element (&var);
2703       if (m == MATCH_ERROR)
2704         return MATCH_ERROR;
2705       if (m == MATCH_NO)
2706         goto syntax;
2707
2708       tail->next = gfc_get_data_variable ();
2709       tail = tail->next;
2710
2711       *tail = var;
2712     }
2713
2714   if (gfc_match_char (')') != MATCH_YES)
2715     goto syntax;
2716   return MATCH_YES;
2717
2718 syntax:
2719   gfc_syntax_error (ST_DATA);
2720   return MATCH_ERROR;
2721 }
2722
2723
2724 /* Match a single element in a data variable list, which can be a
2725    variable-iterator list.  */
2726
2727 static match
2728 var_element (gfc_data_variable * new)
2729 {
2730   match m;
2731   gfc_symbol *sym;
2732
2733   memset (new, '\0', sizeof (gfc_data_variable));
2734
2735   if (gfc_match_char ('(') == MATCH_YES)
2736     return var_list (new);
2737
2738   m = gfc_match_variable (&new->expr, 0);
2739   if (m != MATCH_YES)
2740     return m;
2741
2742   sym = new->expr->symtree->n.sym;
2743
2744   if(sym->value != NULL)
2745     {
2746       gfc_error ("Variable '%s' at %C already has an initialization",
2747                  sym->name);
2748       return MATCH_ERROR;
2749     }
2750
2751 #if 0 // TODO: Find out where to move this message
2752   if (sym->attr.in_common)
2753     /* See if sym is in the blank common block.  */
2754     for (t = &sym->ns->blank_common; t; t = t->common_next)
2755       if (sym == t->head)
2756         {
2757           gfc_error ("DATA statement at %C may not initialize variable "
2758                      "'%s' from blank COMMON", sym->name);
2759           return MATCH_ERROR;
2760         }
2761 #endif
2762
2763   if (gfc_add_data (&sym->attr, &new->expr->where) == FAILURE)
2764     return MATCH_ERROR;
2765
2766   return MATCH_YES;
2767 }
2768
2769
2770 /* Match the top-level list of data variables.  */
2771
2772 static match
2773 top_var_list (gfc_data * d)
2774 {
2775   gfc_data_variable var, *tail, *new;
2776   match m;
2777
2778   tail = NULL;
2779
2780   for (;;)
2781     {
2782       m = var_element (&var);
2783       if (m == MATCH_NO)
2784         goto syntax;
2785       if (m == MATCH_ERROR)
2786         return MATCH_ERROR;
2787
2788       new = gfc_get_data_variable ();
2789       *new = var;
2790
2791       if (tail == NULL)
2792         d->var = new;
2793       else
2794         tail->next = new;
2795
2796       tail = new;
2797
2798       if (gfc_match_char ('/') == MATCH_YES)
2799         break;
2800       if (gfc_match_char (',') != MATCH_YES)
2801         goto syntax;
2802     }
2803
2804   return MATCH_YES;
2805
2806 syntax:
2807   gfc_syntax_error (ST_DATA);
2808   return MATCH_ERROR;
2809 }
2810
2811
2812 static match
2813 match_data_constant (gfc_expr ** result)
2814 {
2815   char name[GFC_MAX_SYMBOL_LEN + 1];
2816   gfc_symbol *sym;
2817   gfc_expr *expr;
2818   match m;
2819
2820   m = gfc_match_literal_constant (&expr, 1);
2821   if (m == MATCH_YES)
2822     {
2823       *result = expr;
2824       return MATCH_YES;
2825     }
2826
2827   if (m == MATCH_ERROR)
2828     return MATCH_ERROR;
2829
2830   m = gfc_match_null (result);
2831   if (m != MATCH_NO)
2832     return m;
2833
2834   m = gfc_match_name (name);
2835   if (m != MATCH_YES)
2836     return m;
2837
2838   if (gfc_find_symbol (name, NULL, 1, &sym))
2839     return MATCH_ERROR;
2840
2841   if (sym == NULL
2842       || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
2843     {
2844       gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
2845                  name);
2846       return MATCH_ERROR;
2847     }
2848   else if (sym->attr.flavor == FL_DERIVED)
2849     return gfc_match_structure_constructor (sym, result);
2850
2851   *result = gfc_copy_expr (sym->value);
2852   return MATCH_YES;
2853 }
2854
2855
2856 /* Match a list of values in a DATA statement.  The leading '/' has
2857    already been seen at this point.  */
2858
2859 static match
2860 top_val_list (gfc_data * data)
2861 {
2862   gfc_data_value *new, *tail;
2863   gfc_expr *expr;
2864   const char *msg;
2865   match m;
2866
2867   tail = NULL;
2868
2869   for (;;)
2870     {
2871       m = match_data_constant (&expr);
2872       if (m == MATCH_NO)
2873         goto syntax;
2874       if (m == MATCH_ERROR)
2875         return MATCH_ERROR;
2876
2877       new = gfc_get_data_value ();
2878
2879       if (tail == NULL)
2880         data->value = new;
2881       else
2882         tail->next = new;
2883
2884       tail = new;
2885
2886       if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
2887         {
2888           tail->expr = expr;
2889           tail->repeat = 1;
2890         }
2891       else
2892         {
2893           msg = gfc_extract_int (expr, &tail->repeat);
2894           gfc_free_expr (expr);
2895           if (msg != NULL)
2896             {
2897               gfc_error (msg);
2898               return MATCH_ERROR;
2899             }
2900
2901           m = match_data_constant (&tail->expr);
2902           if (m == MATCH_NO)
2903             goto syntax;
2904           if (m == MATCH_ERROR)
2905             return MATCH_ERROR;
2906         }
2907
2908       if (gfc_match_char ('/') == MATCH_YES)
2909         break;
2910       if (gfc_match_char (',') == MATCH_NO)
2911         goto syntax;
2912     }
2913
2914   return MATCH_YES;
2915
2916 syntax:
2917   gfc_syntax_error (ST_DATA);
2918   return MATCH_ERROR;
2919 }
2920
2921
2922 /* Match a DATA statement.  */
2923
2924 match
2925 gfc_match_data (void)
2926 {
2927   gfc_data *new;
2928   match m;
2929
2930   for (;;)
2931     {
2932       new = gfc_get_data ();
2933       new->where = gfc_current_locus;
2934
2935       m = top_var_list (new);
2936       if (m != MATCH_YES)
2937         goto cleanup;
2938
2939       m = top_val_list (new);
2940       if (m != MATCH_YES)
2941         goto cleanup;
2942
2943       new->next = gfc_current_ns->data;
2944       gfc_current_ns->data = new;
2945
2946       if (gfc_match_eos () == MATCH_YES)
2947         break;
2948
2949       gfc_match_char (',');     /* Optional comma */
2950     }
2951
2952   if (gfc_pure (NULL))
2953     {
2954       gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
2955       return MATCH_ERROR;
2956     }
2957
2958   return MATCH_YES;
2959
2960 cleanup:
2961   gfc_free_data (new);
2962   return MATCH_ERROR;
2963 }
2964
2965
2966 /***************** SELECT CASE subroutines ******************/
2967
2968 /* Free a single case structure.  */
2969
2970 static void
2971 free_case (gfc_case * p)
2972 {
2973   if (p->low == p->high)
2974     p->high = NULL;
2975   gfc_free_expr (p->low);
2976   gfc_free_expr (p->high);
2977   gfc_free (p);
2978 }
2979
2980
2981 /* Free a list of case structures.  */
2982
2983 void
2984 gfc_free_case_list (gfc_case * p)
2985 {
2986   gfc_case *q;
2987
2988   for (; p; p = q)
2989     {
2990       q = p->next;
2991       free_case (p);
2992     }
2993 }
2994
2995
2996 /* Match a single case selector.  */
2997
2998 static match
2999 match_case_selector (gfc_case ** cp)
3000 {
3001   gfc_case *c;
3002   match m;
3003
3004   c = gfc_get_case ();
3005   c->where = gfc_current_locus;
3006
3007   if (gfc_match_char (':') == MATCH_YES)
3008     {
3009       m = gfc_match_init_expr (&c->high);
3010       if (m == MATCH_NO)
3011         goto need_expr;
3012       if (m == MATCH_ERROR)
3013         goto cleanup;
3014     }
3015
3016   else
3017     {
3018       m = gfc_match_init_expr (&c->low);
3019       if (m == MATCH_ERROR)
3020         goto cleanup;
3021       if (m == MATCH_NO)
3022         goto need_expr;
3023
3024       /* If we're not looking at a ':' now, make a range out of a single
3025          target.  Else get the upper bound for the case range. */
3026       if (gfc_match_char (':') != MATCH_YES)
3027         c->high = c->low;
3028       else
3029         {
3030           m = gfc_match_init_expr (&c->high);
3031           if (m == MATCH_ERROR)
3032             goto cleanup;
3033           /* MATCH_NO is fine.  It's OK if nothing is there!  */
3034         }
3035     }
3036
3037   *cp = c;
3038   return MATCH_YES;
3039
3040 need_expr:
3041   gfc_error ("Expected initialization expression in CASE at %C");
3042
3043 cleanup:
3044   free_case (c);
3045   return MATCH_ERROR;
3046 }
3047
3048
3049 /* Match the end of a case statement.  */
3050
3051 static match
3052 match_case_eos (void)
3053 {
3054   char name[GFC_MAX_SYMBOL_LEN + 1];
3055   match m;
3056
3057   if (gfc_match_eos () == MATCH_YES)
3058     return MATCH_YES;
3059
3060   gfc_gobble_whitespace ();
3061
3062   m = gfc_match_name (name);
3063   if (m != MATCH_YES)
3064     return m;
3065
3066   if (strcmp (name, gfc_current_block ()->name) != 0)
3067     {
3068       gfc_error ("Expected case name of '%s' at %C",
3069                  gfc_current_block ()->name);
3070       return MATCH_ERROR;
3071     }
3072
3073   return gfc_match_eos ();
3074 }
3075
3076
3077 /* Match a SELECT statement.  */
3078
3079 match
3080 gfc_match_select (void)
3081 {
3082   gfc_expr *expr;
3083   match m;
3084
3085   m = gfc_match_label ();
3086   if (m == MATCH_ERROR)
3087     return m;
3088
3089   m = gfc_match (" select case ( %e )%t", &expr);
3090   if (m != MATCH_YES)
3091     return m;
3092
3093   new_st.op = EXEC_SELECT;
3094   new_st.expr = expr;
3095
3096   return MATCH_YES;
3097 }
3098
3099
3100 /* Match a CASE statement.  */
3101
3102 match
3103 gfc_match_case (void)
3104 {
3105   gfc_case *c, *head, *tail;
3106   match m;
3107
3108   head = tail = NULL;
3109
3110   if (gfc_current_state () != COMP_SELECT)
3111     {
3112       gfc_error ("Unexpected CASE statement at %C");
3113       return MATCH_ERROR;
3114     }
3115
3116   if (gfc_match ("% default") == MATCH_YES)
3117     {
3118       m = match_case_eos ();
3119       if (m == MATCH_NO)
3120         goto syntax;
3121       if (m == MATCH_ERROR)
3122         goto cleanup;
3123
3124       new_st.op = EXEC_SELECT;
3125       c = gfc_get_case ();
3126       c->where = gfc_current_locus;
3127       new_st.ext.case_list = c;
3128       return MATCH_YES;
3129     }
3130
3131   if (gfc_match_char ('(') != MATCH_YES)
3132     goto syntax;
3133
3134   for (;;)
3135     {
3136       if (match_case_selector (&c) == MATCH_ERROR)
3137         goto cleanup;
3138
3139       if (head == NULL)
3140         head = c;
3141       else
3142         tail->next = c;
3143
3144       tail = c;
3145
3146       if (gfc_match_char (')') == MATCH_YES)
3147         break;
3148       if (gfc_match_char (',') != MATCH_YES)
3149         goto syntax;
3150     }
3151
3152   m = match_case_eos ();
3153   if (m == MATCH_NO)
3154     goto syntax;
3155   if (m == MATCH_ERROR)
3156     goto cleanup;
3157
3158   new_st.op = EXEC_SELECT;
3159   new_st.ext.case_list = head;
3160
3161   return MATCH_YES;
3162
3163 syntax:
3164   gfc_error ("Syntax error in CASE-specification at %C");
3165
3166 cleanup:
3167   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
3168   return MATCH_ERROR;
3169 }
3170
3171 /********************* WHERE subroutines ********************/
3172
3173 /* Match a WHERE statement.  */
3174
3175 match
3176 gfc_match_where (gfc_statement * st)
3177 {
3178   gfc_expr *expr;
3179   match m0, m;
3180   gfc_code *c;
3181
3182   m0 = gfc_match_label ();
3183   if (m0 == MATCH_ERROR)
3184     return m0;
3185
3186   m = gfc_match (" where ( %e )", &expr);
3187   if (m != MATCH_YES)
3188     return m;
3189
3190   if (gfc_match_eos () == MATCH_YES)
3191     {
3192       *st = ST_WHERE_BLOCK;
3193
3194       new_st.op = EXEC_WHERE;
3195       new_st.expr = expr;
3196       return MATCH_YES;
3197     }
3198
3199   m = gfc_match_assignment ();
3200   if (m == MATCH_NO)
3201     gfc_syntax_error (ST_WHERE);
3202
3203   if (m != MATCH_YES)
3204     {
3205       gfc_free_expr (expr);
3206       return MATCH_ERROR;
3207     }
3208
3209   /* We've got a simple WHERE statement.  */
3210   *st = ST_WHERE;
3211   c = gfc_get_code ();
3212
3213   c->op = EXEC_WHERE;
3214   c->expr = expr;
3215   c->next = gfc_get_code ();
3216
3217   *c->next = new_st;
3218   gfc_clear_new_st ();
3219
3220   new_st.op = EXEC_WHERE;
3221   new_st.block = c;
3222
3223   return MATCH_YES;
3224 }
3225
3226
3227 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
3228    new_st if successful.  */
3229
3230 match
3231 gfc_match_elsewhere (void)
3232 {
3233   char name[GFC_MAX_SYMBOL_LEN + 1];
3234   gfc_expr *expr;
3235   match m;
3236
3237   if (gfc_current_state () != COMP_WHERE)
3238     {
3239       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3240       return MATCH_ERROR;
3241     }
3242
3243   expr = NULL;
3244
3245   if (gfc_match_char ('(') == MATCH_YES)
3246     {
3247       m = gfc_match_expr (&expr);
3248       if (m == MATCH_NO)
3249         goto syntax;
3250       if (m == MATCH_ERROR)
3251         return MATCH_ERROR;
3252
3253       if (gfc_match_char (')') != MATCH_YES)
3254         goto syntax;
3255     }
3256
3257   if (gfc_match_eos () != MATCH_YES)
3258     {                           /* Better be a name at this point */
3259       m = gfc_match_name (name);
3260       if (m == MATCH_NO)
3261         goto syntax;
3262       if (m == MATCH_ERROR)
3263         goto cleanup;
3264
3265       if (gfc_match_eos () != MATCH_YES)
3266         goto syntax;
3267
3268       if (strcmp (name, gfc_current_block ()->name) != 0)
3269         {
3270           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3271                      name, gfc_current_block ()->name);
3272           goto cleanup;
3273         }
3274     }
3275
3276   new_st.op = EXEC_WHERE;
3277   new_st.expr = expr;
3278   return MATCH_YES;
3279
3280 syntax:
3281   gfc_syntax_error (ST_ELSEWHERE);
3282
3283 cleanup:
3284   gfc_free_expr (expr);
3285   return MATCH_ERROR;
3286 }
3287
3288
3289 /******************** FORALL subroutines ********************/
3290
3291 /* Free a list of FORALL iterators.  */
3292
3293 void
3294 gfc_free_forall_iterator (gfc_forall_iterator * iter)
3295 {
3296   gfc_forall_iterator *next;
3297
3298   while (iter)
3299     {
3300       next = iter->next;
3301
3302       gfc_free_expr (iter->var);
3303       gfc_free_expr (iter->start);
3304       gfc_free_expr (iter->end);
3305       gfc_free_expr (iter->stride);
3306
3307       gfc_free (iter);
3308       iter = next;
3309     }
3310 }
3311
3312
3313 /* Match an iterator as part of a FORALL statement.  The format is:
3314
3315      <var> = <start>:<end>[:<stride>][, <scalar mask>]  */
3316
3317 static match
3318 match_forall_iterator (gfc_forall_iterator ** result)
3319 {
3320   gfc_forall_iterator *iter;
3321   locus where;
3322   match m;
3323
3324   where = gfc_current_locus;
3325   iter = gfc_getmem (sizeof (gfc_forall_iterator));
3326
3327   m = gfc_match_variable (&iter->var, 0);
3328   if (m != MATCH_YES)
3329     goto cleanup;
3330
3331   if (gfc_match_char ('=') != MATCH_YES)
3332     {
3333       m = MATCH_NO;
3334       goto cleanup;
3335     }
3336
3337   m = gfc_match_expr (&iter->start);
3338   if (m == MATCH_NO)
3339     goto syntax;
3340   if (m == MATCH_ERROR)
3341     goto cleanup;
3342
3343   if (gfc_match_char (':') != MATCH_YES)
3344     goto syntax;
3345
3346   m = gfc_match_expr (&iter->end);
3347   if (m == MATCH_NO)
3348     goto syntax;
3349   if (m == MATCH_ERROR)
3350     goto cleanup;
3351
3352   if (gfc_match_char (':') == MATCH_NO)
3353     iter->stride = gfc_int_expr (1);
3354   else
3355     {
3356       m = gfc_match_expr (&iter->stride);
3357       if (m == MATCH_NO)
3358         goto syntax;
3359       if (m == MATCH_ERROR)
3360         goto cleanup;
3361     }
3362
3363   *result = iter;
3364   return MATCH_YES;
3365
3366 syntax:
3367   gfc_error ("Syntax error in FORALL iterator at %C");
3368   m = MATCH_ERROR;
3369
3370 cleanup:
3371   gfc_current_locus = where;
3372   gfc_free_forall_iterator (iter);
3373   return m;
3374 }
3375
3376
3377 /* Match a FORALL statement.  */
3378
3379 match
3380 gfc_match_forall (gfc_statement * st)
3381 {
3382   gfc_forall_iterator *head, *tail, *new;
3383   gfc_expr *mask;
3384   gfc_code *c;
3385   match m0, m;
3386
3387   head = tail = NULL;
3388   mask = NULL;
3389   c = NULL;
3390
3391   m0 = gfc_match_label ();
3392   if (m0 == MATCH_ERROR)
3393     return MATCH_ERROR;
3394
3395   m = gfc_match (" forall (");
3396   if (m != MATCH_YES)
3397     return m;
3398
3399   m = match_forall_iterator (&new);
3400   if (m == MATCH_ERROR)
3401     goto cleanup;
3402   if (m == MATCH_NO)
3403     goto syntax;
3404
3405   head = tail = new;
3406
3407   for (;;)
3408     {
3409       if (gfc_match_char (',') != MATCH_YES)
3410         break;
3411
3412       m = match_forall_iterator (&new);
3413       if (m == MATCH_ERROR)
3414         goto cleanup;
3415       if (m == MATCH_YES)
3416         {
3417           tail->next = new;
3418           tail = new;
3419           continue;
3420         }
3421
3422       /* Have to have a mask expression.  */
3423       m = gfc_match_expr (&mask);
3424       if (m == MATCH_NO)
3425         goto syntax;
3426       if (m == MATCH_ERROR)
3427         goto cleanup;
3428
3429       break;
3430     }
3431
3432   if (gfc_match_char (')') == MATCH_NO)
3433     goto syntax;
3434
3435   if (gfc_match_eos () == MATCH_YES)
3436     {
3437       *st = ST_FORALL_BLOCK;
3438
3439       new_st.op = EXEC_FORALL;
3440       new_st.expr = mask;
3441       new_st.ext.forall_iterator = head;
3442
3443       return MATCH_YES;
3444     }
3445
3446   m = gfc_match_assignment ();
3447   if (m == MATCH_ERROR)
3448     goto cleanup;
3449   if (m == MATCH_NO)
3450     {
3451       m = gfc_match_pointer_assignment ();
3452       if (m == MATCH_ERROR)
3453         goto cleanup;
3454       if (m == MATCH_NO)
3455         goto syntax;
3456     }
3457
3458   c = gfc_get_code ();
3459   *c = new_st;
3460
3461   if (gfc_match_eos () != MATCH_YES)
3462     goto syntax;
3463
3464   gfc_clear_new_st ();
3465   new_st.op = EXEC_FORALL;
3466   new_st.expr = mask;
3467   new_st.ext.forall_iterator = head;
3468   new_st.block = gfc_get_code ();
3469
3470   new_st.block->op = EXEC_FORALL;
3471   new_st.block->next = c;
3472
3473   *st = ST_FORALL;
3474   return MATCH_YES;
3475
3476 syntax:
3477   gfc_syntax_error (ST_FORALL);
3478
3479 cleanup:
3480   gfc_free_forall_iterator (head);
3481   gfc_free_expr (mask);
3482   gfc_free_statements (c);
3483   return MATCH_NO;
3484 }