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