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   new_st.op = EXEC_POINTER_ASSIGN;
 915   new_st.expr = lvalue;
 916   new_st.expr2 = rvalue;
 917
 918   return MATCH_YES;
 919
 920 cleanup:
 921   gfc_current_locus = old_loc;
 922   gfc_free_expr (lvalue);
 923   gfc_free_expr (rvalue);
 924   return m;
 925 }
 926
 927
 928 /* We try to match an easy arithmetic IF statement. This only happens
 929    when just after having encountered a simple IF statement. This code
 930    is really duplicate with parts of the gfc_match_if code, but this is
 931    *much* easier.  */
 932
 933 static match
 934 match_arithmetic_if (void)
 935 {
 936   gfc_st_label *l1, *l2, *l3;
 937   gfc_expr *expr;
 938   match m;
 939
 940   m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
 941   if (m != MATCH_YES)
 942     return m;
 943
 944   if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
 945       || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
 946       || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
 947     {
 948       gfc_free_expr (expr);
 949       return MATCH_ERROR;
 950     }
 951
 952   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF statement "
 953                       "at %C") == FAILURE)
 954     return MATCH_ERROR;
 955
 956   new_st.op = EXEC_ARITHMETIC_IF;
 957   new_st.expr = expr;
 958   new_st.label = l1;
 959   new_st.label2 = l2;
 960   new_st.label3 = l3;
 961
 962   return MATCH_YES;
 963 }
 964
 965
 966 /* The IF statement is a bit of a pain.  First of all, there are three
 967    forms of it, the simple IF, the IF that starts a block and the
 968    arithmetic IF.
 969
 970    There is a problem with the simple IF and that is the fact that we
 971    only have a single level of undo information on symbols.  What this
 972    means is for a simple IF, we must re-match the whole IF statement
 973    multiple times in order to guarantee that the symbol table ends up
 974    in the proper state.  */
 975
 976 static match match_simple_forall (void);
 977 static match match_simple_where (void);
 978
 979 match
 980 gfc_match_if (gfc_statement *if_type)
 981 {
 982   gfc_expr *expr;
 983   gfc_st_label *l1, *l2, *l3;
 984   locus old_loc;
 985   gfc_code *p;
 986   match m, n;
 987
 988   n = gfc_match_label ();
 989   if (n == MATCH_ERROR)
 990     return n;
 991
 992   old_loc = gfc_current_locus;
 993
 994   m = gfc_match (" if ( %e", &expr);
 995   if (m != MATCH_YES)
 996     return m;
 997
 998   if (gfc_match_char (')') != MATCH_YES)
 999     {
1000       gfc_error ("Syntax error in IF-expression at %C");
1001       gfc_free_expr (expr);
1002       return MATCH_ERROR;
1003     }
1004
1005   m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1006
1007   if (m == MATCH_YES)
1008     {
1009       if (n == MATCH_YES)
1010         {
1011           gfc_error ("Block label not appropriate for arithmetic IF "
1012                      "statement at %C");
1013           gfc_free_expr (expr);
1014           return MATCH_ERROR;
1015         }
1016
1017       if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1018           || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1019           || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1020         {
1021           gfc_free_expr (expr);
1022           return MATCH_ERROR;
1023         }
1024
1025       if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF "
1026                           "statement at %C") == FAILURE)
1027         return MATCH_ERROR;
1028
1029       new_st.op = EXEC_ARITHMETIC_IF;
1030       new_st.expr = expr;
1031       new_st.label = l1;
1032       new_st.label2 = l2;
1033       new_st.label3 = l3;
1034
1035       *if_type = ST_ARITHMETIC_IF;
1036       return MATCH_YES;
1037     }
1038
1039   if (gfc_match (" then%t") == MATCH_YES)
1040     {
1041       new_st.op = EXEC_IF;
1042       new_st.expr = expr;
1043       *if_type = ST_IF_BLOCK;
1044       return MATCH_YES;
1045     }
1046
1047   if (n == MATCH_YES)
1048     {
1049       gfc_error ("Block label is not appropriate IF statement at %C");
1050       gfc_free_expr (expr);
1051       return MATCH_ERROR;
1052     }
1053
1054   /* At this point the only thing left is a simple IF statement.  At
1055      this point, n has to be MATCH_NO, so we don't have to worry about
1056      re-matching a block label.  From what we've got so far, try
1057      matching an assignment.  */
1058
1059   *if_type = ST_SIMPLE_IF;
1060
1061   m = gfc_match_assignment ();
1062   if (m == MATCH_YES)
1063     goto got_match;
1064
1065   gfc_free_expr (expr);
1066   gfc_undo_symbols ();
1067   gfc_current_locus = old_loc;
1068
1069   /* m can be MATCH_NO or MATCH_ERROR, here.  For MATCH_ERROR, a mangled
1070      assignment was found.  For MATCH_NO, continue to call the various
1071      matchers.  */
1072   if (m == MATCH_ERROR)
1073     return MATCH_ERROR;
1074
1075   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */
1076
1077   m = gfc_match_pointer_assignment ();
1078   if (m == MATCH_YES)
1079     goto got_match;
1080
1081   gfc_free_expr (expr);
1082   gfc_undo_symbols ();
1083   gfc_current_locus = old_loc;
1084
1085   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */
1086
1087   /* Look at the next keyword to see which matcher to call.  Matching
1088      the keyword doesn't affect the symbol table, so we don't have to
1089      restore between tries.  */
1090
1091 #define match(string, subr, statement) \
1092   if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1093
1094   gfc_clear_error ();
1095
1096   match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1097   match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1098   match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1099   match ("call", gfc_match_call, ST_CALL)
1100   match ("close", gfc_match_close, ST_CLOSE)
1101   match ("continue", gfc_match_continue, ST_CONTINUE)
1102   match ("cycle", gfc_match_cycle, ST_CYCLE)
1103   match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1104   match ("end file", gfc_match_endfile, ST_END_FILE)
1105   match ("exit", gfc_match_exit, ST_EXIT)
1106   match ("flush", gfc_match_flush, ST_FLUSH)
1107   match ("forall", match_simple_forall, ST_FORALL)
1108   match ("go to", gfc_match_goto, ST_GOTO)
1109   match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1110   match ("inquire", gfc_match_inquire, ST_INQUIRE)
1111   match ("nullify", gfc_match_nullify, ST_NULLIFY)
1112   match ("open", gfc_match_open, ST_OPEN)
1113   match ("pause", gfc_match_pause, ST_NONE)
1114   match ("print", gfc_match_print, ST_WRITE)
1115   match ("read", gfc_match_read, ST_READ)
1116   match ("return", gfc_match_return, ST_RETURN)
1117   match ("rewind", gfc_match_rewind, ST_REWIND)
1118   match ("stop", gfc_match_stop, ST_STOP)
1119   match ("where", match_simple_where, ST_WHERE)
1120   match ("write", gfc_match_write, ST_WRITE)
1121
1122   /* The gfc_match_assignment() above may have returned a MATCH_NO
1123      where the assignment was to a named constant.  Check that
1124      special case here.  */
1125   m = gfc_match_assignment ();
1126   if (m == MATCH_NO)
1127    {
1128       gfc_error ("Cannot assign to a named constant at %C");
1129       gfc_free_expr (expr);
1130       gfc_undo_symbols ();
1131       gfc_current_locus = old_loc;
1132       return MATCH_ERROR;
1133    }
1134
1135   /* All else has failed, so give up.  See if any of the matchers has
1136      stored an error message of some sort.  */
1137   if (gfc_error_check () == 0)
1138     gfc_error ("Unclassifiable statement in IF-clause at %C");
1139
1140   gfc_free_expr (expr);
1141   return MATCH_ERROR;
1142
1143 got_match:
1144   if (m == MATCH_NO)
1145     gfc_error ("Syntax error in IF-clause at %C");
1146   if (m != MATCH_YES)
1147     {
1148       gfc_free_expr (expr);
1149       return MATCH_ERROR;
1150     }
1151
1152   /* At this point, we've matched the single IF and the action clause
1153      is in new_st.  Rearrange things so that the IF statement appears
1154      in new_st.  */
1155
1156   p = gfc_get_code ();
1157   p->next = gfc_get_code ();
1158   *p->next = new_st;
1159   p->next->loc = gfc_current_locus;
1160
1161   p->expr = expr;
1162   p->op = EXEC_IF;
1163
1164   gfc_clear_new_st ();
1165
1166   new_st.op = EXEC_IF;
1167   new_st.block = p;
1168
1169   return MATCH_YES;
1170 }
1171
1172 #undef match
1173
1174
1175 /* Match an ELSE statement.  */
1176
1177 match
1178 gfc_match_else (void)
1179 {
1180   char name[GFC_MAX_SYMBOL_LEN + 1];
1181
1182   if (gfc_match_eos () == MATCH_YES)
1183     return MATCH_YES;
1184
1185   if (gfc_match_name (name) != MATCH_YES
1186       || gfc_current_block () == NULL
1187       || gfc_match_eos () != MATCH_YES)
1188     {
1189       gfc_error ("Unexpected junk after ELSE statement at %C");
1190       return MATCH_ERROR;
1191     }
1192
1193   if (strcmp (name, gfc_current_block ()->name) != 0)
1194     {
1195       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1196                  name, gfc_current_block ()->name);
1197       return MATCH_ERROR;
1198     }
1199
1200   return MATCH_YES;
1201 }
1202
1203
1204 /* Match an ELSE IF statement.  */
1205
1206 match
1207 gfc_match_elseif (void)
1208 {
1209   char name[GFC_MAX_SYMBOL_LEN + 1];
1210   gfc_expr *expr;
1211   match m;
1212
1213   m = gfc_match (" ( %e ) then", &expr);
1214   if (m != MATCH_YES)
1215     return m;
1216
1217   if (gfc_match_eos () == MATCH_YES)
1218     goto done;
1219
1220   if (gfc_match_name (name) != MATCH_YES
1221       || gfc_current_block () == NULL
1222       || gfc_match_eos () != MATCH_YES)
1223     {
1224       gfc_error ("Unexpected junk after ELSE IF statement at %C");
1225       goto cleanup;
1226     }
1227
1228   if (strcmp (name, gfc_current_block ()->name) != 0)
1229     {
1230       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1231                  name, gfc_current_block ()->name);
1232       goto cleanup;
1233     }
1234
1235 done:
1236   new_st.op = EXEC_IF;
1237   new_st.expr = expr;
1238   return MATCH_YES;
1239
1240 cleanup:
1241   gfc_free_expr (expr);
1242   return MATCH_ERROR;
1243 }
1244
1245
1246 /* Free a gfc_iterator structure.  */
1247
1248 void
1249 gfc_free_iterator (gfc_iterator *iter, int flag)
1250 {
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 label).  */
1393   for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1394     if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1395       break;
1396     else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1397       o = p;
1398
1399   if (p == NULL)
1400     {
1401       if (sym == NULL)
1402         gfc_error ("%s statement at %C is not within a loop",
1403                    gfc_ascii_statement (st));
1404       else
1405         gfc_error ("%s statement at %C is not within loop '%s'",
1406                    gfc_ascii_statement (st), sym->name);
1407
1408       return MATCH_ERROR;
1409     }
1410
1411   if (o != NULL)
1412     {
1413       gfc_error ("%s statement at %C leaving OpenMP structured block",
1414                  gfc_ascii_statement (st));
1415       return MATCH_ERROR;
1416     }
1417   else if (st == ST_EXIT
1418            && p->previous != NULL
1419            && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1420            && (p->previous->head->op == EXEC_OMP_DO
1421                || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1422     {
1423       gcc_assert (p->previous->head->next != NULL);
1424       gcc_assert (p->previous->head->next->op == EXEC_DO
1425                   || p->previous->head->next->op == EXEC_DO_WHILE);
1426       gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1427       return MATCH_ERROR;
1428     }
1429
1430   /* Save the first statement in the loop - needed by the backend.  */
1431   new_st.ext.whichloop = p->head;
1432
1433   new_st.op = op;
1434
1435   return MATCH_YES;
1436 }
1437
1438
1439 /* Match the EXIT statement.  */
1440
1441 match
1442 gfc_match_exit (void)
1443 {
1444   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1445 }
1446
1447
1448 /* Match the CYCLE statement.  */
1449
1450 match
1451 gfc_match_cycle (void)
1452 {
1453   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1454 }
1455
1456
1457 /* Match a number or character constant after a STOP or PAUSE statement.  */
1458
1459 static match
1460 gfc_match_stopcode (gfc_statement st)
1461 {
1462   int stop_code;
1463   gfc_expr *e;
1464   match m;
1465   int cnt;
1466
1467   stop_code = -1;
1468   e = NULL;
1469
1470   if (gfc_match_eos () != MATCH_YES)
1471     {
1472       m = gfc_match_small_literal_int (&stop_code, &cnt);
1473       if (m == MATCH_ERROR)
1474         goto cleanup;
1475
1476       if (m == MATCH_YES && cnt > 5)
1477         {
1478           gfc_error ("Too many digits in STOP code at %C");
1479           goto cleanup;
1480         }
1481
1482       if (m == MATCH_NO)
1483         {
1484           /* Try a character constant.  */
1485           m = gfc_match_expr (&e);
1486           if (m == MATCH_ERROR)
1487             goto cleanup;
1488           if (m == MATCH_NO)
1489             goto syntax;
1490           if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1491             goto syntax;
1492         }
1493
1494       if (gfc_match_eos () != MATCH_YES)
1495         goto syntax;
1496     }
1497
1498   if (gfc_pure (NULL))
1499     {
1500       gfc_error ("%s statement not allowed in PURE procedure at %C",
1501                  gfc_ascii_statement (st));
1502       goto cleanup;
1503     }
1504
1505   new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1506   new_st.expr = e;
1507   new_st.ext.stop_code = stop_code;
1508
1509   return MATCH_YES;
1510
1511 syntax:
1512   gfc_syntax_error (st);
1513
1514 cleanup:
1515
1516   gfc_free_expr (e);
1517   return MATCH_ERROR;
1518 }
1519
1520
1521 /* Match the (deprecated) PAUSE statement.  */
1522
1523 match
1524 gfc_match_pause (void)
1525 {
1526   match m;
1527
1528   m = gfc_match_stopcode (ST_PAUSE);
1529   if (m == MATCH_YES)
1530     {
1531       if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: PAUSE statement at %C")
1532           == FAILURE)
1533         m = MATCH_ERROR;
1534     }
1535   return m;
1536 }
1537
1538
1539 /* Match the STOP statement.  */
1540
1541 match
1542 gfc_match_stop (void)
1543 {
1544   return gfc_match_stopcode (ST_STOP);
1545 }
1546
1547
1548 /* Match a CONTINUE statement.  */
1549
1550 match
1551 gfc_match_continue (void)
1552 {
1553   if (gfc_match_eos () != MATCH_YES)
1554     {
1555       gfc_syntax_error (ST_CONTINUE);
1556       return MATCH_ERROR;
1557     }
1558
1559   new_st.op = EXEC_CONTINUE;
1560   return MATCH_YES;
1561 }
1562
1563
1564 /* Match the (deprecated) ASSIGN statement.  */
1565
1566 match
1567 gfc_match_assign (void)
1568 {
1569   gfc_expr *expr;
1570   gfc_st_label *label;
1571
1572   if (gfc_match (" %l", &label) == MATCH_YES)
1573     {
1574       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
1575         return MATCH_ERROR;
1576       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
1577         {
1578           if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: ASSIGN "
1579                               "statement at %C")
1580               == FAILURE)
1581             return MATCH_ERROR;
1582
1583           expr->symtree->n.sym->attr.assign = 1;
1584
1585           new_st.op = EXEC_LABEL_ASSIGN;
1586           new_st.label = label;
1587           new_st.expr = expr;
1588           return MATCH_YES;
1589         }
1590     }
1591   return MATCH_NO;
1592 }
1593
1594
1595 /* Match the GO TO statement.  As a computed GOTO statement is
1596    matched, it is transformed into an equivalent SELECT block.  No
1597    tree is necessary, and the resulting jumps-to-jumps are
1598    specifically optimized away by the back end.  */
1599
1600 match
1601 gfc_match_goto (void)
1602 {
1603   gfc_code *head, *tail;
1604   gfc_expr *expr;
1605   gfc_case *cp;
1606   gfc_st_label *label;
1607   int i;
1608   match m;
1609
1610   if (gfc_match (" %l%t", &label) == MATCH_YES)
1611     {
1612       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1613         return MATCH_ERROR;
1614
1615       new_st.op = EXEC_GOTO;
1616       new_st.label = label;
1617       return MATCH_YES;
1618     }
1619
1620   /* The assigned GO TO statement.  */
1621
1622   if (gfc_match_variable (&expr, 0) == MATCH_YES)
1623     {
1624       if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: Assigned GOTO "
1625                           "statement at %C")
1626           == FAILURE)
1627         return MATCH_ERROR;
1628
1629       new_st.op = EXEC_GOTO;
1630       new_st.expr = expr;
1631
1632       if (gfc_match_eos () == MATCH_YES)
1633         return MATCH_YES;
1634
1635       /* Match label list.  */
1636       gfc_match_char (',');
1637       if (gfc_match_char ('(') != MATCH_YES)
1638         {
1639           gfc_syntax_error (ST_GOTO);
1640           return MATCH_ERROR;
1641         }
1642       head = tail = NULL;
1643
1644       do
1645         {
1646           m = gfc_match_st_label (&label);
1647           if (m != MATCH_YES)
1648             goto syntax;
1649
1650           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1651             goto cleanup;
1652
1653           if (head == NULL)
1654             head = tail = gfc_get_code ();
1655           else
1656             {
1657               tail->block = gfc_get_code ();
1658               tail = tail->block;
1659             }
1660
1661           tail->label = label;
1662           tail->op = EXEC_GOTO;
1663         }
1664       while (gfc_match_char (',') == MATCH_YES);
1665
1666       if (gfc_match (")%t") != MATCH_YES)
1667         goto syntax;
1668
1669       if (head == NULL)
1670         {
1671            gfc_error ("Statement label list in GOTO at %C cannot be empty");
1672            goto syntax;
1673         }
1674       new_st.block = head;
1675
1676       return MATCH_YES;
1677     }
1678
1679   /* Last chance is a computed GO TO statement.  */
1680   if (gfc_match_char ('(') != MATCH_YES)
1681     {
1682       gfc_syntax_error (ST_GOTO);
1683       return MATCH_ERROR;
1684     }
1685
1686   head = tail = NULL;
1687   i = 1;
1688
1689   do
1690     {
1691       m = gfc_match_st_label (&label);
1692       if (m != MATCH_YES)
1693         goto syntax;
1694
1695       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1696         goto cleanup;
1697
1698       if (head == NULL)
1699         head = tail = gfc_get_code ();
1700       else
1701         {
1702           tail->block = gfc_get_code ();
1703           tail = tail->block;
1704         }
1705
1706       cp = gfc_get_case ();
1707       cp->low = cp->high = gfc_int_expr (i++);
1708
1709       tail->op = EXEC_SELECT;
1710       tail->ext.case_list = cp;
1711
1712       tail->next = gfc_get_code ();
1713       tail->next->op = EXEC_GOTO;
1714       tail->next->label = label;
1715     }
1716   while (gfc_match_char (',') == MATCH_YES);
1717
1718   if (gfc_match_char (')') != MATCH_YES)
1719     goto syntax;
1720
1721   if (head == NULL)
1722     {
1723       gfc_error ("Statement label list in GOTO at %C cannot be empty");
1724       goto syntax;
1725     }
1726
1727   /* Get the rest of the statement.  */
1728   gfc_match_char (',');
1729
1730   if (gfc_match (" %e%t", &expr) != MATCH_YES)
1731     goto syntax;
1732
1733   /* At this point, a computed GOTO has been fully matched and an
1734      equivalent SELECT statement constructed.  */
1735
1736   new_st.op = EXEC_SELECT;
1737   new_st.expr = NULL;
1738
1739   /* Hack: For a "real" SELECT, the expression is in expr. We put
1740      it in expr2 so we can distinguish then and produce the correct
1741      diagnostics.  */
1742   new_st.expr2 = expr;
1743   new_st.block = head;
1744   return MATCH_YES;
1745
1746 syntax:
1747   gfc_syntax_error (ST_GOTO);
1748 cleanup:
1749   gfc_free_statements (head);
1750   return MATCH_ERROR;
1751 }
1752
1753
1754 /* Frees a list of gfc_alloc structures.  */
1755
1756 void
1757 gfc_free_alloc_list (gfc_alloc *p)
1758 {
1759   gfc_alloc *q;
1760
1761   for (; p; p = q)
1762     {
1763       q = p->next;
1764       gfc_free_expr (p->expr);
1765       gfc_free (p);
1766     }
1767 }
1768
1769
1770 /* Match an ALLOCATE statement.  */
1771
1772 match
1773 gfc_match_allocate (void)
1774 {
1775   gfc_alloc *head, *tail;
1776   gfc_expr *stat;
1777   match m;
1778
1779   head = tail = NULL;
1780   stat = NULL;
1781
1782   if (gfc_match_char ('(') != MATCH_YES)
1783     goto syntax;
1784
1785   for (;;)
1786     {
1787       if (head == NULL)
1788         head = tail = gfc_get_alloc ();
1789       else
1790         {
1791           tail->next = gfc_get_alloc ();
1792           tail = tail->next;
1793         }
1794
1795       m = gfc_match_variable (&tail->expr, 0);
1796       if (m == MATCH_NO)
1797         goto syntax;
1798       if (m == MATCH_ERROR)
1799         goto cleanup;
1800
1801       if (gfc_check_do_variable (tail->expr->symtree))
1802         goto cleanup;
1803
1804       if (gfc_pure (NULL)
1805           && gfc_impure_variable (tail->expr->symtree->n.sym))
1806         {
1807           gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1808                      "PURE procedure");
1809           goto cleanup;
1810         }
1811
1812       if (tail->expr->ts.type == BT_DERIVED)
1813         tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
1814
1815       if (gfc_match_char (',') != MATCH_YES)
1816         break;
1817
1818       m = gfc_match (" stat = %v", &stat);
1819       if (m == MATCH_ERROR)
1820         goto cleanup;
1821       if (m == MATCH_YES)
1822         break;
1823     }
1824
1825   if (stat != NULL)
1826     {
1827       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1828         {
1829           gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot "
1830                      "be INTENT(IN)", stat->symtree->n.sym->name);
1831           goto cleanup;
1832         }
1833
1834       if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
1835         {
1836           gfc_error ("Illegal STAT variable in ALLOCATE statement at %C "
1837                      "for a PURE procedure");
1838           goto cleanup;
1839         }
1840
1841       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1842         {
1843           gfc_error ("STAT expression at %C must be a variable");
1844           goto cleanup;
1845         }
1846
1847       gfc_check_do_variable(stat->symtree);
1848     }
1849
1850   if (gfc_match (" )%t") != MATCH_YES)
1851     goto syntax;
1852
1853   new_st.op = EXEC_ALLOCATE;
1854   new_st.expr = stat;
1855   new_st.ext.alloc_list = head;
1856
1857   return MATCH_YES;
1858
1859 syntax:
1860   gfc_syntax_error (ST_ALLOCATE);
1861
1862 cleanup:
1863   gfc_free_expr (stat);
1864   gfc_free_alloc_list (head);
1865   return MATCH_ERROR;
1866 }
1867
1868
1869 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1870    a set of pointer assignments to intrinsic NULL().  */
1871
1872 match
1873 gfc_match_nullify (void)
1874 {
1875   gfc_code *tail;
1876   gfc_expr *e, *p;
1877   match m;
1878
1879   tail = NULL;
1880
1881   if (gfc_match_char ('(') != MATCH_YES)
1882     goto syntax;
1883
1884   for (;;)
1885     {
1886       m = gfc_match_variable (&p, 0);
1887       if (m == MATCH_ERROR)
1888         goto cleanup;
1889       if (m == MATCH_NO)
1890         goto syntax;
1891
1892       if (gfc_check_do_variable (p->symtree))
1893         goto cleanup;
1894
1895       if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
1896         {
1897           gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
1898           goto cleanup;
1899         }
1900
1901       /* build ' => NULL() '.  */
1902       e = gfc_get_expr ();
1903       e->where = gfc_current_locus;
1904       e->expr_type = EXPR_NULL;
1905       e->ts.type = BT_UNKNOWN;
1906
1907       /* Chain to list.  */
1908       if (tail == NULL)
1909         tail = &new_st;
1910       else
1911         {
1912           tail->next = gfc_get_code ();
1913           tail = tail->next;
1914         }
1915
1916       tail->op = EXEC_POINTER_ASSIGN;
1917       tail->expr = p;
1918       tail->expr2 = e;
1919
1920       if (gfc_match (" )%t") == MATCH_YES)
1921         break;
1922       if (gfc_match_char (',') != MATCH_YES)
1923         goto syntax;
1924     }
1925
1926   return MATCH_YES;
1927
1928 syntax:
1929   gfc_syntax_error (ST_NULLIFY);
1930
1931 cleanup:
1932   gfc_free_statements (new_st.next);
1933   return MATCH_ERROR;
1934 }
1935
1936
1937 /* Match a DEALLOCATE statement.  */
1938
1939 match
1940 gfc_match_deallocate (void)
1941 {
1942   gfc_alloc *head, *tail;
1943   gfc_expr *stat;
1944   match m;
1945
1946   head = tail = NULL;
1947   stat = NULL;
1948
1949   if (gfc_match_char ('(') != MATCH_YES)
1950     goto syntax;
1951
1952   for (;;)
1953     {
1954       if (head == NULL)
1955         head = tail = gfc_get_alloc ();
1956       else
1957         {
1958           tail->next = gfc_get_alloc ();
1959           tail = tail->next;
1960         }
1961
1962       m = gfc_match_variable (&tail->expr, 0);
1963       if (m == MATCH_ERROR)
1964         goto cleanup;
1965       if (m == MATCH_NO)
1966         goto syntax;
1967
1968       if (gfc_check_do_variable (tail->expr->symtree))
1969         goto cleanup;
1970
1971       if (gfc_pure (NULL)
1972           && gfc_impure_variable (tail->expr->symtree->n.sym))
1973         {
1974           gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
1975                      "for a PURE procedure");
1976           goto cleanup;
1977         }
1978
1979       if (gfc_match_char (',') != MATCH_YES)
1980         break;
1981
1982       m = gfc_match (" stat = %v", &stat);
1983       if (m == MATCH_ERROR)
1984         goto cleanup;
1985       if (m == MATCH_YES)
1986         break;
1987     }
1988
1989   if (stat != NULL)
1990     {
1991       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1992         {
1993           gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
1994                      "cannot be INTENT(IN)", stat->symtree->n.sym->name);
1995           goto cleanup;
1996         }
1997
1998       if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
1999         {
2000           gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
2001                      "for a PURE procedure");
2002           goto cleanup;
2003         }
2004
2005       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
2006         {
2007           gfc_error ("STAT expression at %C must be a variable");
2008           goto cleanup;
2009         }
2010
2011       gfc_check_do_variable(stat->symtree);
2012     }
2013
2014   if (gfc_match (" )%t") != MATCH_YES)
2015     goto syntax;
2016
2017   new_st.op = EXEC_DEALLOCATE;
2018   new_st.expr = stat;
2019   new_st.ext.alloc_list = head;
2020
2021   return MATCH_YES;
2022
2023 syntax:
2024   gfc_syntax_error (ST_DEALLOCATE);
2025
2026 cleanup:
2027   gfc_free_expr (stat);
2028   gfc_free_alloc_list (head);
2029   return MATCH_ERROR;
2030 }
2031
2032
2033 /* Match a RETURN statement.  */
2034
2035 match
2036 gfc_match_return (void)
2037 {
2038   gfc_expr *e;
2039   match m;
2040   gfc_compile_state s;
2041   int c;
2042
2043   e = NULL;
2044   if (gfc_match_eos () == MATCH_YES)
2045     goto done;
2046
2047   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2048     {
2049       gfc_error ("Alternate RETURN statement at %C is only allowed within "
2050                  "a SUBROUTINE");
2051       goto cleanup;
2052     }
2053
2054   if (gfc_current_form == FORM_FREE)
2055     {
2056       /* The following are valid, so we can't require a blank after the
2057         RETURN keyword:
2058           return+1
2059           return(1)  */
2060       c = gfc_peek_char ();
2061       if (ISALPHA (c) || ISDIGIT (c))
2062         return MATCH_NO;
2063     }
2064
2065   m = gfc_match (" %e%t", &e);
2066   if (m == MATCH_YES)
2067     goto done;
2068   if (m == MATCH_ERROR)
2069     goto cleanup;
2070
2071   gfc_syntax_error (ST_RETURN);
2072
2073 cleanup:
2074   gfc_free_expr (e);
2075   return MATCH_ERROR;
2076
2077 done:
2078   gfc_enclosing_unit (&s);
2079   if (s == COMP_PROGRAM
2080       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2081                         "main program at %C") == FAILURE)
2082       return MATCH_ERROR;
2083
2084   new_st.op = EXEC_RETURN;
2085   new_st.expr = e;
2086
2087   return MATCH_YES;
2088 }
2089
2090
2091 /* Match a CALL statement.  The tricky part here are possible
2092    alternate return specifiers.  We handle these by having all
2093    "subroutines" actually return an integer via a register that gives
2094    the return number.  If the call specifies alternate returns, we
2095    generate code for a SELECT statement whose case clauses contain
2096    GOTOs to the various labels.  */
2097
2098 match
2099 gfc_match_call (void)
2100 {
2101   char name[GFC_MAX_SYMBOL_LEN + 1];
2102   gfc_actual_arglist *a, *arglist;
2103   gfc_case *new_case;
2104   gfc_symbol *sym;
2105   gfc_symtree *st;
2106   gfc_code *c;
2107   match m;
2108   int i;
2109
2110   arglist = NULL;
2111
2112   m = gfc_match ("% %n", name);
2113   if (m == MATCH_NO)
2114     goto syntax;
2115   if (m != MATCH_YES)
2116     return m;
2117
2118   if (gfc_get_ha_sym_tree (name, &st))
2119     return MATCH_ERROR;
2120
2121   sym = st->n.sym;
2122   gfc_set_sym_referenced (sym);
2123
2124   if (!sym->attr.generic
2125       && !sym->attr.subroutine
2126       && gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2127     return MATCH_ERROR;
2128
2129   if (gfc_match_eos () != MATCH_YES)
2130     {
2131       m = gfc_match_actual_arglist (1, &arglist);
2132       if (m == MATCH_NO)
2133         goto syntax;
2134       if (m == MATCH_ERROR)
2135         goto cleanup;
2136
2137       if (gfc_match_eos () != MATCH_YES)
2138         goto syntax;
2139     }
2140
2141   /* If any alternate return labels were found, construct a SELECT
2142      statement that will jump to the right place.  */
2143
2144   i = 0;
2145   for (a = arglist; a; a = a->next)
2146     if (a->expr == NULL)
2147       i = 1;
2148
2149   if (i)
2150     {
2151       gfc_symtree *select_st;
2152       gfc_symbol *select_sym;
2153       char name[GFC_MAX_SYMBOL_LEN + 1];
2154
2155       new_st.next = c = gfc_get_code ();
2156       c->op = EXEC_SELECT;
2157       sprintf (name, "_result_%s", sym->name);
2158       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
2159
2160       select_sym = select_st->n.sym;
2161       select_sym->ts.type = BT_INTEGER;
2162       select_sym->ts.kind = gfc_default_integer_kind;
2163       gfc_set_sym_referenced (select_sym);
2164       c->expr = gfc_get_expr ();
2165       c->expr->expr_type = EXPR_VARIABLE;
2166       c->expr->symtree = select_st;
2167       c->expr->ts = select_sym->ts;
2168       c->expr->where = gfc_current_locus;
2169
2170       i = 0;
2171       for (a = arglist; a; a = a->next)
2172         {
2173           if (a->expr != NULL)
2174             continue;
2175
2176           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2177             continue;
2178
2179           i++;
2180
2181           c->block = gfc_get_code ();
2182           c = c->block;
2183           c->op = EXEC_SELECT;
2184
2185           new_case = gfc_get_case ();
2186           new_case->high = new_case->low = gfc_int_expr (i);
2187           c->ext.case_list = new_case;
2188
2189           c->next = gfc_get_code ();
2190           c->next->op = EXEC_GOTO;
2191           c->next->label = a->label;
2192         }
2193     }
2194
2195   new_st.op = EXEC_CALL;
2196   new_st.symtree = st;
2197   new_st.ext.actual = arglist;
2198
2199   return MATCH_YES;
2200
2201 syntax:
2202   gfc_syntax_error (ST_CALL);
2203
2204 cleanup:
2205   gfc_free_actual_arglist (arglist);
2206   return MATCH_ERROR;
2207 }
2208
2209
2210 /* Given a name, return a pointer to the common head structure,
2211    creating it if it does not exist. If FROM_MODULE is nonzero, we
2212    mangle the name so that it doesn't interfere with commons defined
2213    in the using namespace.
2214    TODO: Add to global symbol tree.  */
2215
2216 gfc_common_head *
2217 gfc_get_common (const char *name, int from_module)
2218 {
2219   gfc_symtree *st;
2220   static int serial = 0;
2221   char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
2222
2223   if (from_module)
2224     {
2225       /* A use associated common block is only needed to correctly layout
2226          the variables it contains.  */
2227       snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2228       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2229     }
2230   else
2231     {
2232       st = gfc_find_symtree (gfc_current_ns->common_root, name);
2233
2234       if (st == NULL)
2235         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2236     }
2237
2238   if (st->n.common == NULL)
2239     {
2240       st->n.common = gfc_get_common_head ();
2241       st->n.common->where = gfc_current_locus;
2242       strcpy (st->n.common->name, name);
2243     }
2244
2245   return st->n.common;
2246 }
2247
2248
2249 /* Match a common block name.  */
2250
2251 static match
2252 match_common_name (char *name)
2253 {
2254   match m;
2255
2256   if (gfc_match_char ('/') == MATCH_NO)
2257     {
2258       name[0] = '\0';
2259       return MATCH_YES;
2260     }
2261
2262   if (gfc_match_char ('/') == MATCH_YES)
2263     {
2264       name[0] = '\0';
2265       return MATCH_YES;
2266     }
2267
2268   m = gfc_match_name (name);
2269
2270   if (m == MATCH_ERROR)
2271     return MATCH_ERROR;
2272   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2273     return MATCH_YES;
2274
2275   gfc_error ("Syntax error in common block name at %C");
2276   return MATCH_ERROR;
2277 }
2278
2279
2280 /* Match a COMMON statement.  */
2281
2282 match
2283 gfc_match_common (void)
2284 {
2285   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2286   char name[GFC_MAX_SYMBOL_LEN + 1];
2287   gfc_common_head *t;
2288   gfc_array_spec *as;
2289   gfc_equiv *e1, *e2;
2290   match m;
2291   gfc_gsymbol *gsym;
2292
2293   old_blank_common = gfc_current_ns->blank_common.head;
2294   if (old_blank_common)
2295     {
2296       while (old_blank_common->common_next)
2297         old_blank_common = old_blank_common->common_next;
2298     }
2299
2300   as = NULL;
2301
2302   for (;;)
2303     {
2304       m = match_common_name (name);
2305       if (m == MATCH_ERROR)
2306         goto cleanup;
2307
2308       gsym = gfc_get_gsymbol (name);
2309       if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
2310         {
2311           gfc_error ("Symbol '%s' at %C is already an external symbol that "
2312                      "is not COMMON", name);
2313           goto cleanup;
2314         }
2315
2316       if (gsym->type == GSYM_UNKNOWN)
2317         {
2318           gsym->type = GSYM_COMMON;
2319           gsym->where = gfc_current_locus;
2320           gsym->defined = 1;
2321         }
2322
2323       gsym->used = 1;
2324
2325       if (name[0] == '\0')
2326         {
2327           if (gfc_current_ns->is_block_data)
2328             {
2329               gfc_warning ("BLOCK DATA unit cannot contain blank COMMON "
2330                            "at %C");
2331             }
2332           t = &gfc_current_ns->blank_common;
2333           if (t->head == NULL)
2334             t->where = gfc_current_locus;
2335         }
2336       else
2337         {
2338           t = gfc_get_common (name, 0);
2339         }
2340       head = &t->head;
2341
2342       if (*head == NULL)
2343         tail = NULL;
2344       else
2345         {
2346           tail = *head;
2347           while (tail->common_next)
2348             tail = tail->common_next;
2349         }
2350
2351       /* Grab the list of symbols.  */
2352       for (;;)
2353         {
2354           m = gfc_match_symbol (&sym, 0);
2355           if (m == MATCH_ERROR)
2356             goto cleanup;
2357           if (m == MATCH_NO)
2358             goto syntax;
2359
2360           if (sym->attr.in_common)
2361             {
2362               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2363                          sym->name);
2364               goto cleanup;
2365             }
2366
2367           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2368             goto cleanup;
2369
2370           if (sym->value != NULL
2371               && (name[0] == '\0' || !sym->attr.data))
2372             {
2373               if (name[0] == '\0')
2374                 gfc_error ("Previously initialized symbol '%s' in "
2375                            "blank COMMON block at %C", sym->name);
2376               else
2377                 gfc_error ("Previously initialized symbol '%s' in "
2378                            "COMMON block '%s' at %C", sym->name, name);
2379               goto cleanup;
2380             }
2381
2382           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2383             goto cleanup;
2384
2385           /* Derived type names must have the SEQUENCE attribute.  */
2386           if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2387             {
2388               gfc_error ("Derived type variable in COMMON at %C does not "
2389                          "have the SEQUENCE attribute");
2390               goto cleanup;
2391             }
2392
2393           if (tail != NULL)
2394             tail->common_next = sym;
2395           else
2396             *head = sym;
2397
2398           tail = sym;
2399
2400           /* Deal with an optional array specification after the
2401              symbol name.  */
2402           m = gfc_match_array_spec (&as);
2403           if (m == MATCH_ERROR)
2404             goto cleanup;
2405
2406           if (m == MATCH_YES)
2407             {
2408               if (as->type != AS_EXPLICIT)
2409                 {
2410                   gfc_error ("Array specification for symbol '%s' in COMMON "
2411                              "at %C must be explicit", sym->name);
2412                   goto cleanup;
2413                 }
2414
2415               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2416                 goto cleanup;
2417
2418               if (sym->attr.pointer)
2419                 {
2420                   gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
2421                              "POINTER array", sym->name);
2422                   goto cleanup;
2423                 }
2424
2425               sym->as = as;
2426               as = NULL;
2427
2428             }
2429
2430           sym->common_head = t;
2431
2432           /* Check to see if the symbol is already in an equivalence group.
2433              If it is, set the other members as being in common.  */
2434           if (sym->attr.in_equivalence)
2435             {
2436               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2437                 {
2438                   for (e2 = e1; e2; e2 = e2->eq)
2439                     if (e2->expr->symtree->n.sym == sym)
2440                       goto equiv_found;
2441
2442                   continue;
2443
2444           equiv_found:
2445
2446                   for (e2 = e1; e2; e2 = e2->eq)
2447                     {
2448                       other = e2->expr->symtree->n.sym;
2449                       if (other->common_head
2450                           && other->common_head != sym->common_head)
2451                         {
2452                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
2453                                      "%C is being indirectly equivalenced to "
2454                                      "another COMMON block '%s'",
2455                                      sym->name, sym->common_head->name,
2456                                      other->common_head->name);
2457                             goto cleanup;
2458                         }
2459                       other->attr.in_common = 1;
2460                       other->common_head = t;
2461                     }
2462                 }
2463             }
2464
2465
2466           gfc_gobble_whitespace ();
2467           if (gfc_match_eos () == MATCH_YES)
2468             goto done;
2469           if (gfc_peek_char () == '/')
2470             break;
2471           if (gfc_match_char (',') != MATCH_YES)
2472             goto syntax;
2473           gfc_gobble_whitespace ();
2474           if (gfc_peek_char () == '/')
2475             break;
2476         }
2477     }
2478
2479 done:
2480   return MATCH_YES;
2481
2482 syntax:
2483   gfc_syntax_error (ST_COMMON);
2484
2485 cleanup:
2486   if (old_blank_common)
2487     old_blank_common->common_next = NULL;
2488   else
2489     gfc_current_ns->blank_common.head = NULL;
2490   gfc_free_array_spec (as);
2491   return MATCH_ERROR;
2492 }
2493
2494
2495 /* Match a BLOCK DATA program unit.  */
2496
2497 match
2498 gfc_match_block_data (void)
2499 {
2500   char name[GFC_MAX_SYMBOL_LEN + 1];
2501   gfc_symbol *sym;
2502   match m;
2503
2504   if (gfc_match_eos () == MATCH_YES)
2505     {
2506       gfc_new_block = NULL;
2507       return MATCH_YES;
2508     }
2509
2510   m = gfc_match ("% %n%t", name);
2511   if (m != MATCH_YES)
2512     return MATCH_ERROR;
2513
2514   if (gfc_get_symbol (name, NULL, &sym))
2515     return MATCH_ERROR;
2516
2517   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2518     return MATCH_ERROR;
2519
2520   gfc_new_block = sym;
2521
2522   return MATCH_YES;
2523 }
2524
2525
2526 /* Free a namelist structure.  */
2527
2528 void
2529 gfc_free_namelist (gfc_namelist *name)
2530 {
2531   gfc_namelist *n;
2532
2533   for (; name; name = n)
2534     {
2535       n = name->next;
2536       gfc_free (name);
2537     }
2538 }
2539
2540
2541 /* Match a NAMELIST statement.  */
2542
2543 match
2544 gfc_match_namelist (void)
2545 {
2546   gfc_symbol *group_name, *sym;
2547   gfc_namelist *nl;
2548   match m, m2;
2549
2550   m = gfc_match (" / %s /", &group_name);
2551   if (m == MATCH_NO)
2552     goto syntax;
2553   if (m == MATCH_ERROR)
2554     goto error;
2555
2556   for (;;)
2557     {
2558       if (group_name->ts.type != BT_UNKNOWN)
2559         {
2560           gfc_error ("Namelist group name '%s' at %C already has a basic "
2561                      "type of %s", group_name->name,
2562                      gfc_typename (&group_name->ts));
2563           return MATCH_ERROR;
2564         }
2565
2566       if (group_name->attr.flavor == FL_NAMELIST
2567           && group_name->attr.use_assoc
2568           && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
2569                              "at %C already is USE associated and can"
2570                              "not be respecified.", group_name->name)
2571              == FAILURE)
2572         return MATCH_ERROR;
2573
2574       if (group_name->attr.flavor != FL_NAMELIST
2575           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2576                              group_name->name, NULL) == FAILURE)
2577         return MATCH_ERROR;
2578
2579       for (;;)
2580         {
2581           m = gfc_match_symbol (&sym, 1);
2582           if (m == MATCH_NO)
2583             goto syntax;
2584           if (m == MATCH_ERROR)
2585             goto error;
2586
2587           if (sym->attr.in_namelist == 0
2588               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
2589             goto error;
2590
2591           /* Use gfc_error_check here, rather than goto error, so that
2592              these are the only errors for the next two lines.  */
2593           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
2594             {
2595               gfc_error ("Assumed size array '%s' in namelist '%s' at "
2596                          "%C is not allowed", sym->name, group_name->name);
2597               gfc_error_check ();
2598             }
2599
2600           if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
2601             {
2602               gfc_error ("Assumed character length '%s' in namelist '%s' at "
2603                          "%C is not allowed", sym->name, group_name->name);
2604               gfc_error_check ();
2605             }
2606
2607           if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
2608               && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
2609                                  "namelist '%s' at %C is an extension.",
2610                                  sym->name, group_name->name) == FAILURE)
2611             gfc_error_check ();
2612
2613           nl = gfc_get_namelist ();
2614           nl->sym = sym;
2615           sym->refs++;
2616
2617           if (group_name->namelist == NULL)
2618             group_name->namelist = group_name->namelist_tail = nl;
2619           else
2620             {
2621               group_name->namelist_tail->next = nl;
2622               group_name->namelist_tail = nl;
2623             }
2624
2625           if (gfc_match_eos () == MATCH_YES)
2626             goto done;
2627
2628           m = gfc_match_char (',');
2629
2630           if (gfc_match_char ('/') == MATCH_YES)
2631             {
2632               m2 = gfc_match (" %s /", &group_name);
2633               if (m2 == MATCH_YES)
2634                 break;
2635               if (m2 == MATCH_ERROR)
2636                 goto error;
2637               goto syntax;
2638             }
2639
2640           if (m != MATCH_YES)
2641             goto syntax;
2642         }
2643     }
2644
2645 done:
2646   return MATCH_YES;
2647
2648 syntax:
2649   gfc_syntax_error (ST_NAMELIST);
2650
2651 error:
2652   return MATCH_ERROR;
2653 }
2654
2655
2656 /* Match a MODULE statement.  */
2657
2658 match
2659 gfc_match_module (void)
2660 {
2661   match m;
2662
2663   m = gfc_match (" %s%t", &gfc_new_block);
2664   if (m != MATCH_YES)
2665     return m;
2666
2667   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2668                       gfc_new_block->name, NULL) == FAILURE)
2669     return MATCH_ERROR;
2670
2671   return MATCH_YES;
2672 }
2673
2674
2675 /* Free equivalence sets and lists.  Recursively is the easiest way to
2676    do this.  */
2677
2678 void
2679 gfc_free_equiv (gfc_equiv *eq)
2680 {
2681   if (eq == NULL)
2682     return;
2683
2684   gfc_free_equiv (eq->eq);
2685   gfc_free_equiv (eq->next);
2686   gfc_free_expr (eq->expr);
2687   gfc_free (eq);
2688 }
2689
2690
2691 /* Match an EQUIVALENCE statement.  */
2692
2693 match
2694 gfc_match_equivalence (void)
2695 {
2696   gfc_equiv *eq, *set, *tail;
2697   gfc_ref *ref;
2698   gfc_symbol *sym;
2699   match m;
2700   gfc_common_head *common_head = NULL;
2701   bool common_flag;
2702   int cnt;
2703
2704   tail = NULL;
2705
2706   for (;;)
2707     {
2708       eq = gfc_get_equiv ();
2709       if (tail == NULL)
2710         tail = eq;
2711
2712       eq->next = gfc_current_ns->equiv;
2713       gfc_current_ns->equiv = eq;
2714
2715       if (gfc_match_char ('(') != MATCH_YES)
2716         goto syntax;
2717
2718       set = eq;
2719       common_flag = FALSE;
2720       cnt = 0;
2721
2722       for (;;)
2723         {
2724           m = gfc_match_equiv_variable (&set->expr);
2725           if (m == MATCH_ERROR)
2726             goto cleanup;
2727           if (m == MATCH_NO)
2728             goto syntax;
2729
2730           /*  count the number of objects.  */
2731           cnt++;
2732
2733           if (gfc_match_char ('%') == MATCH_YES)
2734             {
2735               gfc_error ("Derived type component %C is not a "
2736                          "permitted EQUIVALENCE member");
2737               goto cleanup;
2738             }
2739
2740           for (ref = set->expr->ref; ref; ref = ref->next)
2741             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2742               {
2743                 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
2744                            "be an array section");
2745                 goto cleanup;
2746               }
2747
2748           sym = set->expr->symtree->n.sym;
2749
2750           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
2751             goto cleanup;
2752
2753           if (sym->attr.in_common)
2754             {
2755               common_flag = TRUE;
2756               common_head = sym->common_head;
2757             }
2758
2759           if (gfc_match_char (')') == MATCH_YES)
2760             break;
2761
2762           if (gfc_match_char (',') != MATCH_YES)
2763             goto syntax;
2764
2765           set->eq = gfc_get_equiv ();
2766           set = set->eq;
2767         }
2768
2769       if (cnt < 2)
2770         {
2771           gfc_error ("EQUIVALENCE at %C requires two or more objects");
2772           goto cleanup;
2773         }
2774
2775       /* If one of the members of an equivalence is in common, then
2776          mark them all as being in common.  Before doing this, check
2777          that members of the equivalence group are not in different
2778          common blocks.  */
2779       if (common_flag)
2780         for (set = eq; set; set = set->eq)
2781           {
2782             sym = set->expr->symtree->n.sym;
2783             if (sym->common_head && sym->common_head != common_head)
2784               {
2785                 gfc_error ("Attempt to indirectly overlap COMMON "
2786                            "blocks %s and %s by EQUIVALENCE at %C",
2787                            sym->common_head->name, common_head->name);
2788                 goto cleanup;
2789               }
2790             sym->attr.in_common = 1;
2791             sym->common_head = common_head;
2792           }
2793
2794       if (gfc_match_eos () == MATCH_YES)
2795         break;
2796       if (gfc_match_char (',') != MATCH_YES)
2797         goto syntax;
2798     }
2799
2800   return MATCH_YES;
2801
2802 syntax:
2803   gfc_syntax_error (ST_EQUIVALENCE);
2804
2805 cleanup:
2806   eq = tail->next;
2807   tail->next = NULL;
2808
2809   gfc_free_equiv (gfc_current_ns->equiv);
2810   gfc_current_ns->equiv = eq;
2811
2812   return MATCH_ERROR;
2813 }
2814
2815
2816 /* Check that a statement function is not recursive. This is done by looking
2817    for the statement function symbol(sym) by looking recursively through its
2818    expression(e).  If a reference to sym is found, true is returned.
2819    12.5.4 requires that any variable of function that is implicitly typed
2820    shall have that type confirmed by any subsequent type declaration.  The
2821    implicit typing is conveniently done here.  */
2822
2823 static bool
2824 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
2825 {
2826   gfc_actual_arglist *arg;
2827   gfc_ref *ref;
2828   int i;
2829
2830   if (e == NULL)
2831     return false;
2832
2833   switch (e->expr_type)
2834     {
2835     case EXPR_FUNCTION:
2836       for (arg = e->value.function.actual; arg; arg = arg->next)
2837         {
2838           if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym))
2839             return true;
2840         }
2841
2842       if (e->symtree == NULL)
2843         return false;
2844
2845       /* Check the name before testing for nested recursion!  */
2846       if (sym->name == e->symtree->n.sym->name)
2847         return true;
2848
2849       /* Catch recursion via other statement functions.  */
2850       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
2851           && e->symtree->n.sym->value
2852           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
2853         return true;
2854
2855       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2856         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2857
2858       break;
2859
2860     case EXPR_VARIABLE:
2861       if (e->symtree && sym->name == e->symtree->n.sym->name)
2862         return true;
2863
2864       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2865         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2866       break;
2867
2868     case EXPR_OP:
2869       if (recursive_stmt_fcn (e->value.op.op1, sym)
2870           || recursive_stmt_fcn (e->value.op.op2, sym))
2871         return true;
2872       break;
2873
2874     default:
2875       break;
2876     }
2877
2878   /* Component references do not need to be checked.  */
2879   if (e->ref)
2880     {
2881       for (ref = e->ref; ref; ref = ref->next)
2882         {
2883           switch (ref->type)
2884             {
2885             case REF_ARRAY:
2886               for (i = 0; i < ref->u.ar.dimen; i++)
2887                 {
2888                   if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
2889                       || recursive_stmt_fcn (ref->u.ar.end[i], sym)
2890                       || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
2891                     return true;
2892                 }
2893               break;
2894
2895             case REF_SUBSTRING:
2896               if (recursive_stmt_fcn (ref->u.ss.start, sym)
2897                   || recursive_stmt_fcn (ref->u.ss.end, sym))
2898                 return true;
2899
2900               break;
2901
2902             default:
2903               break;
2904             }
2905         }
2906     }
2907   return false;
2908 }
2909
2910
2911 /* Match a statement function declaration.  It is so easy to match
2912    non-statement function statements with a MATCH_ERROR as opposed to
2913    MATCH_NO that we suppress error message in most cases.  */
2914
2915 match
2916 gfc_match_st_function (void)
2917 {
2918   gfc_error_buf old_error;
2919   gfc_symbol *sym;
2920   gfc_expr *expr;
2921   match m;
2922
2923   m = gfc_match_symbol (&sym, 0);
2924   if (m != MATCH_YES)
2925     return m;
2926
2927   gfc_push_error (&old_error);
2928
2929   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
2930                          sym->name, NULL) == FAILURE)
2931     goto undo_error;
2932
2933   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2934     goto undo_error;
2935
2936   m = gfc_match (" = %e%t", &expr);
2937   if (m == MATCH_NO)
2938     goto undo_error;
2939
2940   gfc_free_error (&old_error);
2941   if (m == MATCH_ERROR)
2942     return m;
2943
2944   if (recursive_stmt_fcn (expr, sym))
2945     {
2946       gfc_error ("Statement function at %L is recursive", &expr->where);
2947       return MATCH_ERROR;
2948     }
2949
2950   sym->value = expr;
2951
2952   return MATCH_YES;
2953
2954 undo_error:
2955   gfc_pop_error (&old_error);
2956   return MATCH_NO;
2957 }
2958
2959
2960 /***************** SELECT CASE subroutines ******************/
2961
2962 /* Free a single case structure.  */
2963
2964 static void
2965 free_case (gfc_case *p)
2966 {
2967   if (p->low == p->high)
2968     p->high = NULL;
2969   gfc_free_expr (p->low);
2970   gfc_free_expr (p->high);
2971   gfc_free (p);
2972 }
2973
2974
2975 /* Free a list of case structures.  */
2976
2977 void
2978 gfc_free_case_list (gfc_case *p)
2979 {
2980   gfc_case *q;
2981
2982   for (; p; p = q)
2983     {
2984       q = p->next;
2985       free_case (p);
2986     }
2987 }
2988
2989
2990 /* Match a single case selector.  */
2991
2992 static match
2993 match_case_selector (gfc_case **cp)
2994 {
2995   gfc_case *c;
2996   match m;
2997
2998   c = gfc_get_case ();
2999   c->where = gfc_current_locus;
3000
3001   if (gfc_match_char (':') == MATCH_YES)
3002     {
3003       m = gfc_match_init_expr (&c->high);
3004       if (m == MATCH_NO)
3005         goto need_expr;
3006       if (m == MATCH_ERROR)
3007         goto cleanup;
3008     }
3009   else
3010     {
3011       m = gfc_match_init_expr (&c->low);
3012       if (m == MATCH_ERROR)
3013         goto cleanup;
3014       if (m == MATCH_NO)
3015         goto need_expr;
3016
3017       /* If we're not looking at a ':' now, make a range out of a single
3018          target.  Else get the upper bound for the case range.  */
3019       if (gfc_match_char (':') != MATCH_YES)
3020         c->high = c->low;
3021       else
3022         {
3023           m = gfc_match_init_expr (&c->high);
3024           if (m == MATCH_ERROR)
3025             goto cleanup;
3026           /* MATCH_NO is fine.  It's OK if nothing is there!  */
3027         }
3028     }
3029
3030   *cp = c;
3031   return MATCH_YES;
3032
3033 need_expr:
3034   gfc_error ("Expected initialization expression in CASE at %C");
3035
3036 cleanup:
3037   free_case (c);
3038   return MATCH_ERROR;
3039 }
3040
3041
3042 /* Match the end of a case statement.  */
3043
3044 static match
3045 match_case_eos (void)
3046 {
3047   char name[GFC_MAX_SYMBOL_LEN + 1];
3048   match m;
3049
3050   if (gfc_match_eos () == MATCH_YES)
3051     return MATCH_YES;
3052
3053   /* If the case construct doesn't have a case-construct-name, we
3054      should have matched the EOS.  */
3055   if (!gfc_current_block ())
3056     {
3057       gfc_error ("Expected the name of the SELECT CASE construct at %C");
3058       return MATCH_ERROR;
3059     }
3060
3061   gfc_gobble_whitespace ();
3062
3063   m = gfc_match_name (name);
3064   if (m != MATCH_YES)
3065     return m;
3066
3067   if (strcmp (name, gfc_current_block ()->name) != 0)
3068     {
3069       gfc_error ("Expected case name of '%s' at %C",
3070                  gfc_current_block ()->name);
3071       return MATCH_ERROR;
3072     }
3073
3074   return gfc_match_eos ();
3075 }
3076
3077
3078 /* Match a SELECT statement.  */
3079
3080 match
3081 gfc_match_select (void)
3082 {
3083   gfc_expr *expr;
3084   match m;
3085
3086   m = gfc_match_label ();
3087   if (m == MATCH_ERROR)
3088     return m;
3089
3090   m = gfc_match (" select case ( %e )%t", &expr);
3091   if (m != MATCH_YES)
3092     return m;
3093
3094   new_st.op = EXEC_SELECT;
3095   new_st.expr = expr;
3096
3097   return MATCH_YES;
3098 }
3099
3100
3101 /* Match a CASE statement.  */
3102
3103 match
3104 gfc_match_case (void)
3105 {
3106   gfc_case *c, *head, *tail;
3107   match m;
3108
3109   head = tail = NULL;
3110
3111   if (gfc_current_state () != COMP_SELECT)
3112     {
3113       gfc_error ("Unexpected CASE statement at %C");
3114       return MATCH_ERROR;
3115     }
3116
3117   if (gfc_match ("% default") == MATCH_YES)
3118     {
3119       m = match_case_eos ();
3120       if (m == MATCH_NO)
3121         goto syntax;
3122       if (m == MATCH_ERROR)
3123         goto cleanup;
3124
3125       new_st.op = EXEC_SELECT;
3126       c = gfc_get_case ();
3127       c->where = gfc_current_locus;
3128       new_st.ext.case_list = c;
3129       return MATCH_YES;
3130     }
3131
3132   if (gfc_match_char ('(') != MATCH_YES)
3133     goto syntax;
3134
3135   for (;;)
3136     {
3137       if (match_case_selector (&c) == MATCH_ERROR)
3138         goto cleanup;
3139
3140       if (head == NULL)
3141         head = c;
3142       else
3143         tail->next = c;
3144
3145       tail = c;
3146
3147       if (gfc_match_char (')') == MATCH_YES)
3148         break;
3149       if (gfc_match_char (',') != MATCH_YES)
3150         goto syntax;
3151     }
3152
3153   m = match_case_eos ();
3154   if (m == MATCH_NO)
3155     goto syntax;
3156   if (m == MATCH_ERROR)
3157     goto cleanup;
3158
3159   new_st.op = EXEC_SELECT;
3160   new_st.ext.case_list = head;
3161
3162   return MATCH_YES;
3163
3164 syntax:
3165   gfc_error ("Syntax error in CASE-specification at %C");
3166
3167 cleanup:
3168   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
3169   return MATCH_ERROR;
3170 }
3171
3172 /********************* WHERE subroutines ********************/
3173
3174 /* Match the rest of a simple WHERE statement that follows an IF statement.
3175  */
3176
3177 static match
3178 match_simple_where (void)
3179 {
3180   gfc_expr *expr;
3181   gfc_code *c;
3182   match m;
3183
3184   m = gfc_match (" ( %e )", &expr);
3185   if (m != MATCH_YES)
3186     return m;
3187
3188   m = gfc_match_assignment ();
3189   if (m == MATCH_NO)
3190     goto syntax;
3191   if (m == MATCH_ERROR)
3192     goto cleanup;
3193
3194   if (gfc_match_eos () != MATCH_YES)
3195     goto syntax;
3196
3197   c = gfc_get_code ();
3198
3199   c->op = EXEC_WHERE;
3200   c->expr = expr;
3201   c->next = gfc_get_code ();
3202
3203   *c->next = new_st;
3204   gfc_clear_new_st ();
3205
3206   new_st.op = EXEC_WHERE;
3207   new_st.block = c;
3208
3209   return MATCH_YES;
3210
3211 syntax:
3212   gfc_syntax_error (ST_WHERE);
3213
3214 cleanup:
3215   gfc_free_expr (expr);
3216   return MATCH_ERROR;
3217 }
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 }