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