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