gcc/fortran/match.c

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