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           sym->refs++;
2593
2594           if (group_name->namelist == NULL)
2595             group_name->namelist = group_name->namelist_tail = nl;
2596           else
2597             {
2598               group_name->namelist_tail->next = nl;
2599               group_name->namelist_tail = nl;
2600             }
2601
2602           if (gfc_match_eos () == MATCH_YES)
2603             goto done;
2604
2605           m = gfc_match_char (',');
2606
2607           if (gfc_match_char ('/') == MATCH_YES)
2608             {
2609               m2 = gfc_match (" %s /", &group_name);
2610               if (m2 == MATCH_YES)
2611                 break;
2612               if (m2 == MATCH_ERROR)
2613                 goto error;
2614               goto syntax;
2615             }
2616
2617           if (m != MATCH_YES)
2618             goto syntax;
2619         }
2620     }
2621
2622 done:
2623   return MATCH_YES;
2624
2625 syntax:
2626   gfc_syntax_error (ST_NAMELIST);
2627
2628 error:
2629   return MATCH_ERROR;
2630 }
2631
2632
2633 /* Match a MODULE statement.  */
2634
2635 match
2636 gfc_match_module (void)
2637 {
2638   match m;
2639
2640   m = gfc_match (" %s%t", &gfc_new_block);
2641   if (m != MATCH_YES)
2642     return m;
2643
2644   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2645                       gfc_new_block->name, NULL) == FAILURE)
2646     return MATCH_ERROR;
2647
2648   return MATCH_YES;
2649 }
2650
2651
2652 /* Free equivalence sets and lists.  Recursively is the easiest way to
2653    do this.  */
2654
2655 void
2656 gfc_free_equiv (gfc_equiv * eq)
2657 {
2658
2659   if (eq == NULL)
2660     return;
2661
2662   gfc_free_equiv (eq->eq);
2663   gfc_free_equiv (eq->next);
2664
2665   gfc_free_expr (eq->expr);
2666   gfc_free (eq);
2667 }
2668
2669
2670 /* Match an EQUIVALENCE statement.  */
2671
2672 match
2673 gfc_match_equivalence (void)
2674 {
2675   gfc_equiv *eq, *set, *tail;
2676   gfc_ref *ref;
2677   gfc_symbol *sym;
2678   match m;
2679   gfc_common_head *common_head = NULL;
2680   bool common_flag;
2681   int cnt;
2682
2683   tail = NULL;
2684
2685   for (;;)
2686     {
2687       eq = gfc_get_equiv ();
2688       if (tail == NULL)
2689         tail = eq;
2690
2691       eq->next = gfc_current_ns->equiv;
2692       gfc_current_ns->equiv = eq;
2693
2694       if (gfc_match_char ('(') != MATCH_YES)
2695         goto syntax;
2696
2697       set = eq;
2698       common_flag = FALSE;
2699       cnt = 0;
2700
2701       for (;;)
2702         {
2703           m = gfc_match_equiv_variable (&set->expr);
2704           if (m == MATCH_ERROR)
2705             goto cleanup;
2706           if (m == MATCH_NO)
2707             goto syntax;
2708
2709           /*  count the number of objects.  */
2710           cnt++;
2711
2712           if (gfc_match_char ('%') == MATCH_YES)
2713             {
2714               gfc_error ("Derived type component %C is not a "
2715                          "permitted EQUIVALENCE member");
2716               goto cleanup;
2717             }
2718
2719           for (ref = set->expr->ref; ref; ref = ref->next)
2720             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2721               {
2722                 gfc_error
2723                   ("Array reference in EQUIVALENCE at %C cannot be an "
2724                    "array section");
2725                 goto cleanup;
2726               }
2727
2728           sym = set->expr->symtree->n.sym;
2729
2730           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL)
2731                 == FAILURE)
2732             goto cleanup;
2733
2734           if (sym->attr.in_common)
2735             {
2736               common_flag = TRUE;
2737               common_head = sym->common_head;
2738             }
2739
2740           if (gfc_match_char (')') == MATCH_YES)
2741             break;
2742
2743           if (gfc_match_char (',') != MATCH_YES)
2744             goto syntax;
2745
2746           set->eq = gfc_get_equiv ();
2747           set = set->eq;
2748         }
2749
2750       if (cnt < 2)
2751         {
2752           gfc_error ("EQUIVALENCE at %C requires two or more objects");
2753           goto cleanup;
2754         }
2755
2756       /* If one of the members of an equivalence is in common, then
2757          mark them all as being in common.  Before doing this, check
2758          that members of the equivalence group are not in different
2759          common blocks. */
2760       if (common_flag)
2761         for (set = eq; set; set = set->eq)
2762           {
2763             sym = set->expr->symtree->n.sym;
2764             if (sym->common_head && sym->common_head != common_head)
2765               {
2766                 gfc_error ("Attempt to indirectly overlap COMMON "
2767                            "blocks %s and %s by EQUIVALENCE at %C",
2768                            sym->common_head->name,
2769                            common_head->name);
2770                 goto cleanup;
2771               }
2772             sym->attr.in_common = 1;
2773             sym->common_head = common_head;
2774           }
2775
2776       if (gfc_match_eos () == MATCH_YES)
2777         break;
2778       if (gfc_match_char (',') != MATCH_YES)
2779         goto syntax;
2780     }
2781
2782   return MATCH_YES;
2783
2784 syntax:
2785   gfc_syntax_error (ST_EQUIVALENCE);
2786
2787 cleanup:
2788   eq = tail->next;
2789   tail->next = NULL;
2790
2791   gfc_free_equiv (gfc_current_ns->equiv);
2792   gfc_current_ns->equiv = eq;
2793
2794   return MATCH_ERROR;
2795 }
2796
2797 /* Check that a statement function is not recursive. This is done by looking
2798    for the statement function symbol(sym) by looking recursively through its
2799    expression(e).  If a reference to sym is found, true is returned.  */
2800 static bool
2801 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
2802 {
2803   gfc_actual_arglist *arg;
2804   gfc_ref *ref;
2805   int i;
2806
2807   if (e == NULL)
2808     return false;
2809
2810   switch (e->expr_type)
2811     {
2812     case EXPR_FUNCTION:
2813       for (arg = e->value.function.actual; arg; arg = arg->next)
2814         {
2815           if (sym->name == arg->name
2816                 || recursive_stmt_fcn (arg->expr, sym))
2817             return true;
2818         }
2819
2820       if (e->symtree == NULL)
2821         return false;
2822
2823       /* Check the name before testing for nested recursion!  */
2824       if (sym->name == e->symtree->n.sym->name)
2825         return true;
2826
2827       /* Catch recursion via other statement functions.  */
2828       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
2829             && e->symtree->n.sym->value
2830             && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
2831         return true;
2832
2833       break;
2834
2835     case EXPR_VARIABLE:
2836       if (e->symtree && sym->name == e->symtree->n.sym->name)
2837         return true;
2838       break;
2839
2840     case EXPR_OP:
2841       if (recursive_stmt_fcn (e->value.op.op1, sym)
2842             || recursive_stmt_fcn (e->value.op.op2, sym))
2843         return true;
2844       break;
2845
2846     default:
2847       break;
2848     }
2849
2850   /* Component references do not need to be checked.  */
2851   if (e->ref)
2852     {
2853       for (ref = e->ref; ref; ref = ref->next)
2854         {
2855           switch (ref->type)
2856             {
2857             case REF_ARRAY:
2858               for (i = 0; i < ref->u.ar.dimen; i++)
2859                 {
2860                   if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
2861                         || recursive_stmt_fcn (ref->u.ar.end[i], sym)
2862                         || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
2863                     return true;
2864                 }
2865               break;
2866
2867             case REF_SUBSTRING:
2868               if (recursive_stmt_fcn (ref->u.ss.start, sym)
2869                     || recursive_stmt_fcn (ref->u.ss.end, sym))
2870                 return true;
2871
2872               break;
2873
2874             default:
2875               break;
2876             }
2877         }
2878     }
2879   return false;
2880 }
2881
2882
2883 /* Match a statement function declaration.  It is so easy to match
2884    non-statement function statements with a MATCH_ERROR as opposed to
2885    MATCH_NO that we suppress error message in most cases.  */
2886
2887 match
2888 gfc_match_st_function (void)
2889 {
2890   gfc_error_buf old_error;
2891   gfc_symbol *sym;
2892   gfc_expr *expr;
2893   match m;
2894
2895   m = gfc_match_symbol (&sym, 0);
2896   if (m != MATCH_YES)
2897     return m;
2898
2899   gfc_push_error (&old_error);
2900
2901   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
2902                          sym->name, NULL) == FAILURE)
2903     goto undo_error;
2904
2905   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2906     goto undo_error;
2907
2908   m = gfc_match (" = %e%t", &expr);
2909   if (m == MATCH_NO)
2910     goto undo_error;
2911
2912   gfc_free_error (&old_error);
2913   if (m == MATCH_ERROR)
2914     return m;
2915
2916   if (recursive_stmt_fcn (expr, sym))
2917     {
2918       gfc_error ("Statement function at %L is recursive",
2919                  &expr->where);
2920       return MATCH_ERROR;
2921     }
2922
2923   sym->value = expr;
2924
2925   return MATCH_YES;
2926
2927 undo_error:
2928   gfc_pop_error (&old_error);
2929   return MATCH_NO;
2930 }
2931
2932
2933 /***************** SELECT CASE subroutines ******************/
2934
2935 /* Free a single case structure.  */
2936
2937 static void
2938 free_case (gfc_case * p)
2939 {
2940   if (p->low == p->high)
2941     p->high = NULL;
2942   gfc_free_expr (p->low);
2943   gfc_free_expr (p->high);
2944   gfc_free (p);
2945 }
2946
2947
2948 /* Free a list of case structures.  */
2949
2950 void
2951 gfc_free_case_list (gfc_case * p)
2952 {
2953   gfc_case *q;
2954
2955   for (; p; p = q)
2956     {
2957       q = p->next;
2958       free_case (p);
2959     }
2960 }
2961
2962
2963 /* Match a single case selector.  */
2964
2965 static match
2966 match_case_selector (gfc_case ** cp)
2967 {
2968   gfc_case *c;
2969   match m;
2970
2971   c = gfc_get_case ();
2972   c->where = gfc_current_locus;
2973
2974   if (gfc_match_char (':') == MATCH_YES)
2975     {
2976       m = gfc_match_init_expr (&c->high);
2977       if (m == MATCH_NO)
2978         goto need_expr;
2979       if (m == MATCH_ERROR)
2980         goto cleanup;
2981     }
2982
2983   else
2984     {
2985       m = gfc_match_init_expr (&c->low);
2986       if (m == MATCH_ERROR)
2987         goto cleanup;
2988       if (m == MATCH_NO)
2989         goto need_expr;
2990
2991       /* If we're not looking at a ':' now, make a range out of a single
2992          target.  Else get the upper bound for the case range.  */
2993       if (gfc_match_char (':') != MATCH_YES)
2994         c->high = c->low;
2995       else
2996         {
2997           m = gfc_match_init_expr (&c->high);
2998           if (m == MATCH_ERROR)
2999             goto cleanup;
3000           /* MATCH_NO is fine.  It's OK if nothing is there!  */
3001         }
3002     }
3003
3004   *cp = c;
3005   return MATCH_YES;
3006
3007 need_expr:
3008   gfc_error ("Expected initialization expression in CASE at %C");
3009
3010 cleanup:
3011   free_case (c);
3012   return MATCH_ERROR;
3013 }
3014
3015
3016 /* Match the end of a case statement.  */
3017
3018 static match
3019 match_case_eos (void)
3020 {
3021   char name[GFC_MAX_SYMBOL_LEN + 1];
3022   match m;
3023
3024   if (gfc_match_eos () == MATCH_YES)
3025     return MATCH_YES;
3026
3027   /* If the case construct doesn't have a case-construct-name, we
3028      should have matched the EOS.  */
3029   if (!gfc_current_block ())
3030     return MATCH_ERROR;
3031
3032   gfc_gobble_whitespace ();
3033
3034   m = gfc_match_name (name);
3035   if (m != MATCH_YES)
3036     return m;
3037
3038   if (strcmp (name, gfc_current_block ()->name) != 0)
3039     {
3040       gfc_error ("Expected case name of '%s' at %C",
3041                  gfc_current_block ()->name);
3042       return MATCH_ERROR;
3043     }
3044
3045   return gfc_match_eos ();
3046 }
3047
3048
3049 /* Match a SELECT statement.  */
3050
3051 match
3052 gfc_match_select (void)
3053 {
3054   gfc_expr *expr;
3055   match m;
3056
3057   m = gfc_match_label ();
3058   if (m == MATCH_ERROR)
3059     return m;
3060
3061   m = gfc_match (" select case ( %e )%t", &expr);
3062   if (m != MATCH_YES)
3063     return m;
3064
3065   new_st.op = EXEC_SELECT;
3066   new_st.expr = expr;
3067
3068   return MATCH_YES;
3069 }
3070
3071
3072 /* Match a CASE statement.  */
3073
3074 match
3075 gfc_match_case (void)
3076 {
3077   gfc_case *c, *head, *tail;
3078   match m;
3079
3080   head = tail = NULL;
3081
3082   if (gfc_current_state () != COMP_SELECT)
3083     {
3084       gfc_error ("Unexpected CASE statement at %C");
3085       return MATCH_ERROR;
3086     }
3087
3088   if (gfc_match ("% default") == MATCH_YES)
3089     {
3090       m = match_case_eos ();
3091       if (m == MATCH_NO)
3092         goto syntax;
3093       if (m == MATCH_ERROR)
3094         goto cleanup;
3095
3096       new_st.op = EXEC_SELECT;
3097       c = gfc_get_case ();
3098       c->where = gfc_current_locus;
3099       new_st.ext.case_list = c;
3100       return MATCH_YES;
3101     }
3102
3103   if (gfc_match_char ('(') != MATCH_YES)
3104     goto syntax;
3105
3106   for (;;)
3107     {
3108       if (match_case_selector (&c) == MATCH_ERROR)
3109         goto cleanup;
3110
3111       if (head == NULL)
3112         head = c;
3113       else
3114         tail->next = c;
3115
3116       tail = c;
3117
3118       if (gfc_match_char (')') == MATCH_YES)
3119         break;
3120       if (gfc_match_char (',') != MATCH_YES)
3121         goto syntax;
3122     }
3123
3124   m = match_case_eos ();
3125   if (m == MATCH_NO)
3126     goto syntax;
3127   if (m == MATCH_ERROR)
3128     goto cleanup;
3129
3130   new_st.op = EXEC_SELECT;
3131   new_st.ext.case_list = head;
3132
3133   return MATCH_YES;
3134
3135 syntax:
3136   gfc_error ("Syntax error in CASE-specification at %C");
3137
3138 cleanup:
3139   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
3140   return MATCH_ERROR;
3141 }
3142
3143 /********************* WHERE subroutines ********************/
3144
3145 /* Match the rest of a simple WHERE statement that follows an IF statement.
3146  */
3147
3148 static match
3149 match_simple_where (void)
3150 {
3151   gfc_expr *expr;
3152   gfc_code *c;
3153   match m;
3154
3155   m = gfc_match (" ( %e )", &expr);
3156   if (m != MATCH_YES)
3157     return m;
3158
3159   m = gfc_match_assignment ();
3160   if (m == MATCH_NO)
3161     goto syntax;
3162   if (m == MATCH_ERROR)
3163     goto cleanup;
3164
3165   if (gfc_match_eos () != MATCH_YES)
3166     goto syntax;
3167
3168   c = gfc_get_code ();
3169
3170   c->op = EXEC_WHERE;
3171   c->expr = expr;
3172   c->next = gfc_get_code ();
3173
3174   *c->next = new_st;
3175   gfc_clear_new_st ();
3176
3177   new_st.op = EXEC_WHERE;
3178   new_st.block = c;
3179
3180   return MATCH_YES;
3181
3182 syntax:
3183   gfc_syntax_error (ST_WHERE);
3184
3185 cleanup:
3186   gfc_free_expr (expr);
3187   return MATCH_ERROR;
3188 }
3189
3190 /* Match a WHERE statement.  */
3191
3192 match
3193 gfc_match_where (gfc_statement * st)
3194 {
3195   gfc_expr *expr;
3196   match m0, m;
3197   gfc_code *c;
3198
3199   m0 = gfc_match_label ();
3200   if (m0 == MATCH_ERROR)
3201     return m0;
3202
3203   m = gfc_match (" where ( %e )", &expr);
3204   if (m != MATCH_YES)
3205     return m;
3206
3207   if (gfc_match_eos () == MATCH_YES)
3208     {
3209       *st = ST_WHERE_BLOCK;
3210
3211       new_st.op = EXEC_WHERE;
3212       new_st.expr = expr;
3213       return MATCH_YES;
3214     }
3215
3216   m = gfc_match_assignment ();
3217   if (m == MATCH_NO)
3218     gfc_syntax_error (ST_WHERE);
3219
3220   if (m != MATCH_YES)
3221     {
3222       gfc_free_expr (expr);
3223       return MATCH_ERROR;
3224     }
3225
3226   /* We've got a simple WHERE statement.  */
3227   *st = ST_WHERE;
3228   c = gfc_get_code ();
3229
3230   c->op = EXEC_WHERE;
3231   c->expr = expr;
3232   c->next = gfc_get_code ();
3233
3234   *c->next = new_st;
3235   gfc_clear_new_st ();
3236
3237   new_st.op = EXEC_WHERE;
3238   new_st.block = c;
3239
3240   return MATCH_YES;
3241 }
3242
3243
3244 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
3245    new_st if successful.  */
3246
3247 match
3248 gfc_match_elsewhere (void)
3249 {
3250   char name[GFC_MAX_SYMBOL_LEN + 1];
3251   gfc_expr *expr;
3252   match m;
3253
3254   if (gfc_current_state () != COMP_WHERE)
3255     {
3256       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3257       return MATCH_ERROR;
3258     }
3259
3260   expr = NULL;
3261
3262   if (gfc_match_char ('(') == MATCH_YES)
3263     {
3264       m = gfc_match_expr (&expr);
3265       if (m == MATCH_NO)
3266         goto syntax;
3267       if (m == MATCH_ERROR)
3268         return MATCH_ERROR;
3269
3270       if (gfc_match_char (')') != MATCH_YES)
3271         goto syntax;
3272     }
3273
3274   if (gfc_match_eos () != MATCH_YES)
3275     {                           /* Better be a name at this point */
3276       m = gfc_match_name (name);
3277       if (m == MATCH_NO)
3278         goto syntax;
3279       if (m == MATCH_ERROR)
3280         goto cleanup;
3281
3282       if (gfc_match_eos () != MATCH_YES)
3283         goto syntax;
3284
3285       if (strcmp (name, gfc_current_block ()->name) != 0)
3286         {
3287           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3288                      name, gfc_current_block ()->name);
3289           goto cleanup;
3290         }
3291     }
3292
3293   new_st.op = EXEC_WHERE;
3294   new_st.expr = expr;
3295   return MATCH_YES;
3296
3297 syntax:
3298   gfc_syntax_error (ST_ELSEWHERE);
3299
3300 cleanup:
3301   gfc_free_expr (expr);
3302   return MATCH_ERROR;
3303 }
3304
3305
3306 /******************** FORALL subroutines ********************/
3307
3308 /* Free a list of FORALL iterators.  */
3309
3310 void
3311 gfc_free_forall_iterator (gfc_forall_iterator * iter)
3312 {
3313   gfc_forall_iterator *next;
3314
3315   while (iter)
3316     {
3317       next = iter->next;
3318
3319       gfc_free_expr (iter->var);
3320       gfc_free_expr (iter->start);
3321       gfc_free_expr (iter->end);
3322       gfc_free_expr (iter->stride);
3323
3324       gfc_free (iter);
3325       iter = next;
3326     }
3327 }
3328
3329
3330 /* Match an iterator as part of a FORALL statement.  The format is:
3331
3332      <var> = <start>:<end>[:<stride>][, <scalar mask>]  */
3333
3334 static match
3335 match_forall_iterator (gfc_forall_iterator ** result)
3336 {
3337   gfc_forall_iterator *iter;
3338   locus where;
3339   match m;
3340
3341   where = gfc_current_locus;
3342   iter = gfc_getmem (sizeof (gfc_forall_iterator));
3343
3344   m = gfc_match_variable (&iter->var, 0);
3345   if (m != MATCH_YES)
3346     goto cleanup;
3347
3348   if (gfc_match_char ('=') != MATCH_YES)
3349     {
3350       m = MATCH_NO;
3351       goto cleanup;
3352     }
3353
3354   m = gfc_match_expr (&iter->start);
3355   if (m != MATCH_YES)
3356     goto cleanup;
3357
3358   if (gfc_match_char (':') != MATCH_YES)
3359     goto syntax;
3360
3361   m = gfc_match_expr (&iter->end);
3362   if (m == MATCH_NO)
3363     goto syntax;
3364   if (m == MATCH_ERROR)
3365     goto cleanup;
3366
3367   if (gfc_match_char (':') == MATCH_NO)
3368     iter->stride = gfc_int_expr (1);
3369   else
3370     {
3371       m = gfc_match_expr (&iter->stride);
3372       if (m == MATCH_NO)
3373         goto syntax;
3374       if (m == MATCH_ERROR)
3375         goto cleanup;
3376     }
3377
3378   /* Mark the iteration variable's symbol as used as a FORALL index.  */
3379   iter->var->symtree->n.sym->forall_index = true;
3380
3381   *result = iter;
3382   return MATCH_YES;
3383
3384 syntax:
3385   gfc_error ("Syntax error in FORALL iterator at %C");
3386   m = MATCH_ERROR;
3387
3388 cleanup:
3389   gfc_current_locus = where;
3390   gfc_free_forall_iterator (iter);
3391   return m;
3392 }
3393
3394
3395 /* Match the header of a FORALL statement.  */
3396
3397 static match
3398 match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
3399 {
3400   gfc_forall_iterator *head, *tail, *new;
3401   gfc_expr *msk;
3402   match m;
3403
3404   gfc_gobble_whitespace ();
3405
3406   head = tail = NULL;
3407   msk = NULL;
3408
3409   if (gfc_match_char ('(') != MATCH_YES)
3410     return MATCH_NO;
3411
3412   m = match_forall_iterator (&new);
3413   if (m == MATCH_ERROR)
3414     goto cleanup;
3415   if (m == MATCH_NO)
3416     goto syntax;
3417
3418   head = tail = new;
3419
3420   for (;;)
3421     {
3422       if (gfc_match_char (',') != MATCH_YES)
3423         break;
3424
3425       m = match_forall_iterator (&new);
3426       if (m == MATCH_ERROR)
3427         goto cleanup;
3428
3429       if (m == MATCH_YES)
3430         {
3431           tail->next = new;
3432           tail = new;
3433           continue;
3434         }
3435
3436       /* Have to have a mask expression */
3437
3438       m = gfc_match_expr (&msk);
3439       if (m == MATCH_NO)
3440         goto syntax;
3441       if (m == MATCH_ERROR)
3442         goto cleanup;
3443
3444       break;
3445     }
3446
3447   if (gfc_match_char (')') == MATCH_NO)
3448     goto syntax;
3449
3450   *phead = head;
3451   *mask = msk;
3452   return MATCH_YES;
3453
3454 syntax:
3455   gfc_syntax_error (ST_FORALL);
3456
3457 cleanup:
3458   gfc_free_expr (msk);
3459   gfc_free_forall_iterator (head);
3460
3461   return MATCH_ERROR;
3462 }
3463
3464 /* Match the rest of a simple FORALL statement that follows an IF statement.
3465  */
3466
3467 static match
3468 match_simple_forall (void)
3469 {
3470   gfc_forall_iterator *head;
3471   gfc_expr *mask;
3472   gfc_code *c;
3473   match m;
3474
3475   mask = NULL;
3476   head = NULL;
3477   c = NULL;
3478
3479   m = match_forall_header (&head, &mask);
3480
3481   if (m == MATCH_NO)
3482     goto syntax;
3483   if (m != MATCH_YES)
3484     goto cleanup;
3485
3486   m = gfc_match_assignment ();
3487
3488   if (m == MATCH_ERROR)
3489     goto cleanup;
3490   if (m == MATCH_NO)
3491     {
3492       m = gfc_match_pointer_assignment ();
3493       if (m == MATCH_ERROR)
3494         goto cleanup;
3495       if (m == MATCH_NO)
3496         goto syntax;
3497     }
3498
3499   c = gfc_get_code ();
3500   *c = new_st;
3501   c->loc = gfc_current_locus;
3502
3503   if (gfc_match_eos () != MATCH_YES)
3504     goto syntax;
3505
3506   gfc_clear_new_st ();
3507   new_st.op = EXEC_FORALL;
3508   new_st.expr = mask;
3509   new_st.ext.forall_iterator = head;
3510   new_st.block = gfc_get_code ();
3511
3512   new_st.block->op = EXEC_FORALL;
3513   new_st.block->next = c;
3514
3515   return MATCH_YES;
3516
3517 syntax:
3518   gfc_syntax_error (ST_FORALL);
3519
3520 cleanup:
3521   gfc_free_forall_iterator (head);
3522   gfc_free_expr (mask);
3523
3524   return MATCH_ERROR;
3525 }
3526
3527
3528 /* Match a FORALL statement.  */
3529
3530 match
3531 gfc_match_forall (gfc_statement * st)
3532 {
3533   gfc_forall_iterator *head;
3534   gfc_expr *mask;
3535   gfc_code *c;
3536   match m0, m;
3537
3538   head = NULL;
3539   mask = NULL;
3540   c = NULL;
3541
3542   m0 = gfc_match_label ();
3543   if (m0 == MATCH_ERROR)
3544     return MATCH_ERROR;
3545
3546   m = gfc_match (" forall");
3547   if (m != MATCH_YES)
3548     return m;
3549
3550   m = match_forall_header (&head, &mask);
3551   if (m == MATCH_ERROR)
3552     goto cleanup;
3553   if (m == MATCH_NO)
3554     goto syntax;
3555
3556   if (gfc_match_eos () == MATCH_YES)
3557     {
3558       *st = ST_FORALL_BLOCK;
3559
3560       new_st.op = EXEC_FORALL;
3561       new_st.expr = mask;
3562       new_st.ext.forall_iterator = head;
3563
3564       return MATCH_YES;
3565     }
3566
3567   m = gfc_match_assignment ();
3568   if (m == MATCH_ERROR)
3569     goto cleanup;
3570   if (m == MATCH_NO)
3571     {
3572       m = gfc_match_pointer_assignment ();
3573       if (m == MATCH_ERROR)
3574         goto cleanup;
3575       if (m == MATCH_NO)
3576         goto syntax;
3577     }
3578
3579   c = gfc_get_code ();
3580   *c = new_st;
3581
3582   if (gfc_match_eos () != MATCH_YES)
3583     goto syntax;
3584
3585   gfc_clear_new_st ();
3586   new_st.op = EXEC_FORALL;
3587   new_st.expr = mask;
3588   new_st.ext.forall_iterator = head;
3589   new_st.block = gfc_get_code ();
3590
3591   new_st.block->op = EXEC_FORALL;
3592   new_st.block->next = c;
3593
3594   *st = ST_FORALL;
3595   return MATCH_YES;
3596
3597 syntax:
3598   gfc_syntax_error (ST_FORALL);
3599
3600 cleanup:
3601   gfc_free_forall_iterator (head);
3602   gfc_free_expr (mask);
3603   gfc_free_statements (c);
3604   return MATCH_NO;
3605 }