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