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       if (!(sym->attr.external && !sym->attr.referenced))
2337         {
2338           /* ...create a symbol in this scope...  */
2339           if (sym->ns != gfc_current_ns
2340                 && gfc_get_sym_tree (name, NULL, &st) == 1)
2341             return MATCH_ERROR;
2342
2343           if (sym != st->n.sym)
2344             sym = st->n.sym;
2345         }
2346
2347       /* ...and then to try to make the symbol into a subroutine.  */
2348       if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2349         return MATCH_ERROR;
2350     }
2351
2352   gfc_set_sym_referenced (sym);
2353
2354   if (gfc_match_eos () != MATCH_YES)
2355     {
2356       m = gfc_match_actual_arglist (1, &arglist);
2357       if (m == MATCH_NO)
2358         goto syntax;
2359       if (m == MATCH_ERROR)
2360         goto cleanup;
2361
2362       if (gfc_match_eos () != MATCH_YES)
2363         goto syntax;
2364     }
2365
2366   /* If any alternate return labels were found, construct a SELECT
2367      statement that will jump to the right place.  */
2368
2369   i = 0;
2370   for (a = arglist; a; a = a->next)
2371     if (a->expr == NULL)
2372       i = 1;
2373
2374   if (i)
2375     {
2376       gfc_symtree *select_st;
2377       gfc_symbol *select_sym;
2378       char name[GFC_MAX_SYMBOL_LEN + 1];
2379
2380       new_st.next = c = gfc_get_code ();
2381       c->op = EXEC_SELECT;
2382       sprintf (name, "_result_%s", sym->name);
2383       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
2384
2385       select_sym = select_st->n.sym;
2386       select_sym->ts.type = BT_INTEGER;
2387       select_sym->ts.kind = gfc_default_integer_kind;
2388       gfc_set_sym_referenced (select_sym);
2389       c->expr = gfc_get_expr ();
2390       c->expr->expr_type = EXPR_VARIABLE;
2391       c->expr->symtree = select_st;
2392       c->expr->ts = select_sym->ts;
2393       c->expr->where = gfc_current_locus;
2394
2395       i = 0;
2396       for (a = arglist; a; a = a->next)
2397         {
2398           if (a->expr != NULL)
2399             continue;
2400
2401           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2402             continue;
2403
2404           i++;
2405
2406           c->block = gfc_get_code ();
2407           c = c->block;
2408           c->op = EXEC_SELECT;
2409
2410           new_case = gfc_get_case ();
2411           new_case->high = new_case->low = gfc_int_expr (i);
2412           c->ext.case_list = new_case;
2413
2414           c->next = gfc_get_code ();
2415           c->next->op = EXEC_GOTO;
2416           c->next->label = a->label;
2417         }
2418     }
2419
2420   new_st.op = EXEC_CALL;
2421   new_st.symtree = st;
2422   new_st.ext.actual = arglist;
2423
2424   return MATCH_YES;
2425
2426 syntax:
2427   gfc_syntax_error (ST_CALL);
2428
2429 cleanup:
2430   gfc_free_actual_arglist (arglist);
2431   return MATCH_ERROR;
2432 }
2433
2434
2435 /* Given a name, return a pointer to the common head structure,
2436    creating it if it does not exist. If FROM_MODULE is nonzero, we
2437    mangle the name so that it doesn't interfere with commons defined
2438    in the using namespace.
2439    TODO: Add to global symbol tree.  */
2440
2441 gfc_common_head *
2442 gfc_get_common (const char *name, int from_module)
2443 {
2444   gfc_symtree *st;
2445   static int serial = 0;
2446   char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
2447
2448   if (from_module)
2449     {
2450       /* A use associated common block is only needed to correctly layout
2451          the variables it contains.  */
2452       snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2453       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2454     }
2455   else
2456     {
2457       st = gfc_find_symtree (gfc_current_ns->common_root, name);
2458
2459       if (st == NULL)
2460         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2461     }
2462
2463   if (st->n.common == NULL)
2464     {
2465       st->n.common = gfc_get_common_head ();
2466       st->n.common->where = gfc_current_locus;
2467       strcpy (st->n.common->name, name);
2468     }
2469
2470   return st->n.common;
2471 }
2472
2473
2474 /* Match a common block name.  */
2475
2476 match match_common_name (char *name)
2477 {
2478   match m;
2479
2480   if (gfc_match_char ('/') == MATCH_NO)
2481     {
2482       name[0] = '\0';
2483       return MATCH_YES;
2484     }
2485
2486   if (gfc_match_char ('/') == MATCH_YES)
2487     {
2488       name[0] = '\0';
2489       return MATCH_YES;
2490     }
2491
2492   m = gfc_match_name (name);
2493
2494   if (m == MATCH_ERROR)
2495     return MATCH_ERROR;
2496   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2497     return MATCH_YES;
2498
2499   gfc_error ("Syntax error in common block name at %C");
2500   return MATCH_ERROR;
2501 }
2502
2503
2504 /* Match a COMMON statement.  */
2505
2506 match
2507 gfc_match_common (void)
2508 {
2509   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2510   char name[GFC_MAX_SYMBOL_LEN + 1];
2511   gfc_common_head *t;
2512   gfc_array_spec *as;
2513   gfc_equiv *e1, *e2;
2514   match m;
2515   gfc_gsymbol *gsym;
2516
2517   old_blank_common = gfc_current_ns->blank_common.head;
2518   if (old_blank_common)
2519     {
2520       while (old_blank_common->common_next)
2521         old_blank_common = old_blank_common->common_next;
2522     }
2523
2524   as = NULL;
2525
2526   for (;;)
2527     {
2528       m = match_common_name (name);
2529       if (m == MATCH_ERROR)
2530         goto cleanup;
2531
2532       gsym = gfc_get_gsymbol (name);
2533       if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
2534         {
2535           gfc_error ("Symbol '%s' at %C is already an external symbol that "
2536                      "is not COMMON", name);
2537           goto cleanup;
2538         }
2539
2540       if (gsym->type == GSYM_UNKNOWN)
2541         {
2542           gsym->type = GSYM_COMMON;
2543           gsym->where = gfc_current_locus;
2544           gsym->defined = 1;
2545         }
2546
2547       gsym->used = 1;
2548
2549       if (name[0] == '\0')
2550         {
2551           if (gfc_current_ns->is_block_data)
2552             {
2553               gfc_warning ("BLOCK DATA unit cannot contain blank COMMON "
2554                            "at %C");
2555             }
2556           t = &gfc_current_ns->blank_common;
2557           if (t->head == NULL)
2558             t->where = gfc_current_locus;
2559         }
2560       else
2561         {
2562           t = gfc_get_common (name, 0);
2563         }
2564       head = &t->head;
2565
2566       if (*head == NULL)
2567         tail = NULL;
2568       else
2569         {
2570           tail = *head;
2571           while (tail->common_next)
2572             tail = tail->common_next;
2573         }
2574
2575       /* Grab the list of symbols.  */
2576       for (;;)
2577         {
2578           m = gfc_match_symbol (&sym, 0);
2579           if (m == MATCH_ERROR)
2580             goto cleanup;
2581           if (m == MATCH_NO)
2582             goto syntax;
2583
2584           /* Store a ref to the common block for error checking.  */
2585           sym->common_block = t;
2586
2587           /* See if we know the current common block is bind(c), and if
2588              so, then see if we can check if the symbol is (which it'll
2589              need to be).  This can happen if the bind(c) attr stmt was
2590              applied to the common block, and the variable(s) already
2591              defined, before declaring the common block.  */
2592           if (t->is_bind_c == 1)
2593             {
2594               if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
2595                 {
2596                   /* If we find an error, just print it and continue,
2597                      cause it's just semantic, and we can see if there
2598                      are more errors.  */
2599                   gfc_error_now ("Variable '%s' at %L in common block '%s' "
2600                                  "at %C must be declared with a C "
2601                                  "interoperable kind since common block "
2602                                  "'%s' is bind(c)",
2603                                  sym->name, &(sym->declared_at), t->name,
2604                                  t->name);
2605                 }
2606
2607               if (sym->attr.is_bind_c == 1)
2608                 gfc_error_now ("Variable '%s' in common block "
2609                                "'%s' at %C can not be bind(c) since "
2610                                "it is not global", sym->name, t->name);
2611             }
2612
2613           if (sym->attr.in_common)
2614             {
2615               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2616                          sym->name);
2617               goto cleanup;
2618             }
2619
2620           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2621             goto cleanup;
2622
2623           if (sym->value != NULL && sym->value->expr_type != EXPR_NULL
2624               && (name[0] == '\0' || !sym->attr.data))
2625             {
2626               if (name[0] == '\0')
2627                 gfc_error ("Previously initialized symbol '%s' in "
2628                            "blank COMMON block at %C", sym->name);
2629               else
2630                 gfc_error ("Previously initialized symbol '%s' in "
2631                            "COMMON block '%s' at %C", sym->name, name);
2632               goto cleanup;
2633             }
2634
2635           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2636             goto cleanup;
2637
2638           /* Derived type names must have the SEQUENCE attribute.  */
2639           if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2640             {
2641               gfc_error ("Derived type variable in COMMON at %C does not "
2642                          "have the SEQUENCE attribute");
2643               goto cleanup;
2644             }
2645
2646           if (tail != NULL)
2647             tail->common_next = sym;
2648           else
2649             *head = sym;
2650
2651           tail = sym;
2652
2653           /* Deal with an optional array specification after the
2654              symbol name.  */
2655           m = gfc_match_array_spec (&as);
2656           if (m == MATCH_ERROR)
2657             goto cleanup;
2658
2659           if (m == MATCH_YES)
2660             {
2661               if (as->type != AS_EXPLICIT)
2662                 {
2663                   gfc_error ("Array specification for symbol '%s' in COMMON "
2664                              "at %C must be explicit", sym->name);
2665                   goto cleanup;
2666                 }
2667
2668               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2669                 goto cleanup;
2670
2671               if (sym->attr.pointer)
2672                 {
2673                   gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
2674                              "POINTER array", sym->name);
2675                   goto cleanup;
2676                 }
2677
2678               sym->as = as;
2679               as = NULL;
2680
2681             }
2682
2683           sym->common_head = t;
2684
2685           /* Check to see if the symbol is already in an equivalence group.
2686              If it is, set the other members as being in common.  */
2687           if (sym->attr.in_equivalence)
2688             {
2689               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2690                 {
2691                   for (e2 = e1; e2; e2 = e2->eq)
2692                     if (e2->expr->symtree->n.sym == sym)
2693                       goto equiv_found;
2694
2695                   continue;
2696
2697           equiv_found:
2698
2699                   for (e2 = e1; e2; e2 = e2->eq)
2700                     {
2701                       other = e2->expr->symtree->n.sym;
2702                       if (other->common_head
2703                           && other->common_head != sym->common_head)
2704                         {
2705                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
2706                                      "%C is being indirectly equivalenced to "
2707                                      "another COMMON block '%s'",
2708                                      sym->name, sym->common_head->name,
2709                                      other->common_head->name);
2710                             goto cleanup;
2711                         }
2712                       other->attr.in_common = 1;
2713                       other->common_head = t;
2714                     }
2715                 }
2716             }
2717
2718
2719           gfc_gobble_whitespace ();
2720           if (gfc_match_eos () == MATCH_YES)
2721             goto done;
2722           if (gfc_peek_char () == '/')
2723             break;
2724           if (gfc_match_char (',') != MATCH_YES)
2725             goto syntax;
2726           gfc_gobble_whitespace ();
2727           if (gfc_peek_char () == '/')
2728             break;
2729         }
2730     }
2731
2732 done:
2733   return MATCH_YES;
2734
2735 syntax:
2736   gfc_syntax_error (ST_COMMON);
2737
2738 cleanup:
2739   if (old_blank_common)
2740     old_blank_common->common_next = NULL;
2741   else
2742     gfc_current_ns->blank_common.head = NULL;
2743   gfc_free_array_spec (as);
2744   return MATCH_ERROR;
2745 }
2746
2747
2748 /* Match a BLOCK DATA program unit.  */
2749
2750 match
2751 gfc_match_block_data (void)
2752 {
2753   char name[GFC_MAX_SYMBOL_LEN + 1];
2754   gfc_symbol *sym;
2755   match m;
2756
2757   if (gfc_match_eos () == MATCH_YES)
2758     {
2759       gfc_new_block = NULL;
2760       return MATCH_YES;
2761     }
2762
2763   m = gfc_match ("% %n%t", name);
2764   if (m != MATCH_YES)
2765     return MATCH_ERROR;
2766
2767   if (gfc_get_symbol (name, NULL, &sym))
2768     return MATCH_ERROR;
2769
2770   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2771     return MATCH_ERROR;
2772
2773   gfc_new_block = sym;
2774
2775   return MATCH_YES;
2776 }
2777
2778
2779 /* Free a namelist structure.  */
2780
2781 void
2782 gfc_free_namelist (gfc_namelist *name)
2783 {
2784   gfc_namelist *n;
2785
2786   for (; name; name = n)
2787     {
2788       n = name->next;
2789       gfc_free (name);
2790     }
2791 }
2792
2793
2794 /* Match a NAMELIST statement.  */
2795
2796 match
2797 gfc_match_namelist (void)
2798 {
2799   gfc_symbol *group_name, *sym;
2800   gfc_namelist *nl;
2801   match m, m2;
2802
2803   m = gfc_match (" / %s /", &group_name);
2804   if (m == MATCH_NO)
2805     goto syntax;
2806   if (m == MATCH_ERROR)
2807     goto error;
2808
2809   for (;;)
2810     {
2811       if (group_name->ts.type != BT_UNKNOWN)
2812         {
2813           gfc_error ("Namelist group name '%s' at %C already has a basic "
2814                      "type of %s", group_name->name,
2815                      gfc_typename (&group_name->ts));
2816           return MATCH_ERROR;
2817         }
2818
2819       if (group_name->attr.flavor == FL_NAMELIST
2820           && group_name->attr.use_assoc
2821           && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
2822                              "at %C already is USE associated and can"
2823                              "not be respecified.", group_name->name)
2824              == FAILURE)
2825         return MATCH_ERROR;
2826
2827       if (group_name->attr.flavor != FL_NAMELIST
2828           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2829                              group_name->name, NULL) == FAILURE)
2830         return MATCH_ERROR;
2831
2832       for (;;)
2833         {
2834           m = gfc_match_symbol (&sym, 1);
2835           if (m == MATCH_NO)
2836             goto syntax;
2837           if (m == MATCH_ERROR)
2838             goto error;
2839
2840           if (sym->attr.in_namelist == 0
2841               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
2842             goto error;
2843
2844           /* Use gfc_error_check here, rather than goto error, so that
2845              these are the only errors for the next two lines.  */
2846           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
2847             {
2848               gfc_error ("Assumed size array '%s' in namelist '%s' at "
2849                          "%C is not allowed", sym->name, group_name->name);
2850               gfc_error_check ();
2851             }
2852
2853           if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
2854             {
2855               gfc_error ("Assumed character length '%s' in namelist '%s' at "
2856                          "%C is not allowed", sym->name, group_name->name);
2857               gfc_error_check ();
2858             }
2859
2860           nl = gfc_get_namelist ();
2861           nl->sym = sym;
2862           sym->refs++;
2863
2864           if (group_name->namelist == NULL)
2865             group_name->namelist = group_name->namelist_tail = nl;
2866           else
2867             {
2868               group_name->namelist_tail->next = nl;
2869               group_name->namelist_tail = nl;
2870             }
2871
2872           if (gfc_match_eos () == MATCH_YES)
2873             goto done;
2874
2875           m = gfc_match_char (',');
2876
2877           if (gfc_match_char ('/') == MATCH_YES)
2878             {
2879               m2 = gfc_match (" %s /", &group_name);
2880               if (m2 == MATCH_YES)
2881                 break;
2882               if (m2 == MATCH_ERROR)
2883                 goto error;
2884               goto syntax;
2885             }
2886
2887           if (m != MATCH_YES)
2888             goto syntax;
2889         }
2890     }
2891
2892 done:
2893   return MATCH_YES;
2894
2895 syntax:
2896   gfc_syntax_error (ST_NAMELIST);
2897
2898 error:
2899   return MATCH_ERROR;
2900 }
2901
2902
2903 /* Match a MODULE statement.  */
2904
2905 match
2906 gfc_match_module (void)
2907 {
2908   match m;
2909
2910   m = gfc_match (" %s%t", &gfc_new_block);
2911   if (m != MATCH_YES)
2912     return m;
2913
2914   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2915                       gfc_new_block->name, NULL) == FAILURE)
2916     return MATCH_ERROR;
2917
2918   return MATCH_YES;
2919 }
2920
2921
2922 /* Free equivalence sets and lists.  Recursively is the easiest way to
2923    do this.  */
2924
2925 void
2926 gfc_free_equiv (gfc_equiv *eq)
2927 {
2928   if (eq == NULL)
2929     return;
2930
2931   gfc_free_equiv (eq->eq);
2932   gfc_free_equiv (eq->next);
2933   gfc_free_expr (eq->expr);
2934   gfc_free (eq);
2935 }
2936
2937
2938 /* Match an EQUIVALENCE statement.  */
2939
2940 match
2941 gfc_match_equivalence (void)
2942 {
2943   gfc_equiv *eq, *set, *tail;
2944   gfc_ref *ref;
2945   gfc_symbol *sym;
2946   match m;
2947   gfc_common_head *common_head = NULL;
2948   bool common_flag;
2949   int cnt;
2950
2951   tail = NULL;
2952
2953   for (;;)
2954     {
2955       eq = gfc_get_equiv ();
2956       if (tail == NULL)
2957         tail = eq;
2958
2959       eq->next = gfc_current_ns->equiv;
2960       gfc_current_ns->equiv = eq;
2961
2962       if (gfc_match_char ('(') != MATCH_YES)
2963         goto syntax;
2964
2965       set = eq;
2966       common_flag = FALSE;
2967       cnt = 0;
2968
2969       for (;;)
2970         {
2971           m = gfc_match_equiv_variable (&set->expr);
2972           if (m == MATCH_ERROR)
2973             goto cleanup;
2974           if (m == MATCH_NO)
2975             goto syntax;
2976
2977           /*  count the number of objects.  */
2978           cnt++;
2979
2980           if (gfc_match_char ('%') == MATCH_YES)
2981             {
2982               gfc_error ("Derived type component %C is not a "
2983                          "permitted EQUIVALENCE member");
2984               goto cleanup;
2985             }
2986
2987           for (ref = set->expr->ref; ref; ref = ref->next)
2988             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2989               {
2990                 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
2991                            "be an array section");
2992                 goto cleanup;
2993               }
2994
2995           sym = set->expr->symtree->n.sym;
2996
2997           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
2998             goto cleanup;
2999
3000           if (sym->attr.in_common)
3001             {
3002               common_flag = TRUE;
3003               common_head = sym->common_head;
3004             }
3005
3006           if (gfc_match_char (')') == MATCH_YES)
3007             break;
3008
3009           if (gfc_match_char (',') != MATCH_YES)
3010             goto syntax;
3011
3012           set->eq = gfc_get_equiv ();
3013           set = set->eq;
3014         }
3015
3016       if (cnt < 2)
3017         {
3018           gfc_error ("EQUIVALENCE at %C requires two or more objects");
3019           goto cleanup;
3020         }
3021
3022       /* If one of the members of an equivalence is in common, then
3023          mark them all as being in common.  Before doing this, check
3024          that members of the equivalence group are not in different
3025          common blocks.  */
3026       if (common_flag)
3027         for (set = eq; set; set = set->eq)
3028           {
3029             sym = set->expr->symtree->n.sym;
3030             if (sym->common_head && sym->common_head != common_head)
3031               {
3032                 gfc_error ("Attempt to indirectly overlap COMMON "
3033                            "blocks %s and %s by EQUIVALENCE at %C",
3034                            sym->common_head->name, common_head->name);
3035                 goto cleanup;
3036               }
3037             sym->attr.in_common = 1;
3038             sym->common_head = common_head;
3039           }
3040
3041       if (gfc_match_eos () == MATCH_YES)
3042         break;
3043       if (gfc_match_char (',') != MATCH_YES)
3044         goto syntax;
3045     }
3046
3047   return MATCH_YES;
3048
3049 syntax:
3050   gfc_syntax_error (ST_EQUIVALENCE);
3051
3052 cleanup:
3053   eq = tail->next;
3054   tail->next = NULL;
3055
3056   gfc_free_equiv (gfc_current_ns->equiv);
3057   gfc_current_ns->equiv = eq;
3058
3059   return MATCH_ERROR;
3060 }
3061
3062
3063 /* Check that a statement function is not recursive. This is done by looking
3064    for the statement function symbol(sym) by looking recursively through its
3065    expression(e).  If a reference to sym is found, true is returned.
3066    12.5.4 requires that any variable of function that is implicitly typed
3067    shall have that type confirmed by any subsequent type declaration.  The
3068    implicit typing is conveniently done here.  */
3069
3070 static bool
3071 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
3072 {
3073   gfc_actual_arglist *arg;
3074   gfc_ref *ref;
3075   int i;
3076
3077   if (e == NULL)
3078     return false;
3079
3080   switch (e->expr_type)
3081     {
3082     case EXPR_FUNCTION:
3083       for (arg = e->value.function.actual; arg; arg = arg->next)
3084         {
3085           if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym))
3086             return true;
3087         }
3088
3089       if (e->symtree == NULL)
3090         return false;
3091
3092       /* Check the name before testing for nested recursion!  */
3093       if (sym->name == e->symtree->n.sym->name)
3094         return true;
3095
3096       /* Catch recursion via other statement functions.  */
3097       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
3098           && e->symtree->n.sym->value
3099           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
3100         return true;
3101
3102       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3103         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3104
3105       break;
3106
3107     case EXPR_VARIABLE:
3108       if (e->symtree && sym->name == e->symtree->n.sym->name)
3109         return true;
3110
3111       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3112         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3113       break;
3114
3115     case EXPR_OP:
3116       if (recursive_stmt_fcn (e->value.op.op1, sym)
3117           || recursive_stmt_fcn (e->value.op.op2, sym))
3118         return true;
3119       break;
3120
3121     default:
3122       break;
3123     }
3124
3125   /* Component references do not need to be checked.  */
3126   if (e->ref)
3127     {
3128       for (ref = e->ref; ref; ref = ref->next)
3129         {
3130           switch (ref->type)
3131             {
3132             case REF_ARRAY:
3133               for (i = 0; i < ref->u.ar.dimen; i++)
3134                 {
3135                   if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
3136                       || recursive_stmt_fcn (ref->u.ar.end[i], sym)
3137                       || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
3138                     return true;
3139                 }
3140               break;
3141
3142             case REF_SUBSTRING:
3143               if (recursive_stmt_fcn (ref->u.ss.start, sym)
3144                   || recursive_stmt_fcn (ref->u.ss.end, sym))
3145                 return true;
3146
3147               break;
3148
3149             default:
3150               break;
3151             }
3152         }
3153     }
3154   return false;
3155 }
3156
3157
3158 /* Match a statement function declaration.  It is so easy to match
3159    non-statement function statements with a MATCH_ERROR as opposed to
3160    MATCH_NO that we suppress error message in most cases.  */
3161
3162 match
3163 gfc_match_st_function (void)
3164 {
3165   gfc_error_buf old_error;
3166   gfc_symbol *sym;
3167   gfc_expr *expr;
3168   match m;
3169
3170   m = gfc_match_symbol (&sym, 0);
3171   if (m != MATCH_YES)
3172     return m;
3173
3174   gfc_push_error (&old_error);
3175
3176   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
3177                          sym->name, NULL) == FAILURE)
3178     goto undo_error;
3179
3180   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
3181     goto undo_error;
3182
3183   m = gfc_match (" = %e%t", &expr);
3184   if (m == MATCH_NO)
3185     goto undo_error;
3186
3187   gfc_free_error (&old_error);
3188   if (m == MATCH_ERROR)
3189     return m;
3190
3191   if (recursive_stmt_fcn (expr, sym))
3192     {
3193       gfc_error ("Statement function at %L is recursive", &expr->where);
3194       return MATCH_ERROR;
3195     }
3196
3197   sym->value = expr;
3198
3199   return MATCH_YES;
3200
3201 undo_error:
3202   gfc_pop_error (&old_error);
3203   return MATCH_NO;
3204 }
3205
3206
3207 /***************** SELECT CASE subroutines ******************/
3208
3209 /* Free a single case structure.  */
3210
3211 static void
3212 free_case (gfc_case *p)
3213 {
3214   if (p->low == p->high)
3215     p->high = NULL;
3216   gfc_free_expr (p->low);
3217   gfc_free_expr (p->high);
3218   gfc_free (p);
3219 }
3220
3221
3222 /* Free a list of case structures.  */
3223
3224 void
3225 gfc_free_case_list (gfc_case *p)
3226 {
3227   gfc_case *q;
3228
3229   for (; p; p = q)
3230     {
3231       q = p->next;
3232       free_case (p);
3233     }
3234 }
3235
3236
3237 /* Match a single case selector.  */
3238
3239 static match
3240 match_case_selector (gfc_case **cp)
3241 {
3242   gfc_case *c;
3243   match m;
3244
3245   c = gfc_get_case ();
3246   c->where = gfc_current_locus;
3247
3248   if (gfc_match_char (':') == MATCH_YES)
3249     {
3250       m = gfc_match_init_expr (&c->high);
3251       if (m == MATCH_NO)
3252         goto need_expr;
3253       if (m == MATCH_ERROR)
3254         goto cleanup;
3255     }
3256   else
3257     {
3258       m = gfc_match_init_expr (&c->low);
3259       if (m == MATCH_ERROR)
3260         goto cleanup;
3261       if (m == MATCH_NO)
3262         goto need_expr;
3263
3264       /* If we're not looking at a ':' now, make a range out of a single
3265          target.  Else get the upper bound for the case range.  */
3266       if (gfc_match_char (':') != MATCH_YES)
3267         c->high = c->low;
3268       else
3269         {
3270           m = gfc_match_init_expr (&c->high);
3271           if (m == MATCH_ERROR)
3272             goto cleanup;
3273           /* MATCH_NO is fine.  It's OK if nothing is there!  */
3274         }
3275     }
3276
3277   *cp = c;
3278   return MATCH_YES;
3279
3280 need_expr:
3281   gfc_error ("Expected initialization expression in CASE at %C");
3282
3283 cleanup:
3284   free_case (c);
3285   return MATCH_ERROR;
3286 }
3287
3288
3289 /* Match the end of a case statement.  */
3290
3291 static match
3292 match_case_eos (void)
3293 {
3294   char name[GFC_MAX_SYMBOL_LEN + 1];
3295   match m;
3296
3297   if (gfc_match_eos () == MATCH_YES)
3298     return MATCH_YES;
3299
3300   /* If the case construct doesn't have a case-construct-name, we
3301      should have matched the EOS.  */
3302   if (!gfc_current_block ())
3303     {
3304       gfc_error ("Expected the name of the SELECT CASE construct at %C");
3305       return MATCH_ERROR;
3306     }
3307
3308   gfc_gobble_whitespace ();
3309
3310   m = gfc_match_name (name);
3311   if (m != MATCH_YES)
3312     return m;
3313
3314   if (strcmp (name, gfc_current_block ()->name) != 0)
3315     {
3316       gfc_error ("Expected case name of '%s' at %C",
3317                  gfc_current_block ()->name);
3318       return MATCH_ERROR;
3319     }
3320
3321   return gfc_match_eos ();
3322 }
3323
3324
3325 /* Match a SELECT statement.  */
3326
3327 match
3328 gfc_match_select (void)
3329 {
3330   gfc_expr *expr;
3331   match m;
3332
3333   m = gfc_match_label ();
3334   if (m == MATCH_ERROR)
3335     return m;
3336
3337   m = gfc_match (" select case ( %e )%t", &expr);
3338   if (m != MATCH_YES)
3339     return m;
3340
3341   new_st.op = EXEC_SELECT;
3342   new_st.expr = expr;
3343
3344   return MATCH_YES;
3345 }
3346
3347
3348 /* Match a CASE statement.  */
3349
3350 match
3351 gfc_match_case (void)
3352 {
3353   gfc_case *c, *head, *tail;
3354   match m;
3355
3356   head = tail = NULL;
3357
3358   if (gfc_current_state () != COMP_SELECT)
3359     {
3360       gfc_error ("Unexpected CASE statement at %C");
3361       return MATCH_ERROR;
3362     }
3363
3364   if (gfc_match ("% default") == MATCH_YES)
3365     {
3366       m = match_case_eos ();
3367       if (m == MATCH_NO)
3368         goto syntax;
3369       if (m == MATCH_ERROR)
3370         goto cleanup;
3371
3372       new_st.op = EXEC_SELECT;
3373       c = gfc_get_case ();
3374       c->where = gfc_current_locus;
3375       new_st.ext.case_list = c;
3376       return MATCH_YES;
3377     }
3378
3379   if (gfc_match_char ('(') != MATCH_YES)
3380     goto syntax;
3381
3382   for (;;)
3383     {
3384       if (match_case_selector (&c) == MATCH_ERROR)
3385         goto cleanup;
3386
3387       if (head == NULL)
3388         head = c;
3389       else
3390         tail->next = c;
3391
3392       tail = c;
3393
3394       if (gfc_match_char (')') == MATCH_YES)
3395         break;
3396       if (gfc_match_char (',') != MATCH_YES)
3397         goto syntax;
3398     }
3399
3400   m = match_case_eos ();
3401   if (m == MATCH_NO)
3402     goto syntax;
3403   if (m == MATCH_ERROR)
3404     goto cleanup;
3405
3406   new_st.op = EXEC_SELECT;
3407   new_st.ext.case_list = head;
3408
3409   return MATCH_YES;
3410
3411 syntax:
3412   gfc_error ("Syntax error in CASE-specification at %C");
3413
3414 cleanup:
3415   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
3416   return MATCH_ERROR;
3417 }
3418
3419 /********************* WHERE subroutines ********************/
3420
3421 /* Match the rest of a simple WHERE statement that follows an IF statement.
3422  */
3423
3424 static match
3425 match_simple_where (void)
3426 {
3427   gfc_expr *expr;
3428   gfc_code *c;
3429   match m;
3430
3431   m = gfc_match (" ( %e )", &expr);
3432   if (m != MATCH_YES)
3433     return m;
3434
3435   m = gfc_match_assignment ();
3436   if (m == MATCH_NO)
3437     goto syntax;
3438   if (m == MATCH_ERROR)
3439     goto cleanup;
3440
3441   if (gfc_match_eos () != MATCH_YES)
3442     goto syntax;
3443
3444   c = gfc_get_code ();
3445
3446   c->op = EXEC_WHERE;
3447   c->expr = expr;
3448   c->next = gfc_get_code ();
3449
3450   *c->next = new_st;
3451   gfc_clear_new_st ();
3452
3453   new_st.op = EXEC_WHERE;
3454   new_st.block = c;
3455
3456   return MATCH_YES;
3457
3458 syntax:
3459   gfc_syntax_error (ST_WHERE);
3460
3461 cleanup:
3462   gfc_free_expr (expr);
3463   return MATCH_ERROR;
3464 }
3465
3466
3467 /* Match a WHERE statement.  */
3468
3469 match
3470 gfc_match_where (gfc_statement *st)
3471 {
3472   gfc_expr *expr;
3473   match m0, m;
3474   gfc_code *c;
3475
3476   m0 = gfc_match_label ();
3477   if (m0 == MATCH_ERROR)
3478     return m0;
3479
3480   m = gfc_match (" where ( %e )", &expr);
3481   if (m != MATCH_YES)
3482     return m;
3483
3484   if (gfc_match_eos () == MATCH_YES)
3485     {
3486       *st = ST_WHERE_BLOCK;
3487       new_st.op = EXEC_WHERE;
3488       new_st.expr = expr;
3489       return MATCH_YES;
3490     }
3491
3492   m = gfc_match_assignment ();
3493   if (m == MATCH_NO)
3494     gfc_syntax_error (ST_WHERE);
3495
3496   if (m != MATCH_YES)
3497     {
3498       gfc_free_expr (expr);
3499       return MATCH_ERROR;
3500     }
3501
3502   /* We've got a simple WHERE statement.  */
3503   *st = ST_WHERE;
3504   c = gfc_get_code ();
3505
3506   c->op = EXEC_WHERE;
3507   c->expr = expr;
3508   c->next = gfc_get_code ();
3509
3510   *c->next = new_st;
3511   gfc_clear_new_st ();
3512
3513   new_st.op = EXEC_WHERE;
3514   new_st.block = c;
3515
3516   return MATCH_YES;
3517 }
3518
3519
3520 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
3521    new_st if successful.  */
3522
3523 match
3524 gfc_match_elsewhere (void)
3525 {
3526   char name[GFC_MAX_SYMBOL_LEN + 1];
3527   gfc_expr *expr;
3528   match m;
3529
3530   if (gfc_current_state () != COMP_WHERE)
3531     {
3532       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3533       return MATCH_ERROR;
3534     }
3535
3536   expr = NULL;
3537
3538   if (gfc_match_char ('(') == MATCH_YES)
3539     {
3540       m = gfc_match_expr (&expr);
3541       if (m == MATCH_NO)
3542         goto syntax;
3543       if (m == MATCH_ERROR)
3544         return MATCH_ERROR;
3545
3546       if (gfc_match_char (')') != MATCH_YES)
3547         goto syntax;
3548     }
3549
3550   if (gfc_match_eos () != MATCH_YES)
3551     {
3552       /* Only makes sense if we have a where-construct-name.  */
3553       if (!gfc_current_block ())
3554         {
3555           m = MATCH_ERROR;
3556           goto cleanup;
3557         }
3558       /* Better be a name at this point.  */
3559       m = gfc_match_name (name);
3560       if (m == MATCH_NO)
3561         goto syntax;
3562       if (m == MATCH_ERROR)
3563         goto cleanup;
3564
3565       if (gfc_match_eos () != MATCH_YES)
3566         goto syntax;
3567
3568       if (strcmp (name, gfc_current_block ()->name) != 0)
3569         {
3570           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3571                      name, gfc_current_block ()->name);
3572           goto cleanup;
3573         }
3574     }
3575
3576   new_st.op = EXEC_WHERE;
3577   new_st.expr = expr;
3578   return MATCH_YES;
3579
3580 syntax:
3581   gfc_syntax_error (ST_ELSEWHERE);
3582
3583 cleanup:
3584   gfc_free_expr (expr);
3585   return MATCH_ERROR;
3586 }
3587
3588
3589 /******************** FORALL subroutines ********************/
3590
3591 /* Free a list of FORALL iterators.  */
3592
3593 void
3594 gfc_free_forall_iterator (gfc_forall_iterator *iter)
3595 {
3596   gfc_forall_iterator *next;
3597
3598   while (iter)
3599     {
3600       next = iter->next;
3601       gfc_free_expr (iter->var);
3602       gfc_free_expr (iter->start);
3603       gfc_free_expr (iter->end);
3604       gfc_free_expr (iter->stride);
3605       gfc_free (iter);
3606       iter = next;
3607     }
3608 }
3609
3610
3611 /* Match an iterator as part of a FORALL statement.  The format is:
3612
3613      <var> = <start>:<end>[:<stride>]
3614
3615    On MATCH_NO, the caller tests for the possibility that there is a
3616    scalar mask expression.  */
3617
3618 static match
3619 match_forall_iterator (gfc_forall_iterator **result)
3620 {
3621   gfc_forall_iterator *iter;
3622   locus where;
3623   match m;
3624
3625   where = gfc_current_locus;
3626   iter = gfc_getmem (sizeof (gfc_forall_iterator));
3627
3628   m = gfc_match_expr (&iter->var);
3629   if (m != MATCH_YES)
3630     goto cleanup;
3631
3632   if (gfc_match_char ('=') != MATCH_YES
3633       || iter->var->expr_type != EXPR_VARIABLE)
3634     {
3635       m = MATCH_NO;
3636       goto cleanup;
3637     }
3638
3639   m = gfc_match_expr (&iter->start);
3640   if (m != MATCH_YES)
3641     goto cleanup;
3642
3643   if (gfc_match_char (':') != MATCH_YES)
3644     goto syntax;
3645
3646   m = gfc_match_expr (&iter->end);
3647   if (m == MATCH_NO)
3648     goto syntax;
3649   if (m == MATCH_ERROR)
3650     goto cleanup;
3651
3652   if (gfc_match_char (':') == MATCH_NO)
3653     iter->stride = gfc_int_expr (1);
3654   else
3655     {
3656       m = gfc_match_expr (&iter->stride);
3657       if (m == MATCH_NO)
3658         goto syntax;
3659       if (m == MATCH_ERROR)
3660         goto cleanup;
3661     }
3662
3663   /* Mark the iteration variable's symbol as used as a FORALL index.  */
3664   iter->var->symtree->n.sym->forall_index = true;
3665
3666   *result = iter;
3667   return MATCH_YES;
3668
3669 syntax:
3670   gfc_error ("Syntax error in FORALL iterator at %C");
3671   m = MATCH_ERROR;
3672
3673 cleanup:
3674
3675   gfc_current_locus = where;
3676   gfc_free_forall_iterator (iter);
3677   return m;
3678 }
3679
3680
3681 /* Match the header of a FORALL statement.  */
3682
3683 static match
3684 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
3685 {
3686   gfc_forall_iterator *head, *tail, *new;
3687   gfc_expr *msk;
3688   match m;
3689
3690   gfc_gobble_whitespace ();
3691
3692   head = tail = NULL;
3693   msk = NULL;
3694
3695   if (gfc_match_char ('(') != MATCH_YES)
3696     return MATCH_NO;
3697
3698   m = match_forall_iterator (&new);
3699   if (m == MATCH_ERROR)
3700     goto cleanup;
3701   if (m == MATCH_NO)
3702     goto syntax;
3703
3704   head = tail = new;
3705
3706   for (;;)
3707     {
3708       if (gfc_match_char (',') != MATCH_YES)
3709         break;
3710
3711       m = match_forall_iterator (&new);
3712       if (m == MATCH_ERROR)
3713         goto cleanup;
3714
3715       if (m == MATCH_YES)
3716         {
3717           tail->next = new;
3718           tail = new;
3719           continue;
3720         }
3721
3722       /* Have to have a mask expression.  */
3723
3724       m = gfc_match_expr (&msk);
3725       if (m == MATCH_NO)
3726         goto syntax;
3727       if (m == MATCH_ERROR)
3728         goto cleanup;
3729
3730       break;
3731     }
3732
3733   if (gfc_match_char (')') == MATCH_NO)
3734     goto syntax;
3735
3736   *phead = head;
3737   *mask = msk;
3738   return MATCH_YES;
3739
3740 syntax:
3741   gfc_syntax_error (ST_FORALL);
3742
3743 cleanup:
3744   gfc_free_expr (msk);
3745   gfc_free_forall_iterator (head);
3746
3747   return MATCH_ERROR;
3748 }
3749
3750 /* Match the rest of a simple FORALL statement that follows an
3751    IF statement.  */
3752
3753 static match
3754 match_simple_forall (void)
3755 {
3756   gfc_forall_iterator *head;
3757   gfc_expr *mask;
3758   gfc_code *c;
3759   match m;
3760
3761   mask = NULL;
3762   head = NULL;
3763   c = NULL;
3764
3765   m = match_forall_header (&head, &mask);
3766
3767   if (m == MATCH_NO)
3768     goto syntax;
3769   if (m != MATCH_YES)
3770     goto cleanup;
3771
3772   m = gfc_match_assignment ();
3773
3774   if (m == MATCH_ERROR)
3775     goto cleanup;
3776   if (m == MATCH_NO)
3777     {
3778       m = gfc_match_pointer_assignment ();
3779       if (m == MATCH_ERROR)
3780         goto cleanup;
3781       if (m == MATCH_NO)
3782         goto syntax;
3783     }
3784
3785   c = gfc_get_code ();
3786   *c = new_st;
3787   c->loc = gfc_current_locus;
3788
3789   if (gfc_match_eos () != MATCH_YES)
3790     goto syntax;
3791
3792   gfc_clear_new_st ();
3793   new_st.op = EXEC_FORALL;
3794   new_st.expr = mask;
3795   new_st.ext.forall_iterator = head;
3796   new_st.block = gfc_get_code ();
3797
3798   new_st.block->op = EXEC_FORALL;
3799   new_st.block->next = c;
3800
3801   return MATCH_YES;
3802
3803 syntax:
3804   gfc_syntax_error (ST_FORALL);
3805
3806 cleanup:
3807   gfc_free_forall_iterator (head);
3808   gfc_free_expr (mask);
3809
3810   return MATCH_ERROR;
3811 }
3812
3813
3814 /* Match a FORALL statement.  */
3815
3816 match
3817 gfc_match_forall (gfc_statement *st)
3818 {
3819   gfc_forall_iterator *head;
3820   gfc_expr *mask;
3821   gfc_code *c;
3822   match m0, m;
3823
3824   head = NULL;
3825   mask = NULL;
3826   c = NULL;
3827
3828   m0 = gfc_match_label ();
3829   if (m0 == MATCH_ERROR)
3830     return MATCH_ERROR;
3831
3832   m = gfc_match (" forall");
3833   if (m != MATCH_YES)
3834     return m;
3835
3836   m = match_forall_header (&head, &mask);
3837   if (m == MATCH_ERROR)
3838     goto cleanup;
3839   if (m == MATCH_NO)
3840     goto syntax;
3841
3842   if (gfc_match_eos () == MATCH_YES)
3843     {
3844       *st = ST_FORALL_BLOCK;
3845       new_st.op = EXEC_FORALL;
3846       new_st.expr = mask;
3847       new_st.ext.forall_iterator = head;
3848       return MATCH_YES;
3849     }
3850
3851   m = gfc_match_assignment ();
3852   if (m == MATCH_ERROR)
3853     goto cleanup;
3854   if (m == MATCH_NO)
3855     {
3856       m = gfc_match_pointer_assignment ();
3857       if (m == MATCH_ERROR)
3858         goto cleanup;
3859       if (m == MATCH_NO)
3860         goto syntax;
3861     }
3862
3863   c = gfc_get_code ();
3864   *c = new_st;
3865   c->loc = gfc_current_locus;
3866
3867   gfc_clear_new_st ();
3868   new_st.op = EXEC_FORALL;
3869   new_st.expr = mask;
3870   new_st.ext.forall_iterator = head;
3871   new_st.block = gfc_get_code ();
3872   new_st.block->op = EXEC_FORALL;
3873   new_st.block->next = c;
3874
3875   *st = ST_FORALL;
3876   return MATCH_YES;
3877
3878 syntax:
3879   gfc_syntax_error (ST_FORALL);
3880
3881 cleanup:
3882   gfc_free_forall_iterator (head);
3883   gfc_free_expr (mask);
3884   gfc_free_statements (c);
3885   return MATCH_NO;
3886 }