gcc/fortran/match.c

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