gcc/fortran/match.c

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