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 /* Match a common block name.  */
2250
2251 static match
2252 match_common_name (gfc_symbol ** sym)
2253 {
2254   match m;
2255
2256   if (gfc_match_char ('/') == MATCH_NO)
2257     return MATCH_NO;
2258
2259   if (gfc_match_char ('/') == MATCH_YES)
2260     {
2261       *sym = NULL;
2262       return MATCH_YES;
2263     }
2264
2265   m = gfc_match_symbol (sym, 0);
2266
2267   if (m == MATCH_ERROR)
2268     return MATCH_ERROR;
2269   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2270     return MATCH_YES;
2271
2272   gfc_error ("Syntax error in common block name at %C");
2273   return MATCH_ERROR;
2274 }
2275
2276
2277 /* Match a COMMON statement.  */
2278
2279 match
2280 gfc_match_common (void)
2281 {
2282   gfc_symbol *sym, *common_name, **head, *tail, *old_blank_common;
2283   gfc_array_spec *as;
2284   match m;
2285
2286   old_blank_common = gfc_current_ns->blank_common;
2287   if (old_blank_common)
2288     {
2289       while (old_blank_common->common_next)
2290         old_blank_common = old_blank_common->common_next;
2291     }
2292
2293   common_name = NULL;
2294   as = NULL;
2295
2296   if (gfc_match_eos () == MATCH_YES)
2297     goto syntax;
2298
2299   for (;;)
2300     {
2301       m = match_common_name (&common_name);
2302       if (m == MATCH_ERROR)
2303         goto cleanup;
2304
2305       if (common_name == NULL)
2306         head = &gfc_current_ns->blank_common;
2307       else
2308         {
2309           head = &common_name->common_head;
2310
2311           if (!common_name->attr.common
2312               && gfc_add_common (&common_name->attr, NULL) == FAILURE)
2313             goto cleanup;
2314         }
2315
2316       if (*head == NULL)
2317         tail = NULL;
2318       else
2319         {
2320           tail = *head;
2321           while (tail->common_next)
2322             tail = tail->common_next;
2323         }
2324
2325       /* Grab the list of symbols.  */
2326       for (;;)
2327         {
2328           m = gfc_match_symbol (&sym, 0);
2329           if (m == MATCH_ERROR)
2330             goto cleanup;
2331           if (m == MATCH_NO)
2332             goto syntax;
2333
2334           if (sym->attr.in_common)
2335             {
2336               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2337                          sym->name);
2338               goto cleanup;
2339             }
2340
2341           if (sym->value != NULL
2342               && (common_name == NULL || !sym->attr.data))
2343             {
2344               if (common_name == NULL)
2345                 gfc_error ("Previously initialized symbol '%s' in "
2346                            "blank COMMON block at %C", sym->name);
2347               else
2348                 gfc_error ("Previously initialized symbol '%s' in "
2349                            "COMMON block '%s' at %C", sym->name,
2350                            common_name->name);
2351               goto cleanup;
2352             }
2353
2354           if (gfc_add_in_common (&sym->attr, NULL) == FAILURE)
2355             goto cleanup;
2356
2357           /* Derived type names must have the SEQUENCE attribute.  */
2358           if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2359             {
2360               gfc_error
2361                 ("Derived type variable in COMMON at %C does not have the "
2362                  "SEQUENCE attribute");
2363               goto cleanup;
2364             }
2365
2366           if (tail != NULL)
2367             tail->common_next = sym;
2368           else
2369             *head = sym;
2370
2371           tail = sym;
2372
2373           /* Deal with an optional array specification after the
2374              symbol name.  */
2375           m = gfc_match_array_spec (&as);
2376           if (m == MATCH_ERROR)
2377             goto cleanup;
2378
2379           if (m == MATCH_YES)
2380             {
2381               if (as->type != AS_EXPLICIT)
2382                 {
2383                   gfc_error
2384                     ("Array specification for symbol '%s' in COMMON at %C "
2385                      "must be explicit", sym->name);
2386                   goto cleanup;
2387                 }
2388
2389               if (gfc_add_dimension (&sym->attr, NULL) == FAILURE)
2390                 goto cleanup;
2391
2392               if (sym->attr.pointer)
2393                 {
2394                   gfc_error
2395                     ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2396                      sym->name);
2397                   goto cleanup;
2398                 }
2399
2400               sym->as = as;
2401               as = NULL;
2402             }
2403
2404           if (gfc_match_eos () == MATCH_YES)
2405             goto done;
2406           if (gfc_peek_char () == '/')
2407             break;
2408           if (gfc_match_char (',') != MATCH_YES)
2409             goto syntax;
2410           if (gfc_peek_char () == '/')
2411             break;
2412         }
2413     }
2414
2415 done:
2416   return MATCH_YES;
2417
2418 syntax:
2419   gfc_syntax_error (ST_COMMON);
2420
2421 cleanup:
2422   if (old_blank_common)
2423     old_blank_common->common_next = NULL;
2424   else
2425     gfc_current_ns->blank_common = NULL;
2426   gfc_free_array_spec (as);
2427   return MATCH_ERROR;
2428 }
2429
2430
2431 /* Match a BLOCK DATA program unit.  */
2432
2433 match
2434 gfc_match_block_data (void)
2435 {
2436   char name[GFC_MAX_SYMBOL_LEN + 1];
2437   gfc_symbol *sym;
2438   match m;
2439
2440   if (gfc_match_eos () == MATCH_YES)
2441     {
2442       gfc_new_block = NULL;
2443       return MATCH_YES;
2444     }
2445
2446   m = gfc_match (" %n%t", name);
2447   if (m != MATCH_YES)
2448     return MATCH_ERROR;
2449
2450   if (gfc_get_symbol (name, NULL, &sym))
2451     return MATCH_ERROR;
2452
2453   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, NULL) == FAILURE)
2454     return MATCH_ERROR;
2455
2456   gfc_new_block = sym;
2457
2458   return MATCH_YES;
2459 }
2460
2461
2462 /* Free a namelist structure.  */
2463
2464 void
2465 gfc_free_namelist (gfc_namelist * name)
2466 {
2467   gfc_namelist *n;
2468
2469   for (; name; name = n)
2470     {
2471       n = name->next;
2472       gfc_free (name);
2473     }
2474 }
2475
2476
2477 /* Match a NAMELIST statement.  */
2478
2479 match
2480 gfc_match_namelist (void)
2481 {
2482   gfc_symbol *group_name, *sym;
2483   gfc_namelist *nl;
2484   match m, m2;
2485
2486   m = gfc_match (" / %s /", &group_name);
2487   if (m == MATCH_NO)
2488     goto syntax;
2489   if (m == MATCH_ERROR)
2490     goto error;
2491
2492   for (;;)
2493     {
2494       if (group_name->ts.type != BT_UNKNOWN)
2495         {
2496           gfc_error
2497             ("Namelist group name '%s' at %C already has a basic type "
2498              "of %s", group_name->name, gfc_typename (&group_name->ts));
2499           return MATCH_ERROR;
2500         }
2501
2502       if (group_name->attr.flavor != FL_NAMELIST
2503           && gfc_add_flavor (&group_name->attr, FL_NAMELIST, NULL) == FAILURE)
2504         return MATCH_ERROR;
2505
2506       for (;;)
2507         {
2508           m = gfc_match_symbol (&sym, 1);
2509           if (m == MATCH_NO)
2510             goto syntax;
2511           if (m == MATCH_ERROR)
2512             goto error;
2513
2514           if (sym->attr.in_namelist == 0
2515               && gfc_add_in_namelist (&sym->attr, NULL) == FAILURE)
2516             goto error;
2517
2518           /* TODO: worry about PRIVATE members of a PUBLIC namelist
2519              group.  */
2520
2521           nl = gfc_get_namelist ();
2522           nl->sym = sym;
2523
2524           if (group_name->namelist == NULL)
2525             group_name->namelist = group_name->namelist_tail = nl;
2526           else
2527             {
2528               group_name->namelist_tail->next = nl;
2529               group_name->namelist_tail = nl;
2530             }
2531
2532           if (gfc_match_eos () == MATCH_YES)
2533             goto done;
2534
2535           m = gfc_match_char (',');
2536
2537           if (gfc_match_char ('/') == MATCH_YES)
2538             {
2539               m2 = gfc_match (" %s /", &group_name);
2540               if (m2 == MATCH_YES)
2541                 break;
2542               if (m2 == MATCH_ERROR)
2543                 goto error;
2544               goto syntax;
2545             }
2546
2547           if (m != MATCH_YES)
2548             goto syntax;
2549         }
2550     }
2551
2552 done:
2553   return MATCH_YES;
2554
2555 syntax:
2556   gfc_syntax_error (ST_NAMELIST);
2557
2558 error:
2559   return MATCH_ERROR;
2560 }
2561
2562
2563 /* Match a MODULE statement.  */
2564
2565 match
2566 gfc_match_module (void)
2567 {
2568   match m;
2569
2570   m = gfc_match (" %s%t", &gfc_new_block);
2571   if (m != MATCH_YES)
2572     return m;
2573
2574   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, NULL) == FAILURE)
2575     return MATCH_ERROR;
2576
2577   return MATCH_YES;
2578 }
2579
2580
2581 /* Free equivalence sets and lists.  Recursively is the easiest way to
2582    do this.  */
2583
2584 void
2585 gfc_free_equiv (gfc_equiv * eq)
2586 {
2587
2588   if (eq == NULL)
2589     return;
2590
2591   gfc_free_equiv (eq->eq);
2592   gfc_free_equiv (eq->next);
2593
2594   gfc_free_expr (eq->expr);
2595   gfc_free (eq);
2596 }
2597
2598
2599 /* Match an EQUIVALENCE statement.  */
2600
2601 match
2602 gfc_match_equivalence (void)
2603 {
2604   gfc_equiv *eq, *set, *tail;
2605   gfc_ref *ref;
2606   match m;
2607
2608   tail = NULL;
2609
2610   for (;;)
2611     {
2612       eq = gfc_get_equiv ();
2613       if (tail == NULL)
2614         tail = eq;
2615
2616       eq->next = gfc_current_ns->equiv;
2617       gfc_current_ns->equiv = eq;
2618
2619       if (gfc_match_char ('(') != MATCH_YES)
2620         goto syntax;
2621
2622       set = eq;
2623
2624       for (;;)
2625         {
2626           m = gfc_match_variable (&set->expr, 1);
2627           if (m == MATCH_ERROR)
2628             goto cleanup;
2629           if (m == MATCH_NO)
2630             goto syntax;
2631
2632           for (ref = set->expr->ref; ref; ref = ref->next)
2633             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2634               {
2635                 gfc_error
2636                   ("Array reference in EQUIVALENCE at %C cannot be an "
2637                    "array section");
2638                 goto cleanup;
2639               }
2640
2641           if (gfc_match_char (')') == MATCH_YES)
2642             break;
2643           if (gfc_match_char (',') != MATCH_YES)
2644             goto syntax;
2645
2646           set->eq = gfc_get_equiv ();
2647           set = set->eq;
2648         }
2649
2650       if (gfc_match_eos () == MATCH_YES)
2651         break;
2652       if (gfc_match_char (',') != MATCH_YES)
2653         goto syntax;
2654     }
2655
2656   return MATCH_YES;
2657
2658 syntax:
2659   gfc_syntax_error (ST_EQUIVALENCE);
2660
2661 cleanup:
2662   eq = tail->next;
2663   tail->next = NULL;
2664
2665   gfc_free_equiv (gfc_current_ns->equiv);
2666   gfc_current_ns->equiv = eq;
2667
2668   return MATCH_ERROR;
2669 }
2670
2671
2672 /* Match a statement function declaration.  It is so easy to match
2673    non-statement function statements with a MATCH_ERROR as opposed to
2674    MATCH_NO that we suppress error message in most cases.  */
2675
2676 match
2677 gfc_match_st_function (void)
2678 {
2679   gfc_error_buf old_error;
2680   gfc_symbol *sym;
2681   gfc_expr *expr;
2682   match m;
2683
2684   m = gfc_match_symbol (&sym, 0);
2685   if (m != MATCH_YES)
2686     return m;
2687
2688   gfc_push_error (&old_error);
2689
2690   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, NULL) == FAILURE)
2691     goto undo_error;
2692
2693   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2694     goto undo_error;
2695
2696   m = gfc_match (" = %e%t", &expr);
2697   if (m == MATCH_NO)
2698     goto undo_error;
2699   if (m == MATCH_ERROR)
2700     return m;
2701
2702   sym->value = expr;
2703
2704   return MATCH_YES;
2705
2706 undo_error:
2707   gfc_pop_error (&old_error);
2708   return MATCH_NO;
2709 }
2710
2711
2712 /********************* DATA statement subroutines *********************/
2713
2714 /* Free a gfc_data_variable structure and everything beneath it.  */
2715
2716 static void
2717 free_variable (gfc_data_variable * p)
2718 {
2719   gfc_data_variable *q;
2720
2721   for (; p; p = q)
2722     {
2723       q = p->next;
2724       gfc_free_expr (p->expr);
2725       gfc_free_iterator (&p->iter, 0);
2726       free_variable (p->list);
2727
2728       gfc_free (p);
2729     }
2730 }
2731
2732
2733 /* Free a gfc_data_value structure and everything beneath it.  */
2734
2735 static void
2736 free_value (gfc_data_value * p)
2737 {
2738   gfc_data_value *q;
2739
2740   for (; p; p = q)
2741     {
2742       q = p->next;
2743       gfc_free_expr (p->expr);
2744       gfc_free (p);
2745     }
2746 }
2747
2748
2749 /* Free a list of gfc_data structures.  */
2750
2751 void
2752 gfc_free_data (gfc_data * p)
2753 {
2754   gfc_data *q;
2755
2756   for (; p; p = q)
2757     {
2758       q = p->next;
2759
2760       free_variable (p->var);
2761       free_value (p->value);
2762
2763       gfc_free (p);
2764     }
2765 }
2766
2767
2768 static match var_element (gfc_data_variable *);
2769
2770 /* Match a list of variables terminated by an iterator and a right
2771    parenthesis.  */
2772
2773 static match
2774 var_list (gfc_data_variable * parent)
2775 {
2776   gfc_data_variable *tail, var;
2777   match m;
2778
2779   m = var_element (&var);
2780   if (m == MATCH_ERROR)
2781     return MATCH_ERROR;
2782   if (m == MATCH_NO)
2783     goto syntax;
2784
2785   tail = gfc_get_data_variable ();
2786   *tail = var;
2787
2788   parent->list = tail;
2789
2790   for (;;)
2791     {
2792       if (gfc_match_char (',') != MATCH_YES)
2793         goto syntax;
2794
2795       m = gfc_match_iterator (&parent->iter, 1);
2796       if (m == MATCH_YES)
2797         break;
2798       if (m == MATCH_ERROR)
2799         return MATCH_ERROR;
2800
2801       m = var_element (&var);
2802       if (m == MATCH_ERROR)
2803         return MATCH_ERROR;
2804       if (m == MATCH_NO)
2805         goto syntax;
2806
2807       tail->next = gfc_get_data_variable ();
2808       tail = tail->next;
2809
2810       *tail = var;
2811     }
2812
2813   if (gfc_match_char (')') != MATCH_YES)
2814     goto syntax;
2815   return MATCH_YES;
2816
2817 syntax:
2818   gfc_syntax_error (ST_DATA);
2819   return MATCH_ERROR;
2820 }
2821
2822
2823 /* Match a single element in a data variable list, which can be a
2824    variable-iterator list.  */
2825
2826 static match
2827 var_element (gfc_data_variable * new)
2828 {
2829   match m;
2830   gfc_symbol *sym, *t;
2831
2832   memset (new, '\0', sizeof (gfc_data_variable));
2833
2834   if (gfc_match_char ('(') == MATCH_YES)
2835     return var_list (new);
2836
2837   m = gfc_match_variable (&new->expr, 0);
2838   if (m != MATCH_YES)
2839     return m;
2840
2841   sym = new->expr->symtree->n.sym;
2842
2843   if(sym->value != NULL)
2844     {
2845       gfc_error ("Variable '%s' at %C already has an initialization",
2846                  sym->name);
2847       return MATCH_ERROR;
2848     }
2849
2850   if (sym->attr.in_common)
2851     /* See if sym is in the blank common block.  */
2852     for (t = sym->ns->blank_common; t; t = t->common_next)
2853       if (sym == t)
2854         {
2855           gfc_error ("DATA statement at %C may not initialize variable "
2856                      "'%s' from blank COMMON", sym->name);
2857           return MATCH_ERROR;
2858         }
2859
2860   sym->attr.data = 1;
2861
2862   return MATCH_YES;
2863 }
2864
2865
2866 /* Match the top-level list of data variables.  */
2867
2868 static match
2869 top_var_list (gfc_data * d)
2870 {
2871   gfc_data_variable var, *tail, *new;
2872   match m;
2873
2874   tail = NULL;
2875
2876   for (;;)
2877     {
2878       m = var_element (&var);
2879       if (m == MATCH_NO)
2880         goto syntax;
2881       if (m == MATCH_ERROR)
2882         return MATCH_ERROR;
2883
2884       new = gfc_get_data_variable ();
2885       *new = var;
2886
2887       if (tail == NULL)
2888         d->var = new;
2889       else
2890         tail->next = new;
2891
2892       tail = new;
2893
2894       if (gfc_match_char ('/') == MATCH_YES)
2895         break;
2896       if (gfc_match_char (',') != MATCH_YES)
2897         goto syntax;
2898     }
2899
2900   return MATCH_YES;
2901
2902 syntax:
2903   gfc_syntax_error (ST_DATA);
2904   return MATCH_ERROR;
2905 }
2906
2907
2908 static match
2909 match_data_constant (gfc_expr ** result)
2910 {
2911   char name[GFC_MAX_SYMBOL_LEN + 1];
2912   gfc_symbol *sym;
2913   gfc_expr *expr;
2914   match m;
2915
2916   m = gfc_match_literal_constant (&expr, 1);
2917   if (m == MATCH_YES)
2918     {
2919       *result = expr;
2920       return MATCH_YES;
2921     }
2922
2923   if (m == MATCH_ERROR)
2924     return MATCH_ERROR;
2925
2926   m = gfc_match_null (result);
2927   if (m != MATCH_NO)
2928     return m;
2929
2930   m = gfc_match_name (name);
2931   if (m != MATCH_YES)
2932     return m;
2933
2934   if (gfc_find_symbol (name, NULL, 1, &sym))
2935     return MATCH_ERROR;
2936
2937   if (sym == NULL
2938       || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
2939     {
2940       gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
2941                  name);
2942       return MATCH_ERROR;
2943     }
2944   else if (sym->attr.flavor == FL_DERIVED)
2945     return gfc_match_structure_constructor (sym, result);
2946
2947   *result = gfc_copy_expr (sym->value);
2948   return MATCH_YES;
2949 }
2950
2951
2952 /* Match a list of values in a DATA statement.  The leading '/' has
2953    already been seen at this point.  */
2954
2955 static match
2956 top_val_list (gfc_data * data)
2957 {
2958   gfc_data_value *new, *tail;
2959   gfc_expr *expr;
2960   const char *msg;
2961   match m;
2962
2963   tail = NULL;
2964
2965   for (;;)
2966     {
2967       m = match_data_constant (&expr);
2968       if (m == MATCH_NO)
2969         goto syntax;
2970       if (m == MATCH_ERROR)
2971         return MATCH_ERROR;
2972
2973       new = gfc_get_data_value ();
2974
2975       if (tail == NULL)
2976         data->value = new;
2977       else
2978         tail->next = new;
2979
2980       tail = new;
2981
2982       if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
2983         {
2984           tail->expr = expr;
2985           tail->repeat = 1;
2986         }
2987       else
2988         {
2989           msg = gfc_extract_int (expr, &tail->repeat);
2990           gfc_free_expr (expr);
2991           if (msg != NULL)
2992             {
2993               gfc_error (msg);
2994               return MATCH_ERROR;
2995             }
2996
2997           m = match_data_constant (&tail->expr);
2998           if (m == MATCH_NO)
2999             goto syntax;
3000           if (m == MATCH_ERROR)
3001             return MATCH_ERROR;
3002         }
3003
3004       if (gfc_match_char ('/') == MATCH_YES)
3005         break;
3006       if (gfc_match_char (',') == MATCH_NO)
3007         goto syntax;
3008     }
3009
3010   return MATCH_YES;
3011
3012 syntax:
3013   gfc_syntax_error (ST_DATA);
3014   return MATCH_ERROR;
3015 }
3016
3017
3018 /* Match a DATA statement.  */
3019
3020 match
3021 gfc_match_data (void)
3022 {
3023   gfc_data *new;
3024   match m;
3025
3026   for (;;)
3027     {
3028       new = gfc_get_data ();
3029       new->where = gfc_current_locus;
3030
3031       m = top_var_list (new);
3032       if (m != MATCH_YES)
3033         goto cleanup;
3034
3035       m = top_val_list (new);
3036       if (m != MATCH_YES)
3037         goto cleanup;
3038
3039       new->next = gfc_current_ns->data;
3040       gfc_current_ns->data = new;
3041
3042       if (gfc_match_eos () == MATCH_YES)
3043         break;
3044
3045       gfc_match_char (',');     /* Optional comma */
3046     }
3047
3048   if (gfc_pure (NULL))
3049     {
3050       gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
3051       return MATCH_ERROR;
3052     }
3053
3054   return MATCH_YES;
3055
3056 cleanup:
3057   gfc_free_data (new);
3058   return MATCH_ERROR;
3059 }
3060
3061
3062 /***************** SELECT CASE subroutines ******************/
3063
3064 /* Free a single case structure.  */
3065
3066 static void
3067 free_case (gfc_case * p)
3068 {
3069   if (p->low == p->high)
3070     p->high = NULL;
3071   gfc_free_expr (p->low);
3072   gfc_free_expr (p->high);
3073   gfc_free (p);
3074 }
3075
3076
3077 /* Free a list of case structures.  */
3078
3079 void
3080 gfc_free_case_list (gfc_case * p)
3081 {
3082   gfc_case *q;
3083
3084   for (; p; p = q)
3085     {
3086       q = p->next;
3087       free_case (p);
3088     }
3089 }
3090
3091
3092 /* Match a single case selector.  */
3093
3094 static match
3095 match_case_selector (gfc_case ** cp)
3096 {
3097   gfc_case *c;
3098   match m;
3099
3100   c = gfc_get_case ();
3101   c->where = gfc_current_locus;
3102
3103   if (gfc_match_char (':') == MATCH_YES)
3104     {
3105       m = gfc_match_expr (&c->high);
3106       if (m == MATCH_NO)
3107         goto need_expr;
3108       if (m == MATCH_ERROR)
3109         goto cleanup;
3110     }
3111
3112   else
3113     {
3114       m = gfc_match_expr (&c->low);
3115       if (m == MATCH_ERROR)
3116         goto cleanup;
3117       if (m == MATCH_NO)
3118         goto need_expr;
3119
3120       /* If we're not looking at a ':' now, make a range out of a single
3121          target.  Else get the upper bound for the case range. */
3122       if (gfc_match_char (':') != MATCH_YES)
3123         c->high = c->low;
3124       else
3125         {
3126           m = gfc_match_expr (&c->high);
3127           if (m == MATCH_ERROR)
3128             goto cleanup;
3129           /* MATCH_NO is fine.  It's OK if nothing is there!  */
3130         }
3131     }
3132
3133   *cp = c;
3134   return MATCH_YES;
3135
3136 need_expr:
3137   gfc_error ("Expected expression in CASE at %C");
3138
3139 cleanup:
3140   free_case (c);
3141   return MATCH_ERROR;
3142 }
3143
3144
3145 /* Match the end of a case statement.  */
3146
3147 static match
3148 match_case_eos (void)
3149 {
3150   char name[GFC_MAX_SYMBOL_LEN + 1];
3151   match m;
3152
3153   if (gfc_match_eos () == MATCH_YES)
3154     return MATCH_YES;
3155
3156   gfc_gobble_whitespace ();
3157
3158   m = gfc_match_name (name);
3159   if (m != MATCH_YES)
3160     return m;
3161
3162   if (strcmp (name, gfc_current_block ()->name) != 0)
3163     {
3164       gfc_error ("Expected case name of '%s' at %C",
3165                  gfc_current_block ()->name);
3166       return MATCH_ERROR;
3167     }
3168
3169   return gfc_match_eos ();
3170 }
3171
3172
3173 /* Match a SELECT statement.  */
3174
3175 match
3176 gfc_match_select (void)
3177 {
3178   gfc_expr *expr;
3179   match m;
3180
3181   m = gfc_match_label ();
3182   if (m == MATCH_ERROR)
3183     return m;
3184
3185   m = gfc_match (" select case ( %e )%t", &expr);
3186   if (m != MATCH_YES)
3187     return m;
3188
3189   new_st.op = EXEC_SELECT;
3190   new_st.expr = expr;
3191
3192   return MATCH_YES;
3193 }
3194
3195
3196 /* Match a CASE statement.  */
3197
3198 match
3199 gfc_match_case (void)
3200 {
3201   gfc_case *c, *head, *tail;
3202   match m;
3203
3204   head = tail = NULL;
3205
3206   if (gfc_current_state () != COMP_SELECT)
3207     {
3208       gfc_error ("Unexpected CASE statement at %C");
3209       return MATCH_ERROR;
3210     }
3211
3212   if (gfc_match ("% default") == MATCH_YES)
3213     {
3214       m = match_case_eos ();
3215       if (m == MATCH_NO)
3216         goto syntax;
3217       if (m == MATCH_ERROR)
3218         goto cleanup;
3219
3220       new_st.op = EXEC_SELECT;
3221       c = gfc_get_case ();
3222       c->where = gfc_current_locus;
3223       new_st.ext.case_list = c;
3224       return MATCH_YES;
3225     }
3226
3227   if (gfc_match_char ('(') != MATCH_YES)
3228     goto syntax;
3229
3230   for (;;)
3231     {
3232       if (match_case_selector (&c) == MATCH_ERROR)
3233         goto cleanup;
3234
3235       if (head == NULL)
3236         head = c;
3237       else
3238         tail->next = c;
3239
3240       tail = c;
3241
3242       if (gfc_match_char (')') == MATCH_YES)
3243         break;
3244       if (gfc_match_char (',') != MATCH_YES)
3245         goto syntax;
3246     }
3247
3248   m = match_case_eos ();
3249   if (m == MATCH_NO)
3250     goto syntax;
3251   if (m == MATCH_ERROR)
3252     goto cleanup;
3253
3254   new_st.op = EXEC_SELECT;
3255   new_st.ext.case_list = head;
3256
3257   return MATCH_YES;
3258
3259 syntax:
3260   gfc_error ("Syntax error in CASE-specification at %C");
3261
3262 cleanup:
3263   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
3264   return MATCH_ERROR;
3265 }
3266
3267 /********************* WHERE subroutines ********************/
3268
3269 /* Match a WHERE statement.  */
3270
3271 match
3272 gfc_match_where (gfc_statement * st)
3273 {
3274   gfc_expr *expr;
3275   match m0, m;
3276   gfc_code *c;
3277
3278   m0 = gfc_match_label ();
3279   if (m0 == MATCH_ERROR)
3280     return m0;
3281
3282   m = gfc_match (" where ( %e )", &expr);
3283   if (m != MATCH_YES)
3284     return m;
3285
3286   if (gfc_match_eos () == MATCH_YES)
3287     {
3288       *st = ST_WHERE_BLOCK;
3289
3290       new_st.op = EXEC_WHERE;
3291       new_st.expr = expr;
3292       return MATCH_YES;
3293     }
3294
3295   m = gfc_match_assignment ();
3296   if (m == MATCH_NO)
3297     gfc_syntax_error (ST_WHERE);
3298
3299   if (m != MATCH_YES)
3300     {
3301       gfc_free_expr (expr);
3302       return MATCH_ERROR;
3303     }
3304
3305   /* We've got a simple WHERE statement.  */
3306   *st = ST_WHERE;
3307   c = gfc_get_code ();
3308
3309   c->op = EXEC_WHERE;
3310   c->expr = expr;
3311   c->next = gfc_get_code ();
3312
3313   *c->next = new_st;
3314   gfc_clear_new_st ();
3315
3316   new_st.op = EXEC_WHERE;
3317   new_st.block = c;
3318
3319   return MATCH_YES;
3320 }
3321
3322
3323 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
3324    new_st if successful.  */
3325
3326 match
3327 gfc_match_elsewhere (void)
3328 {
3329   char name[GFC_MAX_SYMBOL_LEN + 1];
3330   gfc_expr *expr;
3331   match m;
3332
3333   if (gfc_current_state () != COMP_WHERE)
3334     {
3335       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3336       return MATCH_ERROR;
3337     }
3338
3339   expr = NULL;
3340
3341   if (gfc_match_char ('(') == MATCH_YES)
3342     {
3343       m = gfc_match_expr (&expr);
3344       if (m == MATCH_NO)
3345         goto syntax;
3346       if (m == MATCH_ERROR)
3347         return MATCH_ERROR;
3348
3349       if (gfc_match_char (')') != MATCH_YES)
3350         goto syntax;
3351     }
3352
3353   if (gfc_match_eos () != MATCH_YES)
3354     {                           /* Better be a name at this point */
3355       m = gfc_match_name (name);
3356       if (m == MATCH_NO)
3357         goto syntax;
3358       if (m == MATCH_ERROR)
3359         goto cleanup;
3360
3361       if (gfc_match_eos () != MATCH_YES)
3362         goto syntax;
3363
3364       if (strcmp (name, gfc_current_block ()->name) != 0)
3365         {
3366           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3367                      name, gfc_current_block ()->name);
3368           goto cleanup;
3369         }
3370     }
3371
3372   new_st.op = EXEC_WHERE;
3373   new_st.expr = expr;
3374   return MATCH_YES;
3375
3376 syntax:
3377   gfc_syntax_error (ST_ELSEWHERE);
3378
3379 cleanup:
3380   gfc_free_expr (expr);
3381   return MATCH_ERROR;
3382 }
3383
3384
3385 /******************** FORALL subroutines ********************/
3386
3387 /* Free a list of FORALL iterators.  */
3388
3389 void
3390 gfc_free_forall_iterator (gfc_forall_iterator * iter)
3391 {
3392   gfc_forall_iterator *next;
3393
3394   while (iter)
3395     {
3396       next = iter->next;
3397
3398       gfc_free_expr (iter->var);
3399       gfc_free_expr (iter->start);
3400       gfc_free_expr (iter->end);
3401       gfc_free_expr (iter->stride);
3402
3403       gfc_free (iter);
3404       iter = next;
3405     }
3406 }
3407
3408
3409 /* Match an iterator as part of a FORALL statement.  The format is:
3410
3411      <var> = <start>:<end>[:<stride>][, <scalar mask>]  */
3412
3413 static match
3414 match_forall_iterator (gfc_forall_iterator ** result)
3415 {
3416   gfc_forall_iterator *iter;
3417   locus where;
3418   match m;
3419
3420   where = gfc_current_locus;
3421   iter = gfc_getmem (sizeof (gfc_forall_iterator));
3422
3423   m = gfc_match_variable (&iter->var, 0);
3424   if (m != MATCH_YES)
3425     goto cleanup;
3426
3427   if (gfc_match_char ('=') != MATCH_YES)
3428     {
3429       m = MATCH_NO;
3430       goto cleanup;
3431     }
3432
3433   m = gfc_match_expr (&iter->start);
3434   if (m == MATCH_NO)
3435     goto syntax;
3436   if (m == MATCH_ERROR)
3437     goto cleanup;
3438
3439   if (gfc_match_char (':') != MATCH_YES)
3440     goto syntax;
3441
3442   m = gfc_match_expr (&iter->end);
3443   if (m == MATCH_NO)
3444     goto syntax;
3445   if (m == MATCH_ERROR)
3446     goto cleanup;
3447
3448   if (gfc_match_char (':') == MATCH_NO)
3449     iter->stride = gfc_int_expr (1);
3450   else
3451     {
3452       m = gfc_match_expr (&iter->stride);
3453       if (m == MATCH_NO)
3454         goto syntax;
3455       if (m == MATCH_ERROR)
3456         goto cleanup;
3457     }
3458
3459   *result = iter;
3460   return MATCH_YES;
3461
3462 syntax:
3463   gfc_error ("Syntax error in FORALL iterator at %C");
3464   m = MATCH_ERROR;
3465
3466 cleanup:
3467   gfc_current_locus = where;
3468   gfc_free_forall_iterator (iter);
3469   return m;
3470 }
3471
3472
3473 /* Match a FORALL statement.  */
3474
3475 match
3476 gfc_match_forall (gfc_statement * st)
3477 {
3478   gfc_forall_iterator *head, *tail, *new;
3479   gfc_expr *mask;
3480   gfc_code *c;
3481   match m0, m;
3482
3483   head = tail = NULL;
3484   mask = NULL;
3485   c = NULL;
3486
3487   m0 = gfc_match_label ();
3488   if (m0 == MATCH_ERROR)
3489     return MATCH_ERROR;
3490
3491   m = gfc_match (" forall (");
3492   if (m != MATCH_YES)
3493     return m;
3494
3495   m = match_forall_iterator (&new);
3496   if (m == MATCH_ERROR)
3497     goto cleanup;
3498   if (m == MATCH_NO)
3499     goto syntax;
3500
3501   head = tail = new;
3502
3503   for (;;)
3504     {
3505       if (gfc_match_char (',') != MATCH_YES)
3506         break;
3507
3508       m = match_forall_iterator (&new);
3509       if (m == MATCH_ERROR)
3510         goto cleanup;
3511       if (m == MATCH_YES)
3512         {
3513           tail->next = new;
3514           tail = new;
3515           continue;
3516         }
3517
3518       /* Have to have a mask expression.  */
3519       m = gfc_match_expr (&mask);
3520       if (m == MATCH_NO)
3521         goto syntax;
3522       if (m == MATCH_ERROR)
3523         goto cleanup;
3524
3525       break;
3526     }
3527
3528   if (gfc_match_char (')') == MATCH_NO)
3529     goto syntax;
3530
3531   if (gfc_match_eos () == MATCH_YES)
3532     {
3533       *st = ST_FORALL_BLOCK;
3534
3535       new_st.op = EXEC_FORALL;
3536       new_st.expr = mask;
3537       new_st.ext.forall_iterator = head;
3538
3539       return MATCH_YES;
3540     }
3541
3542   m = gfc_match_assignment ();
3543   if (m == MATCH_ERROR)
3544     goto cleanup;
3545   if (m == MATCH_NO)
3546     {
3547       m = gfc_match_pointer_assignment ();
3548       if (m == MATCH_ERROR)
3549         goto cleanup;
3550       if (m == MATCH_NO)
3551         goto syntax;
3552     }
3553
3554   c = gfc_get_code ();
3555   *c = new_st;
3556
3557   if (gfc_match_eos () != MATCH_YES)
3558     goto syntax;
3559
3560   gfc_clear_new_st ();
3561   new_st.op = EXEC_FORALL;
3562   new_st.expr = mask;
3563   new_st.ext.forall_iterator = head;
3564   new_st.block = gfc_get_code ();
3565
3566   new_st.block->op = EXEC_FORALL;
3567   new_st.block->next = c;
3568
3569   *st = ST_FORALL;
3570   return MATCH_YES;
3571
3572 syntax:
3573   gfc_syntax_error (ST_FORALL);
3574
3575 cleanup:
3576   gfc_free_forall_iterator (head);
3577   gfc_free_expr (mask);
3578   gfc_free_statements (c);
3579   return MATCH_NO;
3580 }