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, *o;
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 (o = NULL, p = gfc_state_stack; p; p = p->previous)
1372     if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1373       break;
1374     else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1375       o = p;
1376
1377   if (p == NULL)
1378     {
1379       if (sym == NULL)
1380         gfc_error ("%s statement at %C is not within a loop",
1381                    gfc_ascii_statement (st));
1382       else
1383         gfc_error ("%s statement at %C is not within loop '%s'",
1384                    gfc_ascii_statement (st), sym->name);
1385
1386       return MATCH_ERROR;
1387     }
1388
1389   if (o != NULL)
1390     {
1391       gfc_error ("%s statement at %C leaving OpenMP structured block",
1392                  gfc_ascii_statement (st));
1393       return MATCH_ERROR;
1394     }
1395   else if (st == ST_EXIT
1396            && p->previous != NULL
1397            && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1398            && (p->previous->head->op == EXEC_OMP_DO
1399                || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1400     {
1401       gcc_assert (p->previous->head->next != NULL);
1402       gcc_assert (p->previous->head->next->op == EXEC_DO
1403                   || p->previous->head->next->op == EXEC_DO_WHILE);
1404       gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1405       return MATCH_ERROR;
1406     }
1407
1408   /* Save the first statement in the loop - needed by the backend.  */
1409   new_st.ext.whichloop = p->head;
1410
1411   new_st.op = op;
1412 /*  new_st.sym = sym;*/
1413
1414   return MATCH_YES;
1415 }
1416
1417
1418 /* Match the EXIT statement.  */
1419
1420 match
1421 gfc_match_exit (void)
1422 {
1423
1424   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1425 }
1426
1427
1428 /* Match the CYCLE statement.  */
1429
1430 match
1431 gfc_match_cycle (void)
1432 {
1433
1434   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1435 }
1436
1437
1438 /* Match a number or character constant after a STOP or PAUSE statement.  */
1439
1440 static match
1441 gfc_match_stopcode (gfc_statement st)
1442 {
1443   int stop_code;
1444   gfc_expr *e;
1445   match m;
1446   int cnt;
1447
1448   stop_code = -1;
1449   e = NULL;
1450
1451   if (gfc_match_eos () != MATCH_YES)
1452     {
1453       m = gfc_match_small_literal_int (&stop_code, &cnt);
1454       if (m == MATCH_ERROR)
1455         goto cleanup;
1456
1457       if (m == MATCH_YES && cnt > 5)
1458         {
1459           gfc_error ("Too many digits in STOP code at %C");
1460           goto cleanup;
1461         }
1462
1463       if (m == MATCH_NO)
1464         {
1465           /* Try a character constant.  */
1466           m = gfc_match_expr (&e);
1467           if (m == MATCH_ERROR)
1468             goto cleanup;
1469           if (m == MATCH_NO)
1470             goto syntax;
1471           if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1472             goto syntax;
1473         }
1474
1475       if (gfc_match_eos () != MATCH_YES)
1476         goto syntax;
1477     }
1478
1479   if (gfc_pure (NULL))
1480     {
1481       gfc_error ("%s statement not allowed in PURE procedure at %C",
1482                  gfc_ascii_statement (st));
1483       goto cleanup;
1484     }
1485
1486   new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1487   new_st.expr = e;
1488   new_st.ext.stop_code = stop_code;
1489
1490   return MATCH_YES;
1491
1492 syntax:
1493   gfc_syntax_error (st);
1494
1495 cleanup:
1496
1497   gfc_free_expr (e);
1498   return MATCH_ERROR;
1499 }
1500
1501 /* Match the (deprecated) PAUSE statement.  */
1502
1503 match
1504 gfc_match_pause (void)
1505 {
1506   match m;
1507
1508   m = gfc_match_stopcode (ST_PAUSE);
1509   if (m == MATCH_YES)
1510     {
1511       if (gfc_notify_std (GFC_STD_F95_DEL,
1512             "Obsolete: PAUSE statement at %C")
1513           == FAILURE)
1514         m = MATCH_ERROR;
1515     }
1516   return m;
1517 }
1518
1519
1520 /* Match the STOP statement.  */
1521
1522 match
1523 gfc_match_stop (void)
1524 {
1525   return gfc_match_stopcode (ST_STOP);
1526 }
1527
1528
1529 /* Match a CONTINUE statement.  */
1530
1531 match
1532 gfc_match_continue (void)
1533 {
1534
1535   if (gfc_match_eos () != MATCH_YES)
1536     {
1537       gfc_syntax_error (ST_CONTINUE);
1538       return MATCH_ERROR;
1539     }
1540
1541   new_st.op = EXEC_CONTINUE;
1542   return MATCH_YES;
1543 }
1544
1545
1546 /* Match the (deprecated) ASSIGN statement.  */
1547
1548 match
1549 gfc_match_assign (void)
1550 {
1551   gfc_expr *expr;
1552   gfc_st_label *label;
1553
1554   if (gfc_match (" %l", &label) == MATCH_YES)
1555     {
1556       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
1557         return MATCH_ERROR;
1558       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
1559         {
1560           if (gfc_notify_std (GFC_STD_F95_DEL,
1561                 "Obsolete: ASSIGN statement at %C")
1562               == FAILURE)
1563             return MATCH_ERROR;
1564
1565           expr->symtree->n.sym->attr.assign = 1;
1566
1567           new_st.op = EXEC_LABEL_ASSIGN;
1568           new_st.label = label;
1569           new_st.expr = expr;
1570           return MATCH_YES;
1571         }
1572     }
1573   return MATCH_NO;
1574 }
1575
1576
1577 /* Match the GO TO statement.  As a computed GOTO statement is
1578    matched, it is transformed into an equivalent SELECT block.  No
1579    tree is necessary, and the resulting jumps-to-jumps are
1580    specifically optimized away by the back end.  */
1581
1582 match
1583 gfc_match_goto (void)
1584 {
1585   gfc_code *head, *tail;
1586   gfc_expr *expr;
1587   gfc_case *cp;
1588   gfc_st_label *label;
1589   int i;
1590   match m;
1591
1592   if (gfc_match (" %l%t", &label) == MATCH_YES)
1593     {
1594       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1595         return MATCH_ERROR;
1596
1597       new_st.op = EXEC_GOTO;
1598       new_st.label = label;
1599       return MATCH_YES;
1600     }
1601
1602   /* The assigned GO TO statement.  */
1603
1604   if (gfc_match_variable (&expr, 0) == MATCH_YES)
1605     {
1606       if (gfc_notify_std (GFC_STD_F95_DEL,
1607                           "Obsolete: Assigned GOTO statement at %C")
1608           == FAILURE)
1609         return MATCH_ERROR;
1610
1611       new_st.op = EXEC_GOTO;
1612       new_st.expr = expr;
1613
1614       if (gfc_match_eos () == MATCH_YES)
1615         return MATCH_YES;
1616
1617       /* Match label list.  */
1618       gfc_match_char (',');
1619       if (gfc_match_char ('(') != MATCH_YES)
1620         {
1621           gfc_syntax_error (ST_GOTO);
1622           return MATCH_ERROR;
1623         }
1624       head = tail = NULL;
1625
1626       do
1627         {
1628           m = gfc_match_st_label (&label);
1629           if (m != MATCH_YES)
1630             goto syntax;
1631
1632           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1633             goto cleanup;
1634
1635           if (head == NULL)
1636             head = tail = gfc_get_code ();
1637           else
1638             {
1639               tail->block = gfc_get_code ();
1640               tail = tail->block;
1641             }
1642
1643           tail->label = label;
1644           tail->op = EXEC_GOTO;
1645         }
1646       while (gfc_match_char (',') == MATCH_YES);
1647
1648       if (gfc_match (")%t") != MATCH_YES)
1649         goto syntax;
1650
1651       if (head == NULL)
1652         {
1653            gfc_error (
1654                "Statement label list in GOTO at %C cannot be empty");
1655            goto syntax;
1656         }
1657       new_st.block = head;
1658
1659       return MATCH_YES;
1660     }
1661
1662   /* Last chance is a computed GO TO statement.  */
1663   if (gfc_match_char ('(') != MATCH_YES)
1664     {
1665       gfc_syntax_error (ST_GOTO);
1666       return MATCH_ERROR;
1667     }
1668
1669   head = tail = NULL;
1670   i = 1;
1671
1672   do
1673     {
1674       m = gfc_match_st_label (&label);
1675       if (m != MATCH_YES)
1676         goto syntax;
1677
1678       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1679         goto cleanup;
1680
1681       if (head == NULL)
1682         head = tail = gfc_get_code ();
1683       else
1684         {
1685           tail->block = gfc_get_code ();
1686           tail = tail->block;
1687         }
1688
1689       cp = gfc_get_case ();
1690       cp->low = cp->high = gfc_int_expr (i++);
1691
1692       tail->op = EXEC_SELECT;
1693       tail->ext.case_list = cp;
1694
1695       tail->next = gfc_get_code ();
1696       tail->next->op = EXEC_GOTO;
1697       tail->next->label = label;
1698     }
1699   while (gfc_match_char (',') == MATCH_YES);
1700
1701   if (gfc_match_char (')') != MATCH_YES)
1702     goto syntax;
1703
1704   if (head == NULL)
1705     {
1706       gfc_error ("Statement label list in GOTO at %C cannot be empty");
1707       goto syntax;
1708     }
1709
1710   /* Get the rest of the statement.  */
1711   gfc_match_char (',');
1712
1713   if (gfc_match (" %e%t", &expr) != MATCH_YES)
1714     goto syntax;
1715
1716   /* At this point, a computed GOTO has been fully matched and an
1717      equivalent SELECT statement constructed.  */
1718
1719   new_st.op = EXEC_SELECT;
1720   new_st.expr = NULL;
1721
1722   /* Hack: For a "real" SELECT, the expression is in expr. We put
1723      it in expr2 so we can distinguish then and produce the correct
1724      diagnostics.  */
1725   new_st.expr2 = expr;
1726   new_st.block = head;
1727   return MATCH_YES;
1728
1729 syntax:
1730   gfc_syntax_error (ST_GOTO);
1731 cleanup:
1732   gfc_free_statements (head);
1733   return MATCH_ERROR;
1734 }
1735
1736
1737 /* Frees a list of gfc_alloc structures.  */
1738
1739 void
1740 gfc_free_alloc_list (gfc_alloc * p)
1741 {
1742   gfc_alloc *q;
1743
1744   for (; p; p = q)
1745     {
1746       q = p->next;
1747       gfc_free_expr (p->expr);
1748       gfc_free (p);
1749     }
1750 }
1751
1752
1753 /* Match an ALLOCATE statement.  */
1754
1755 match
1756 gfc_match_allocate (void)
1757 {
1758   gfc_alloc *head, *tail;
1759   gfc_expr *stat;
1760   match m;
1761
1762   head = tail = NULL;
1763   stat = NULL;
1764
1765   if (gfc_match_char ('(') != MATCH_YES)
1766     goto syntax;
1767
1768   for (;;)
1769     {
1770       if (head == NULL)
1771         head = tail = gfc_get_alloc ();
1772       else
1773         {
1774           tail->next = gfc_get_alloc ();
1775           tail = tail->next;
1776         }
1777
1778       m = gfc_match_variable (&tail->expr, 0);
1779       if (m == MATCH_NO)
1780         goto syntax;
1781       if (m == MATCH_ERROR)
1782         goto cleanup;
1783
1784       if (gfc_check_do_variable (tail->expr->symtree))
1785         goto cleanup;
1786
1787       if (gfc_pure (NULL)
1788           && gfc_impure_variable (tail->expr->symtree->n.sym))
1789         {
1790           gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1791                      "PURE procedure");
1792           goto cleanup;
1793         }
1794
1795       if (gfc_match_char (',') != MATCH_YES)
1796         break;
1797
1798       m = gfc_match (" stat = %v", &stat);
1799       if (m == MATCH_ERROR)
1800         goto cleanup;
1801       if (m == MATCH_YES)
1802         break;
1803     }
1804
1805   if (stat != NULL)
1806     {
1807       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1808         {
1809           gfc_error
1810             ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1811              "INTENT(IN)", stat->symtree->n.sym->name);
1812           goto cleanup;
1813         }
1814
1815       if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
1816         {
1817           gfc_error
1818             ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1819              "procedure");
1820           goto cleanup;
1821         }
1822
1823       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1824         {
1825           gfc_error("STAT expression at %C must be a variable");
1826           goto cleanup;
1827         }
1828
1829       gfc_check_do_variable(stat->symtree);
1830     }
1831
1832   if (gfc_match (" )%t") != MATCH_YES)
1833     goto syntax;
1834
1835   new_st.op = EXEC_ALLOCATE;
1836   new_st.expr = stat;
1837   new_st.ext.alloc_list = head;
1838
1839   return MATCH_YES;
1840
1841 syntax:
1842   gfc_syntax_error (ST_ALLOCATE);
1843
1844 cleanup:
1845   gfc_free_expr (stat);
1846   gfc_free_alloc_list (head);
1847   return MATCH_ERROR;
1848 }
1849
1850
1851 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1852    a set of pointer assignments to intrinsic NULL().  */
1853
1854 match
1855 gfc_match_nullify (void)
1856 {
1857   gfc_code *tail;
1858   gfc_expr *e, *p;
1859   match m;
1860
1861   tail = NULL;
1862
1863   if (gfc_match_char ('(') != MATCH_YES)
1864     goto syntax;
1865
1866   for (;;)
1867     {
1868       m = gfc_match_variable (&p, 0);
1869       if (m == MATCH_ERROR)
1870         goto cleanup;
1871       if (m == MATCH_NO)
1872         goto syntax;
1873
1874       if (gfc_check_do_variable(p->symtree))
1875         goto cleanup;
1876
1877       if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
1878         {
1879           gfc_error
1880             ("Illegal variable in NULLIFY at %C for a PURE procedure");
1881           goto cleanup;
1882         }
1883
1884       /* build ' => NULL() ' */
1885       e = gfc_get_expr ();
1886       e->where = gfc_current_locus;
1887       e->expr_type = EXPR_NULL;
1888       e->ts.type = BT_UNKNOWN;
1889
1890       /* Chain to list */
1891       if (tail == NULL)
1892         tail = &new_st;
1893       else
1894         {
1895           tail->next = gfc_get_code ();
1896           tail = tail->next;
1897         }
1898
1899       tail->op = EXEC_POINTER_ASSIGN;
1900       tail->expr = p;
1901       tail->expr2 = e;
1902
1903       if (gfc_match (" )%t") == MATCH_YES)
1904         break;
1905       if (gfc_match_char (',') != MATCH_YES)
1906         goto syntax;
1907     }
1908
1909   return MATCH_YES;
1910
1911 syntax:
1912   gfc_syntax_error (ST_NULLIFY);
1913
1914 cleanup:
1915   gfc_free_statements (new_st.next);
1916   return MATCH_ERROR;
1917 }
1918
1919
1920 /* Match a DEALLOCATE statement.  */
1921
1922 match
1923 gfc_match_deallocate (void)
1924 {
1925   gfc_alloc *head, *tail;
1926   gfc_expr *stat;
1927   match m;
1928
1929   head = tail = NULL;
1930   stat = NULL;
1931
1932   if (gfc_match_char ('(') != MATCH_YES)
1933     goto syntax;
1934
1935   for (;;)
1936     {
1937       if (head == NULL)
1938         head = tail = gfc_get_alloc ();
1939       else
1940         {
1941           tail->next = gfc_get_alloc ();
1942           tail = tail->next;
1943         }
1944
1945       m = gfc_match_variable (&tail->expr, 0);
1946       if (m == MATCH_ERROR)
1947         goto cleanup;
1948       if (m == MATCH_NO)
1949         goto syntax;
1950
1951       if (gfc_check_do_variable (tail->expr->symtree))
1952         goto cleanup;
1953
1954       if (gfc_pure (NULL)
1955           && gfc_impure_variable (tail->expr->symtree->n.sym))
1956         {
1957           gfc_error
1958             ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
1959              "procedure");
1960           goto cleanup;
1961         }
1962
1963       if (gfc_match_char (',') != MATCH_YES)
1964         break;
1965
1966       m = gfc_match (" stat = %v", &stat);
1967       if (m == MATCH_ERROR)
1968         goto cleanup;
1969       if (m == MATCH_YES)
1970         break;
1971     }
1972
1973   if (stat != NULL)
1974     {
1975       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1976         {
1977           gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
1978                      "cannot be INTENT(IN)", stat->symtree->n.sym->name);
1979           goto cleanup;
1980         }
1981
1982       if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
1983         {
1984           gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
1985                      "for a PURE procedure");
1986           goto cleanup;
1987         }
1988
1989       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1990         {
1991           gfc_error("STAT expression at %C must be a variable");
1992           goto cleanup;
1993         }
1994
1995       gfc_check_do_variable(stat->symtree);
1996     }
1997
1998   if (gfc_match (" )%t") != MATCH_YES)
1999     goto syntax;
2000
2001   new_st.op = EXEC_DEALLOCATE;
2002   new_st.expr = stat;
2003   new_st.ext.alloc_list = head;
2004
2005   return MATCH_YES;
2006
2007 syntax:
2008   gfc_syntax_error (ST_DEALLOCATE);
2009
2010 cleanup:
2011   gfc_free_expr (stat);
2012   gfc_free_alloc_list (head);
2013   return MATCH_ERROR;
2014 }
2015
2016
2017 /* Match a RETURN statement.  */
2018
2019 match
2020 gfc_match_return (void)
2021 {
2022   gfc_expr *e;
2023   match m;
2024   gfc_compile_state s;
2025   int c;
2026
2027   e = NULL;
2028   if (gfc_match_eos () == MATCH_YES)
2029     goto done;
2030
2031   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2032     {
2033       gfc_error ("Alternate RETURN statement at %C is only allowed within "
2034                  "a SUBROUTINE");
2035       goto cleanup;
2036     }
2037
2038   if (gfc_current_form == FORM_FREE)
2039     {
2040       /* The following are valid, so we can't require a blank after the
2041         RETURN keyword:
2042           return+1
2043           return(1)  */
2044       c = gfc_peek_char ();
2045       if (ISALPHA (c) || ISDIGIT (c))
2046        return MATCH_NO;
2047     }
2048
2049   m = gfc_match (" %e%t", &e);
2050   if (m == MATCH_YES)
2051     goto done;
2052   if (m == MATCH_ERROR)
2053     goto cleanup;
2054
2055   gfc_syntax_error (ST_RETURN);
2056
2057 cleanup:
2058   gfc_free_expr (e);
2059   return MATCH_ERROR;
2060
2061 done:
2062   gfc_enclosing_unit (&s);
2063   if (s == COMP_PROGRAM
2064       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2065                         "main program at %C") == FAILURE)
2066       return MATCH_ERROR;
2067
2068   new_st.op = EXEC_RETURN;
2069   new_st.expr = e;
2070
2071   return MATCH_YES;
2072 }
2073
2074
2075 /* Match a CALL statement.  The tricky part here are possible
2076    alternate return specifiers.  We handle these by having all
2077    "subroutines" actually return an integer via a register that gives
2078    the return number.  If the call specifies alternate returns, we
2079    generate code for a SELECT statement whose case clauses contain
2080    GOTOs to the various labels.  */
2081
2082 match
2083 gfc_match_call (void)
2084 {
2085   char name[GFC_MAX_SYMBOL_LEN + 1];
2086   gfc_actual_arglist *a, *arglist;
2087   gfc_case *new_case;
2088   gfc_symbol *sym;
2089   gfc_symtree *st;
2090   gfc_code *c;
2091   match m;
2092   int i;
2093
2094   arglist = NULL;
2095
2096   m = gfc_match ("% %n", name);
2097   if (m == MATCH_NO)
2098     goto syntax;
2099   if (m != MATCH_YES)
2100     return m;
2101
2102   if (gfc_get_ha_sym_tree (name, &st))
2103     return MATCH_ERROR;
2104
2105   sym = st->n.sym;
2106   gfc_set_sym_referenced (sym);
2107
2108   if (!sym->attr.generic
2109       && !sym->attr.subroutine
2110       && gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2111     return MATCH_ERROR;
2112
2113   if (gfc_match_eos () != MATCH_YES)
2114     {
2115       m = gfc_match_actual_arglist (1, &arglist);
2116       if (m == MATCH_NO)
2117         goto syntax;
2118       if (m == MATCH_ERROR)
2119         goto cleanup;
2120
2121       if (gfc_match_eos () != MATCH_YES)
2122         goto syntax;
2123     }
2124
2125   /* If any alternate return labels were found, construct a SELECT
2126      statement that will jump to the right place.  */
2127
2128   i = 0;
2129   for (a = arglist; a; a = a->next)
2130     if (a->expr == NULL)
2131         i = 1;
2132
2133   if (i)
2134     {
2135       gfc_symtree *select_st;
2136       gfc_symbol *select_sym;
2137       char name[GFC_MAX_SYMBOL_LEN + 1];
2138
2139       new_st.next = c = gfc_get_code ();
2140       c->op = EXEC_SELECT;
2141       sprintf (name, "_result_%s",sym->name);
2142       gfc_get_ha_sym_tree (name, &select_st);  /* Can't fail */
2143
2144       select_sym = select_st->n.sym;
2145       select_sym->ts.type = BT_INTEGER;
2146       select_sym->ts.kind = gfc_default_integer_kind;
2147       gfc_set_sym_referenced (select_sym);
2148       c->expr = gfc_get_expr ();
2149       c->expr->expr_type = EXPR_VARIABLE;
2150       c->expr->symtree = select_st;
2151       c->expr->ts = select_sym->ts;
2152       c->expr->where = gfc_current_locus;
2153
2154       i = 0;
2155       for (a = arglist; a; a = a->next)
2156         {
2157           if (a->expr != NULL)
2158             continue;
2159
2160           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2161             continue;
2162
2163           i++;
2164
2165           c->block = gfc_get_code ();
2166           c = c->block;
2167           c->op = EXEC_SELECT;
2168
2169           new_case = gfc_get_case ();
2170           new_case->high = new_case->low = gfc_int_expr (i);
2171           c->ext.case_list = new_case;
2172
2173           c->next = gfc_get_code ();
2174           c->next->op = EXEC_GOTO;
2175           c->next->label = a->label;
2176         }
2177     }
2178
2179   new_st.op = EXEC_CALL;
2180   new_st.symtree = st;
2181   new_st.ext.actual = arglist;
2182
2183   return MATCH_YES;
2184
2185 syntax:
2186   gfc_syntax_error (ST_CALL);
2187
2188 cleanup:
2189   gfc_free_actual_arglist (arglist);
2190   return MATCH_ERROR;
2191 }
2192
2193
2194 /* Given a name, return a pointer to the common head structure,
2195    creating it if it does not exist. If FROM_MODULE is nonzero, we
2196    mangle the name so that it doesn't interfere with commons defined
2197    in the using namespace.
2198    TODO: Add to global symbol tree.  */
2199
2200 gfc_common_head *
2201 gfc_get_common (const char *name, int from_module)
2202 {
2203   gfc_symtree *st;
2204   static int serial = 0;
2205   char mangled_name[GFC_MAX_SYMBOL_LEN+1];
2206
2207   if (from_module)
2208     {
2209       /* A use associated common block is only needed to correctly layout
2210          the variables it contains.  */
2211       snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2212       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2213     }
2214   else
2215     {
2216       st = gfc_find_symtree (gfc_current_ns->common_root, name);
2217
2218       if (st == NULL)
2219         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2220     }
2221
2222   if (st->n.common == NULL)
2223     {
2224       st->n.common = gfc_get_common_head ();
2225       st->n.common->where = gfc_current_locus;
2226       strcpy (st->n.common->name, name);
2227     }
2228
2229   return st->n.common;
2230 }
2231
2232
2233 /* Match a common block name.  */
2234
2235 static match
2236 match_common_name (char *name)
2237 {
2238   match m;
2239
2240   if (gfc_match_char ('/') == MATCH_NO)
2241     {
2242       name[0] = '\0';
2243       return MATCH_YES;
2244     }
2245
2246   if (gfc_match_char ('/') == MATCH_YES)
2247     {
2248       name[0] = '\0';
2249       return MATCH_YES;
2250     }
2251
2252   m = gfc_match_name (name);
2253
2254   if (m == MATCH_ERROR)
2255     return MATCH_ERROR;
2256   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2257     return MATCH_YES;
2258
2259   gfc_error ("Syntax error in common block name at %C");
2260   return MATCH_ERROR;
2261 }
2262
2263
2264 /* Match a COMMON statement.  */
2265
2266 match
2267 gfc_match_common (void)
2268 {
2269   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2270   char name[GFC_MAX_SYMBOL_LEN+1];
2271   gfc_common_head *t;
2272   gfc_array_spec *as;
2273   gfc_equiv * e1, * e2;
2274   match m;
2275   gfc_gsymbol *gsym;
2276
2277   old_blank_common = gfc_current_ns->blank_common.head;
2278   if (old_blank_common)
2279     {
2280       while (old_blank_common->common_next)
2281         old_blank_common = old_blank_common->common_next;
2282     }
2283
2284   as = NULL;
2285
2286   for (;;)
2287     {
2288       m = match_common_name (name);
2289       if (m == MATCH_ERROR)
2290         goto cleanup;
2291
2292       gsym = gfc_get_gsymbol (name);
2293       if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
2294         {
2295           gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON",
2296                      sym->name);
2297           goto cleanup;
2298         }
2299
2300       if (gsym->type == GSYM_UNKNOWN)
2301         {
2302           gsym->type = GSYM_COMMON;
2303           gsym->where = gfc_current_locus;
2304           gsym->defined = 1;
2305         }
2306
2307       gsym->used = 1;
2308
2309       if (name[0] == '\0')
2310         {
2311           t = &gfc_current_ns->blank_common;
2312           if (t->head == NULL)
2313             t->where = gfc_current_locus;
2314           head = &t->head;
2315         }
2316       else
2317         {
2318           t = gfc_get_common (name, 0);
2319           head = &t->head;
2320         }
2321
2322       if (*head == NULL)
2323         tail = NULL;
2324       else
2325         {
2326           tail = *head;
2327           while (tail->common_next)
2328             tail = tail->common_next;
2329         }
2330
2331       /* Grab the list of symbols.  */
2332       for (;;)
2333         {
2334           m = gfc_match_symbol (&sym, 0);
2335           if (m == MATCH_ERROR)
2336             goto cleanup;
2337           if (m == MATCH_NO)
2338             goto syntax;
2339
2340           if (sym->attr.in_common)
2341             {
2342               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2343                          sym->name);
2344               goto cleanup;
2345             }
2346
2347           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2348             goto cleanup;
2349
2350           if (sym->value != NULL
2351               && (name[0] == '\0' || !sym->attr.data))
2352             {
2353               if (name[0] == '\0')
2354                 gfc_error ("Previously initialized symbol '%s' in "
2355                            "blank COMMON block at %C", sym->name);
2356               else
2357                 gfc_error ("Previously initialized symbol '%s' in "
2358                            "COMMON block '%s' at %C", sym->name, name);
2359               goto cleanup;
2360             }
2361
2362           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2363             goto cleanup;
2364
2365           /* Derived type names must have the SEQUENCE attribute.  */
2366           if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2367             {
2368               gfc_error
2369                 ("Derived type variable in COMMON at %C does not have the "
2370                  "SEQUENCE attribute");
2371               goto cleanup;
2372             }
2373
2374           if (tail != NULL)
2375             tail->common_next = sym;
2376           else
2377             *head = sym;
2378
2379           tail = sym;
2380
2381           /* Deal with an optional array specification after the
2382              symbol name.  */
2383           m = gfc_match_array_spec (&as);
2384           if (m == MATCH_ERROR)
2385             goto cleanup;
2386
2387           if (m == MATCH_YES)
2388             {
2389               if (as->type != AS_EXPLICIT)
2390                 {
2391                   gfc_error
2392                     ("Array specification for symbol '%s' in COMMON at %C "
2393                      "must be explicit", sym->name);
2394                   goto cleanup;
2395                 }
2396
2397               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2398                 goto cleanup;
2399
2400               if (sym->attr.pointer)
2401                 {
2402                   gfc_error
2403                     ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2404                      sym->name);
2405                   goto cleanup;
2406                 }
2407
2408               sym->as = as;
2409               as = NULL;
2410
2411             }
2412
2413           sym->common_head = t;
2414
2415           /* Check to see if the symbol is already in an equivalence group.
2416              If it is, set the other members as being in common.  */
2417           if (sym->attr.in_equivalence)
2418             {
2419               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2420                 {
2421                   for (e2 = e1; e2; e2 = e2->eq)
2422                     if (e2->expr->symtree->n.sym == sym)
2423                       goto equiv_found;
2424
2425                   continue;
2426
2427           equiv_found:
2428
2429                   for (e2 = e1; e2; e2 = e2->eq)
2430                     {
2431                       other = e2->expr->symtree->n.sym;
2432                       if (other->common_head
2433                             && other->common_head != sym->common_head)
2434                         {
2435                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
2436                                      "%C is being indirectly equivalenced to "
2437                                      "another COMMON block '%s'",
2438                                      sym->name,
2439                                      sym->common_head->name,
2440                                      other->common_head->name);
2441                             goto cleanup;
2442                         }
2443                       other->attr.in_common = 1;
2444                       other->common_head = t;
2445                     }
2446                 }
2447             }
2448
2449
2450           gfc_gobble_whitespace ();
2451           if (gfc_match_eos () == MATCH_YES)
2452             goto done;
2453           if (gfc_peek_char () == '/')
2454             break;
2455           if (gfc_match_char (',') != MATCH_YES)
2456             goto syntax;
2457           gfc_gobble_whitespace ();
2458           if (gfc_peek_char () == '/')
2459             break;
2460         }
2461     }
2462
2463 done:
2464   return MATCH_YES;
2465
2466 syntax:
2467   gfc_syntax_error (ST_COMMON);
2468
2469 cleanup:
2470   if (old_blank_common)
2471     old_blank_common->common_next = NULL;
2472   else
2473     gfc_current_ns->blank_common.head = NULL;
2474   gfc_free_array_spec (as);
2475   return MATCH_ERROR;
2476 }
2477
2478
2479 /* Match a BLOCK DATA program unit.  */
2480
2481 match
2482 gfc_match_block_data (void)
2483 {
2484   char name[GFC_MAX_SYMBOL_LEN + 1];
2485   gfc_symbol *sym;
2486   match m;
2487
2488   if (gfc_match_eos () == MATCH_YES)
2489     {
2490       gfc_new_block = NULL;
2491       return MATCH_YES;
2492     }
2493
2494   m = gfc_match ("% %n%t", name);
2495   if (m != MATCH_YES)
2496     return MATCH_ERROR;
2497
2498   if (gfc_get_symbol (name, NULL, &sym))
2499     return MATCH_ERROR;
2500
2501   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2502     return MATCH_ERROR;
2503
2504   gfc_new_block = sym;
2505
2506   return MATCH_YES;
2507 }
2508
2509
2510 /* Free a namelist structure.  */
2511
2512 void
2513 gfc_free_namelist (gfc_namelist * name)
2514 {
2515   gfc_namelist *n;
2516
2517   for (; name; name = n)
2518     {
2519       n = name->next;
2520       gfc_free (name);
2521     }
2522 }
2523
2524
2525 /* Match a NAMELIST statement.  */
2526
2527 match
2528 gfc_match_namelist (void)
2529 {
2530   gfc_symbol *group_name, *sym;
2531   gfc_namelist *nl;
2532   match m, m2;
2533
2534   m = gfc_match (" / %s /", &group_name);
2535   if (m == MATCH_NO)
2536     goto syntax;
2537   if (m == MATCH_ERROR)
2538     goto error;
2539
2540   for (;;)
2541     {
2542       if (group_name->ts.type != BT_UNKNOWN)
2543         {
2544           gfc_error
2545             ("Namelist group name '%s' at %C already has a basic type "
2546              "of %s", group_name->name, gfc_typename (&group_name->ts));
2547           return MATCH_ERROR;
2548         }
2549
2550       if (group_name->attr.flavor == FL_NAMELIST
2551             && group_name->attr.use_assoc
2552             && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
2553                                "at %C already is USE associated and can"
2554                                "not be respecified.", group_name->name)
2555                  == FAILURE)
2556         return MATCH_ERROR;
2557
2558       if (group_name->attr.flavor != FL_NAMELIST
2559           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2560                              group_name->name, NULL) == FAILURE)
2561         return MATCH_ERROR;
2562
2563       for (;;)
2564         {
2565           m = gfc_match_symbol (&sym, 1);
2566           if (m == MATCH_NO)
2567             goto syntax;
2568           if (m == MATCH_ERROR)
2569             goto error;
2570
2571           if (sym->attr.in_namelist == 0
2572               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
2573             goto error;
2574
2575           /* Use gfc_error_check here, rather than goto error, so that this
2576              these are the only errors for the next two lines.  */
2577           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
2578             {
2579               gfc_error ("Assumed size array '%s' in namelist '%s'at "
2580                          "%C is not allowed.", sym->name, group_name->name);
2581               gfc_error_check ();
2582             }
2583
2584           if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
2585                 && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
2586                                    "namelist '%s' at %C is an extension.",
2587                                    sym->name, group_name->name) == FAILURE)
2588             gfc_error_check ();
2589
2590           nl = gfc_get_namelist ();
2591           nl->sym = sym;
2592
2593           if (group_name->namelist == NULL)
2594             group_name->namelist = group_name->namelist_tail = nl;
2595           else
2596             {
2597               group_name->namelist_tail->next = nl;
2598               group_name->namelist_tail = nl;
2599             }
2600
2601           if (gfc_match_eos () == MATCH_YES)
2602             goto done;
2603
2604           m = gfc_match_char (',');
2605
2606           if (gfc_match_char ('/') == MATCH_YES)
2607             {
2608               m2 = gfc_match (" %s /", &group_name);
2609               if (m2 == MATCH_YES)
2610                 break;
2611               if (m2 == MATCH_ERROR)
2612                 goto error;
2613               goto syntax;
2614             }
2615
2616           if (m != MATCH_YES)
2617             goto syntax;
2618         }
2619     }
2620
2621 done:
2622   return MATCH_YES;
2623
2624 syntax:
2625   gfc_syntax_error (ST_NAMELIST);
2626
2627 error:
2628   return MATCH_ERROR;
2629 }
2630
2631
2632 /* Match a MODULE statement.  */
2633
2634 match
2635 gfc_match_module (void)
2636 {
2637   match m;
2638
2639   m = gfc_match (" %s%t", &gfc_new_block);
2640   if (m != MATCH_YES)
2641     return m;
2642
2643   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2644                       gfc_new_block->name, NULL) == FAILURE)
2645     return MATCH_ERROR;
2646
2647   return MATCH_YES;
2648 }
2649
2650
2651 /* Free equivalence sets and lists.  Recursively is the easiest way to
2652    do this.  */
2653
2654 void
2655 gfc_free_equiv (gfc_equiv * eq)
2656 {
2657
2658   if (eq == NULL)
2659     return;
2660
2661   gfc_free_equiv (eq->eq);
2662   gfc_free_equiv (eq->next);
2663
2664   gfc_free_expr (eq->expr);
2665   gfc_free (eq);
2666 }
2667
2668
2669 /* Match an EQUIVALENCE statement.  */
2670
2671 match
2672 gfc_match_equivalence (void)
2673 {
2674   gfc_equiv *eq, *set, *tail;
2675   gfc_ref *ref;
2676   gfc_symbol *sym;
2677   match m;
2678   gfc_common_head *common_head = NULL;
2679   bool common_flag;
2680   int cnt;
2681
2682   tail = NULL;
2683
2684   for (;;)
2685     {
2686       eq = gfc_get_equiv ();
2687       if (tail == NULL)
2688         tail = eq;
2689
2690       eq->next = gfc_current_ns->equiv;
2691       gfc_current_ns->equiv = eq;
2692
2693       if (gfc_match_char ('(') != MATCH_YES)
2694         goto syntax;
2695
2696       set = eq;
2697       common_flag = FALSE;
2698       cnt = 0;
2699
2700       for (;;)
2701         {
2702           m = gfc_match_equiv_variable (&set->expr);
2703           if (m == MATCH_ERROR)
2704             goto cleanup;
2705           if (m == MATCH_NO)
2706             goto syntax;
2707
2708           /*  count the number of objects.  */
2709           cnt++;
2710
2711           if (gfc_match_char ('%') == MATCH_YES)
2712             {
2713               gfc_error ("Derived type component %C is not a "
2714                          "permitted EQUIVALENCE member");
2715               goto cleanup;
2716             }
2717
2718           for (ref = set->expr->ref; ref; ref = ref->next)
2719             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2720               {
2721                 gfc_error
2722                   ("Array reference in EQUIVALENCE at %C cannot be an "
2723                    "array section");
2724                 goto cleanup;
2725               }
2726
2727           sym = set->expr->symtree->n.sym;
2728
2729           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL)
2730                 == FAILURE)
2731             goto cleanup;
2732
2733           if (sym->attr.in_common)
2734             {
2735               common_flag = TRUE;
2736               common_head = sym->common_head;
2737             }
2738
2739           if (gfc_match_char (')') == MATCH_YES)
2740             break;
2741
2742           if (gfc_match_char (',') != MATCH_YES)
2743             goto syntax;
2744
2745           set->eq = gfc_get_equiv ();
2746           set = set->eq;
2747         }
2748
2749       if (cnt < 2)
2750         {
2751           gfc_error ("EQUIVALENCE at %C requires two or more objects");
2752           goto cleanup;
2753         }
2754
2755       /* If one of the members of an equivalence is in common, then
2756          mark them all as being in common.  Before doing this, check
2757          that members of the equivalence group are not in different
2758          common blocks. */
2759       if (common_flag)
2760         for (set = eq; set; set = set->eq)
2761           {
2762             sym = set->expr->symtree->n.sym;
2763             if (sym->common_head && sym->common_head != common_head)
2764               {
2765                 gfc_error ("Attempt to indirectly overlap COMMON "
2766                            "blocks %s and %s by EQUIVALENCE at %C",
2767                            sym->common_head->name,
2768                            common_head->name);
2769                 goto cleanup;
2770               }
2771             sym->attr.in_common = 1;
2772             sym->common_head = common_head;
2773           }
2774
2775       if (gfc_match_eos () == MATCH_YES)
2776         break;
2777       if (gfc_match_char (',') != MATCH_YES)
2778         goto syntax;
2779     }
2780
2781   return MATCH_YES;
2782
2783 syntax:
2784   gfc_syntax_error (ST_EQUIVALENCE);
2785
2786 cleanup:
2787   eq = tail->next;
2788   tail->next = NULL;
2789
2790   gfc_free_equiv (gfc_current_ns->equiv);
2791   gfc_current_ns->equiv = eq;
2792
2793   return MATCH_ERROR;
2794 }
2795
2796 /* Check that a statement function is not recursive. This is done by looking
2797    for the statement function symbol(sym) by looking recursively through its
2798    expression(e).  If a reference to sym is found, true is returned.  */
2799 static bool
2800 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
2801 {
2802   gfc_actual_arglist *arg;
2803   gfc_ref *ref;
2804   int i;
2805
2806   if (e == NULL)
2807     return false;
2808
2809   switch (e->expr_type)
2810     {
2811     case EXPR_FUNCTION:
2812       for (arg = e->value.function.actual; arg; arg = arg->next)
2813         {
2814           if (sym->name == arg->name
2815                 || recursive_stmt_fcn (arg->expr, sym))
2816             return true;
2817         }
2818
2819       if (e->symtree == NULL)
2820         return false;
2821
2822       /* Check the name before testing for nested recursion!  */
2823       if (sym->name == e->symtree->n.sym->name)
2824         return true;
2825
2826       /* Catch recursion via other statement functions.  */
2827       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
2828             && e->symtree->n.sym->value
2829             && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
2830         return true;
2831
2832       break;
2833
2834     case EXPR_VARIABLE:
2835       if (e->symtree && sym->name == e->symtree->n.sym->name)
2836         return true;
2837       break;
2838
2839     case EXPR_OP:
2840       if (recursive_stmt_fcn (e->value.op.op1, sym)
2841             || recursive_stmt_fcn (e->value.op.op2, sym))
2842         return true;
2843       break;
2844
2845     default:
2846       break;
2847     }
2848
2849   /* Component references do not need to be checked.  */
2850   if (e->ref)
2851     {
2852       for (ref = e->ref; ref; ref = ref->next)
2853         {
2854           switch (ref->type)
2855             {
2856             case REF_ARRAY:
2857               for (i = 0; i < ref->u.ar.dimen; i++)
2858                 {
2859                   if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
2860                         || recursive_stmt_fcn (ref->u.ar.end[i], sym)
2861                         || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
2862                     return true;
2863                 }
2864               break;
2865
2866             case REF_SUBSTRING:
2867               if (recursive_stmt_fcn (ref->u.ss.start, sym)
2868                     || recursive_stmt_fcn (ref->u.ss.end, sym))
2869                 return true;
2870
2871               break;
2872
2873             default:
2874               break;
2875             }
2876         }
2877     }
2878   return false;
2879 }
2880
2881
2882 /* Match a statement function declaration.  It is so easy to match
2883    non-statement function statements with a MATCH_ERROR as opposed to
2884    MATCH_NO that we suppress error message in most cases.  */
2885
2886 match
2887 gfc_match_st_function (void)
2888 {
2889   gfc_error_buf old_error;
2890   gfc_symbol *sym;
2891   gfc_expr *expr;
2892   match m;
2893
2894   m = gfc_match_symbol (&sym, 0);
2895   if (m != MATCH_YES)
2896     return m;
2897
2898   gfc_push_error (&old_error);
2899
2900   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
2901                          sym->name, NULL) == FAILURE)
2902     goto undo_error;
2903
2904   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2905     goto undo_error;
2906
2907   m = gfc_match (" = %e%t", &expr);
2908   if (m == MATCH_NO)
2909     goto undo_error;
2910
2911   gfc_free_error (&old_error);
2912   if (m == MATCH_ERROR)
2913     return m;
2914
2915   if (recursive_stmt_fcn (expr, sym))
2916     {
2917       gfc_error ("Statement function at %L is recursive",
2918                  &expr->where);
2919       return MATCH_ERROR;
2920     }
2921
2922   sym->value = expr;
2923
2924   return MATCH_YES;
2925
2926 undo_error:
2927   gfc_pop_error (&old_error);
2928   return MATCH_NO;
2929 }
2930
2931
2932 /***************** SELECT CASE subroutines ******************/
2933
2934 /* Free a single case structure.  */
2935
2936 static void
2937 free_case (gfc_case * p)
2938 {
2939   if (p->low == p->high)
2940     p->high = NULL;
2941   gfc_free_expr (p->low);
2942   gfc_free_expr (p->high);
2943   gfc_free (p);
2944 }
2945
2946
2947 /* Free a list of case structures.  */
2948
2949 void
2950 gfc_free_case_list (gfc_case * p)
2951 {
2952   gfc_case *q;
2953
2954   for (; p; p = q)
2955     {
2956       q = p->next;
2957       free_case (p);
2958     }
2959 }
2960
2961
2962 /* Match a single case selector.  */
2963
2964 static match
2965 match_case_selector (gfc_case ** cp)
2966 {
2967   gfc_case *c;
2968   match m;
2969
2970   c = gfc_get_case ();
2971   c->where = gfc_current_locus;
2972
2973   if (gfc_match_char (':') == MATCH_YES)
2974     {
2975       m = gfc_match_init_expr (&c->high);
2976       if (m == MATCH_NO)
2977         goto need_expr;
2978       if (m == MATCH_ERROR)
2979         goto cleanup;
2980     }
2981
2982   else
2983     {
2984       m = gfc_match_init_expr (&c->low);
2985       if (m == MATCH_ERROR)
2986         goto cleanup;
2987       if (m == MATCH_NO)
2988         goto need_expr;
2989
2990       /* If we're not looking at a ':' now, make a range out of a single
2991          target.  Else get the upper bound for the case range.  */
2992       if (gfc_match_char (':') != MATCH_YES)
2993         c->high = c->low;
2994       else
2995         {
2996           m = gfc_match_init_expr (&c->high);
2997           if (m == MATCH_ERROR)
2998             goto cleanup;
2999           /* MATCH_NO is fine.  It's OK if nothing is there!  */
3000         }
3001     }
3002
3003   *cp = c;
3004   return MATCH_YES;
3005
3006 need_expr:
3007   gfc_error ("Expected initialization expression in CASE at %C");
3008
3009 cleanup:
3010   free_case (c);
3011   return MATCH_ERROR;
3012 }
3013
3014
3015 /* Match the end of a case statement.  */
3016
3017 static match
3018 match_case_eos (void)
3019 {
3020   char name[GFC_MAX_SYMBOL_LEN + 1];
3021   match m;
3022
3023   if (gfc_match_eos () == MATCH_YES)
3024     return MATCH_YES;
3025
3026   gfc_gobble_whitespace ();
3027
3028   m = gfc_match_name (name);
3029   if (m != MATCH_YES)
3030     return m;
3031
3032   if (strcmp (name, gfc_current_block ()->name) != 0)
3033     {
3034       gfc_error ("Expected case name of '%s' at %C",
3035                  gfc_current_block ()->name);
3036       return MATCH_ERROR;
3037     }
3038
3039   return gfc_match_eos ();
3040 }
3041
3042
3043 /* Match a SELECT statement.  */
3044
3045 match
3046 gfc_match_select (void)
3047 {
3048   gfc_expr *expr;
3049   match m;
3050
3051   m = gfc_match_label ();
3052   if (m == MATCH_ERROR)
3053     return m;
3054
3055   m = gfc_match (" select case ( %e )%t", &expr);
3056   if (m != MATCH_YES)
3057     return m;
3058
3059   new_st.op = EXEC_SELECT;
3060   new_st.expr = expr;
3061
3062   return MATCH_YES;
3063 }
3064
3065
3066 /* Match a CASE statement.  */
3067
3068 match
3069 gfc_match_case (void)
3070 {
3071   gfc_case *c, *head, *tail;
3072   match m;
3073
3074   head = tail = NULL;
3075
3076   if (gfc_current_state () != COMP_SELECT)
3077     {
3078       gfc_error ("Unexpected CASE statement at %C");
3079       return MATCH_ERROR;
3080     }
3081
3082   if (gfc_match ("% default") == MATCH_YES)
3083     {
3084       m = match_case_eos ();
3085       if (m == MATCH_NO)
3086         goto syntax;
3087       if (m == MATCH_ERROR)
3088         goto cleanup;
3089
3090       new_st.op = EXEC_SELECT;
3091       c = gfc_get_case ();
3092       c->where = gfc_current_locus;
3093       new_st.ext.case_list = c;
3094       return MATCH_YES;
3095     }
3096
3097   if (gfc_match_char ('(') != MATCH_YES)
3098     goto syntax;
3099
3100   for (;;)
3101     {
3102       if (match_case_selector (&c) == MATCH_ERROR)
3103         goto cleanup;
3104
3105       if (head == NULL)
3106         head = c;
3107       else
3108         tail->next = c;
3109
3110       tail = c;
3111
3112       if (gfc_match_char (')') == MATCH_YES)
3113         break;
3114       if (gfc_match_char (',') != MATCH_YES)
3115         goto syntax;
3116     }
3117
3118   m = match_case_eos ();
3119   if (m == MATCH_NO)
3120     goto syntax;
3121   if (m == MATCH_ERROR)
3122     goto cleanup;
3123
3124   new_st.op = EXEC_SELECT;
3125   new_st.ext.case_list = head;
3126
3127   return MATCH_YES;
3128
3129 syntax:
3130   gfc_error ("Syntax error in CASE-specification at %C");
3131
3132 cleanup:
3133   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
3134   return MATCH_ERROR;
3135 }
3136
3137 /********************* WHERE subroutines ********************/
3138
3139 /* Match the rest of a simple WHERE statement that follows an IF statement.
3140  */
3141
3142 static match
3143 match_simple_where (void)
3144 {
3145   gfc_expr *expr;
3146   gfc_code *c;
3147   match m;
3148
3149   m = gfc_match (" ( %e )", &expr);
3150   if (m != MATCH_YES)
3151     return m;
3152
3153   m = gfc_match_assignment ();
3154   if (m == MATCH_NO)
3155     goto syntax;
3156   if (m == MATCH_ERROR)
3157     goto cleanup;
3158
3159   if (gfc_match_eos () != MATCH_YES)
3160     goto syntax;
3161
3162   c = gfc_get_code ();
3163
3164   c->op = EXEC_WHERE;
3165   c->expr = expr;
3166   c->next = gfc_get_code ();
3167
3168   *c->next = new_st;
3169   gfc_clear_new_st ();
3170
3171   new_st.op = EXEC_WHERE;
3172   new_st.block = c;
3173
3174   return MATCH_YES;
3175
3176 syntax:
3177   gfc_syntax_error (ST_WHERE);
3178
3179 cleanup:
3180   gfc_free_expr (expr);
3181   return MATCH_ERROR;
3182 }
3183
3184 /* Match a WHERE statement.  */
3185
3186 match
3187 gfc_match_where (gfc_statement * st)
3188 {
3189   gfc_expr *expr;
3190   match m0, m;
3191   gfc_code *c;
3192
3193   m0 = gfc_match_label ();
3194   if (m0 == MATCH_ERROR)
3195     return m0;
3196
3197   m = gfc_match (" where ( %e )", &expr);
3198   if (m != MATCH_YES)
3199     return m;
3200
3201   if (gfc_match_eos () == MATCH_YES)
3202     {
3203       *st = ST_WHERE_BLOCK;
3204
3205       new_st.op = EXEC_WHERE;
3206       new_st.expr = expr;
3207       return MATCH_YES;
3208     }
3209
3210   m = gfc_match_assignment ();
3211   if (m == MATCH_NO)
3212     gfc_syntax_error (ST_WHERE);
3213
3214   if (m != MATCH_YES)
3215     {
3216       gfc_free_expr (expr);
3217       return MATCH_ERROR;
3218     }
3219
3220   /* We've got a simple WHERE statement.  */
3221   *st = ST_WHERE;
3222   c = gfc_get_code ();
3223
3224   c->op = EXEC_WHERE;
3225   c->expr = expr;
3226   c->next = gfc_get_code ();
3227
3228   *c->next = new_st;
3229   gfc_clear_new_st ();
3230
3231   new_st.op = EXEC_WHERE;
3232   new_st.block = c;
3233
3234   return MATCH_YES;
3235 }
3236
3237
3238 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
3239    new_st if successful.  */
3240
3241 match
3242 gfc_match_elsewhere (void)
3243 {
3244   char name[GFC_MAX_SYMBOL_LEN + 1];
3245   gfc_expr *expr;
3246   match m;
3247
3248   if (gfc_current_state () != COMP_WHERE)
3249     {
3250       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3251       return MATCH_ERROR;
3252     }
3253
3254   expr = NULL;
3255
3256   if (gfc_match_char ('(') == MATCH_YES)
3257     {
3258       m = gfc_match_expr (&expr);
3259       if (m == MATCH_NO)
3260         goto syntax;
3261       if (m == MATCH_ERROR)
3262         return MATCH_ERROR;
3263
3264       if (gfc_match_char (')') != MATCH_YES)
3265         goto syntax;
3266     }
3267
3268   if (gfc_match_eos () != MATCH_YES)
3269     {                           /* Better be a name at this point */
3270       m = gfc_match_name (name);
3271       if (m == MATCH_NO)
3272         goto syntax;
3273       if (m == MATCH_ERROR)
3274         goto cleanup;
3275
3276       if (gfc_match_eos () != MATCH_YES)
3277         goto syntax;
3278
3279       if (strcmp (name, gfc_current_block ()->name) != 0)
3280         {
3281           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3282                      name, gfc_current_block ()->name);
3283           goto cleanup;
3284         }
3285     }
3286
3287   new_st.op = EXEC_WHERE;
3288   new_st.expr = expr;
3289   return MATCH_YES;
3290
3291 syntax:
3292   gfc_syntax_error (ST_ELSEWHERE);
3293
3294 cleanup:
3295   gfc_free_expr (expr);
3296   return MATCH_ERROR;
3297 }
3298
3299
3300 /******************** FORALL subroutines ********************/
3301
3302 /* Free a list of FORALL iterators.  */
3303
3304 void
3305 gfc_free_forall_iterator (gfc_forall_iterator * iter)
3306 {
3307   gfc_forall_iterator *next;
3308
3309   while (iter)
3310     {
3311       next = iter->next;
3312
3313       gfc_free_expr (iter->var);
3314       gfc_free_expr (iter->start);
3315       gfc_free_expr (iter->end);
3316       gfc_free_expr (iter->stride);
3317
3318       gfc_free (iter);
3319       iter = next;
3320     }
3321 }
3322
3323
3324 /* Match an iterator as part of a FORALL statement.  The format is:
3325
3326      <var> = <start>:<end>[:<stride>][, <scalar mask>]  */
3327
3328 static match
3329 match_forall_iterator (gfc_forall_iterator ** result)
3330 {
3331   gfc_forall_iterator *iter;
3332   locus where;
3333   match m;
3334
3335   where = gfc_current_locus;
3336   iter = gfc_getmem (sizeof (gfc_forall_iterator));
3337
3338   m = gfc_match_variable (&iter->var, 0);
3339   if (m != MATCH_YES)
3340     goto cleanup;
3341
3342   if (gfc_match_char ('=') != MATCH_YES)
3343     {
3344       m = MATCH_NO;
3345       goto cleanup;
3346     }
3347
3348   m = gfc_match_expr (&iter->start);
3349   if (m != MATCH_YES)
3350     goto cleanup;
3351
3352   if (gfc_match_char (':') != MATCH_YES)
3353     goto syntax;
3354
3355   m = gfc_match_expr (&iter->end);
3356   if (m == MATCH_NO)
3357     goto syntax;
3358   if (m == MATCH_ERROR)
3359     goto cleanup;
3360
3361   if (gfc_match_char (':') == MATCH_NO)
3362     iter->stride = gfc_int_expr (1);
3363   else
3364     {
3365       m = gfc_match_expr (&iter->stride);
3366       if (m == MATCH_NO)
3367         goto syntax;
3368       if (m == MATCH_ERROR)
3369         goto cleanup;
3370     }
3371
3372   *result = iter;
3373   return MATCH_YES;
3374
3375 syntax:
3376   gfc_error ("Syntax error in FORALL iterator at %C");
3377   m = MATCH_ERROR;
3378
3379 cleanup:
3380   gfc_current_locus = where;
3381   gfc_free_forall_iterator (iter);
3382   return m;
3383 }
3384
3385
3386 /* Match the header of a FORALL statement.  */
3387
3388 static match
3389 match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
3390 {
3391   gfc_forall_iterator *head, *tail, *new;
3392   gfc_expr *msk;
3393   match m;
3394
3395   gfc_gobble_whitespace ();
3396
3397   head = tail = NULL;
3398   msk = NULL;
3399
3400   if (gfc_match_char ('(') != MATCH_YES)
3401     return MATCH_NO;
3402
3403   m = match_forall_iterator (&new);
3404   if (m == MATCH_ERROR)
3405     goto cleanup;
3406   if (m == MATCH_NO)
3407     goto syntax;
3408
3409   head = tail = new;
3410
3411   for (;;)
3412     {
3413       if (gfc_match_char (',') != MATCH_YES)
3414         break;
3415
3416       m = match_forall_iterator (&new);
3417       if (m == MATCH_ERROR)
3418         goto cleanup;
3419
3420       if (m == MATCH_YES)
3421         {
3422           tail->next = new;
3423           tail = new;
3424           continue;
3425         }
3426
3427       /* Have to have a mask expression */
3428
3429       m = gfc_match_expr (&msk);
3430       if (m == MATCH_NO)
3431         goto syntax;
3432       if (m == MATCH_ERROR)
3433         goto cleanup;
3434
3435       break;
3436     }
3437
3438   if (gfc_match_char (')') == MATCH_NO)
3439     goto syntax;
3440
3441   *phead = head;
3442   *mask = msk;
3443   return MATCH_YES;
3444
3445 syntax:
3446   gfc_syntax_error (ST_FORALL);
3447
3448 cleanup:
3449   gfc_free_expr (msk);
3450   gfc_free_forall_iterator (head);
3451
3452   return MATCH_ERROR;
3453 }
3454
3455 /* Match the rest of a simple FORALL statement that follows an IF statement.
3456  */
3457
3458 static match
3459 match_simple_forall (void)
3460 {
3461   gfc_forall_iterator *head;
3462   gfc_expr *mask;
3463   gfc_code *c;
3464   match m;
3465
3466   mask = NULL;
3467   head = NULL;
3468   c = NULL;
3469
3470   m = match_forall_header (&head, &mask);
3471
3472   if (m == MATCH_NO)
3473     goto syntax;
3474   if (m != MATCH_YES)
3475     goto cleanup;
3476
3477   m = gfc_match_assignment ();
3478
3479   if (m == MATCH_ERROR)
3480     goto cleanup;
3481   if (m == MATCH_NO)
3482     {
3483       m = gfc_match_pointer_assignment ();
3484       if (m == MATCH_ERROR)
3485         goto cleanup;
3486       if (m == MATCH_NO)
3487         goto syntax;
3488     }
3489
3490   c = gfc_get_code ();
3491   *c = new_st;
3492   c->loc = gfc_current_locus;
3493
3494   if (gfc_match_eos () != MATCH_YES)
3495     goto syntax;
3496
3497   gfc_clear_new_st ();
3498   new_st.op = EXEC_FORALL;
3499   new_st.expr = mask;
3500   new_st.ext.forall_iterator = head;
3501   new_st.block = gfc_get_code ();
3502
3503   new_st.block->op = EXEC_FORALL;
3504   new_st.block->next = c;
3505
3506   return MATCH_YES;
3507
3508 syntax:
3509   gfc_syntax_error (ST_FORALL);
3510
3511 cleanup:
3512   gfc_free_forall_iterator (head);
3513   gfc_free_expr (mask);
3514
3515   return MATCH_ERROR;
3516 }
3517
3518
3519 /* Match a FORALL statement.  */
3520
3521 match
3522 gfc_match_forall (gfc_statement * st)
3523 {
3524   gfc_forall_iterator *head;
3525   gfc_expr *mask;
3526   gfc_code *c;
3527   match m0, m;
3528
3529   head = NULL;
3530   mask = NULL;
3531   c = NULL;
3532
3533   m0 = gfc_match_label ();
3534   if (m0 == MATCH_ERROR)
3535     return MATCH_ERROR;
3536
3537   m = gfc_match (" forall");
3538   if (m != MATCH_YES)
3539     return m;
3540
3541   m = match_forall_header (&head, &mask);
3542   if (m == MATCH_ERROR)
3543     goto cleanup;
3544   if (m == MATCH_NO)
3545     goto syntax;
3546
3547   if (gfc_match_eos () == MATCH_YES)
3548     {
3549       *st = ST_FORALL_BLOCK;
3550
3551       new_st.op = EXEC_FORALL;
3552       new_st.expr = mask;
3553       new_st.ext.forall_iterator = head;
3554
3555       return MATCH_YES;
3556     }
3557
3558   m = gfc_match_assignment ();
3559   if (m == MATCH_ERROR)
3560     goto cleanup;
3561   if (m == MATCH_NO)
3562     {
3563       m = gfc_match_pointer_assignment ();
3564       if (m == MATCH_ERROR)
3565         goto cleanup;
3566       if (m == MATCH_NO)
3567         goto syntax;
3568     }
3569
3570   c = gfc_get_code ();
3571   *c = new_st;
3572
3573   if (gfc_match_eos () != MATCH_YES)
3574     goto syntax;
3575
3576   gfc_clear_new_st ();
3577   new_st.op = EXEC_FORALL;
3578   new_st.expr = mask;
3579   new_st.ext.forall_iterator = head;
3580   new_st.block = gfc_get_code ();
3581
3582   new_st.block->op = EXEC_FORALL;
3583   new_st.block->next = c;
3584
3585   *st = ST_FORALL;
3586   return MATCH_YES;
3587
3588 syntax:
3589   gfc_syntax_error (ST_FORALL);
3590
3591 cleanup:
3592   gfc_free_forall_iterator (head);
3593   gfc_free_expr (mask);
3594   gfc_free_statements (c);
3595   return MATCH_NO;
3596 }