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