gcc/fortran/match.c

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