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