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 obligatory symbol.  */
 795
 796 match
 797 gfc_match_program (void)
 798 {
 799   gfc_symbol *sym;
 800   match m;
 801
 802   m = gfc_match ("% %s%t", &sym);
 803
 804   if (m == MATCH_NO)
 805     {
 806       gfc_error ("Invalid form of PROGRAM statement at %C");
 807       m = MATCH_ERROR;
 808     }
 809
 810   if (m == MATCH_ERROR)
 811     return m;
 812
 813   if (gfc_add_flavor (&sym->attr, FL_PROGRAM, NULL) == FAILURE)
 814     return MATCH_ERROR;
 815
 816   gfc_new_block = sym;
 817
 818   return MATCH_YES;
 819 }
 820
 821
 822 /* Match a simple assignment statement.  */
 823
 824 match
 825 gfc_match_assignment (void)
 826 {
 827   gfc_expr *lvalue, *rvalue;
 828   locus old_loc;
 829   match m;
 830
 831   old_loc = gfc_current_locus;
 832
 833   lvalue = rvalue = NULL;
 834   m = gfc_match (" %v =", &lvalue);
 835   if (m != MATCH_YES)
 836     goto cleanup;
 837
 838   if (lvalue->symtree->n.sym->attr.flavor == FL_PARAMETER)
 839     {
 840       gfc_error ("Cannot assign to a PARAMETER variable at %C");
 841       m = MATCH_ERROR;
 842       goto cleanup;
 843     }
 844
 845   m = gfc_match (" %e%t", &rvalue);
 846   if (m != MATCH_YES)
 847     goto cleanup;
 848
 849   gfc_set_sym_referenced (lvalue->symtree->n.sym);
 850
 851   new_st.op = EXEC_ASSIGN;
 852   new_st.expr = lvalue;
 853   new_st.expr2 = rvalue;
 854
 855   gfc_check_do_variable (lvalue->symtree);
 856
 857   return MATCH_YES;
 858
 859 cleanup:
 860   gfc_current_locus = old_loc;
 861   gfc_free_expr (lvalue);
 862   gfc_free_expr (rvalue);
 863   return m;
 864 }
 865
 866
 867 /* Match a pointer assignment statement.  */
 868
 869 match
 870 gfc_match_pointer_assignment (void)
 871 {
 872   gfc_expr *lvalue, *rvalue;
 873   locus old_loc;
 874   match m;
 875
 876   old_loc = gfc_current_locus;
 877
 878   lvalue = rvalue = NULL;
 879
 880   m = gfc_match (" %v =>", &lvalue);
 881   if (m != MATCH_YES)
 882     {
 883       m = MATCH_NO;
 884       goto cleanup;
 885     }
 886
 887   m = gfc_match (" %e%t", &rvalue);
 888   if (m != MATCH_YES)
 889     goto cleanup;
 890
 891   new_st.op = EXEC_POINTER_ASSIGN;
 892   new_st.expr = lvalue;
 893   new_st.expr2 = rvalue;
 894
 895   return MATCH_YES;
 896
 897 cleanup:
 898   gfc_current_locus = old_loc;
 899   gfc_free_expr (lvalue);
 900   gfc_free_expr (rvalue);
 901   return m;
 902 }
 903
 904
 905 /* The IF statement is a bit of a pain.  First of all, there are three
 906    forms of it, the simple IF, the IF that starts a block and the
 907    arithmetic IF.
 908
 909    There is a problem with the simple IF and that is the fact that we
 910    only have a single level of undo information on symbols.  What this
 911    means is for a simple IF, we must re-match the whole IF statement
 912    multiple times in order to guarantee that the symbol table ends up
 913    in the proper state.  */
 914
 915 static match match_simple_forall (void);
 916 static match match_simple_where (void);
 917
 918 match
 919 gfc_match_if (gfc_statement * if_type)
 920 {
 921   gfc_expr *expr;
 922   gfc_st_label *l1, *l2, *l3;
 923   locus old_loc;
 924   gfc_code *p;
 925   match m, n;
 926
 927   n = gfc_match_label ();
 928   if (n == MATCH_ERROR)
 929     return n;
 930
 931   old_loc = gfc_current_locus;
 932
 933   m = gfc_match (" if ( %e", &expr);
 934   if (m != MATCH_YES)
 935     return m;
 936
 937   if (gfc_match_char (')') != MATCH_YES)
 938     {
 939       gfc_error ("Syntax error in IF-expression at %C");
 940       gfc_free_expr (expr);
 941       return MATCH_ERROR;
 942     }
 943
 944   m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
 945
 946   if (m == MATCH_YES)
 947     {
 948       if (n == MATCH_YES)
 949         {
 950           gfc_error
 951             ("Block label not appropriate for arithmetic IF statement "
 952              "at %C");
 953
 954           gfc_free_expr (expr);
 955           return MATCH_ERROR;
 956         }
 957
 958       if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
 959           || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
 960           || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
 961         {
 962
 963           gfc_free_expr (expr);
 964           return MATCH_ERROR;
 965         }
 966
 967       new_st.op = EXEC_ARITHMETIC_IF;
 968       new_st.expr = expr;
 969       new_st.label = l1;
 970       new_st.label2 = l2;
 971       new_st.label3 = l3;
 972
 973       *if_type = ST_ARITHMETIC_IF;
 974       return MATCH_YES;
 975     }
 976
 977   if (gfc_match (" then %t") == MATCH_YES)
 978     {
 979       new_st.op = EXEC_IF;
 980       new_st.expr = expr;
 981
 982       *if_type = ST_IF_BLOCK;
 983       return MATCH_YES;
 984     }
 985
 986   if (n == MATCH_YES)
 987     {
 988       gfc_error ("Block label is not appropriate IF statement at %C");
 989
 990       gfc_free_expr (expr);
 991       return MATCH_ERROR;
 992     }
 993
 994   /* At this point the only thing left is a simple IF statement.  At
 995      this point, n has to be MATCH_NO, so we don't have to worry about
 996      re-matching a block label.  From what we've got so far, try
 997      matching an assignment.  */
 998
 999   *if_type = ST_SIMPLE_IF;
1000
1001   m = gfc_match_assignment ();
1002   if (m == MATCH_YES)
1003     goto got_match;
1004
1005   gfc_free_expr (expr);
1006   gfc_undo_symbols ();
1007   gfc_current_locus = old_loc;
1008
1009   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match */
1010
1011   m = gfc_match_pointer_assignment ();
1012   if (m == MATCH_YES)
1013     goto got_match;
1014
1015   gfc_free_expr (expr);
1016   gfc_undo_symbols ();
1017   gfc_current_locus = old_loc;
1018
1019   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match */
1020
1021   /* Look at the next keyword to see which matcher to call.  Matching
1022      the keyword doesn't affect the symbol table, so we don't have to
1023      restore between tries.  */
1024
1025 #define match(string, subr, statement) \
1026   if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1027
1028   gfc_clear_error ();
1029
1030   match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1031     match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1032     match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1033     match ("call", gfc_match_call, ST_CALL)
1034     match ("close", gfc_match_close, ST_CLOSE)
1035     match ("continue", gfc_match_continue, ST_CONTINUE)
1036     match ("cycle", gfc_match_cycle, ST_CYCLE)
1037     match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1038     match ("end file", gfc_match_endfile, ST_END_FILE)
1039     match ("exit", gfc_match_exit, ST_EXIT)
1040     match ("forall", match_simple_forall, ST_FORALL)
1041     match ("go to", gfc_match_goto, ST_GOTO)
1042     match ("inquire", gfc_match_inquire, ST_INQUIRE)
1043     match ("nullify", gfc_match_nullify, ST_NULLIFY)
1044     match ("open", gfc_match_open, ST_OPEN)
1045     match ("pause", gfc_match_pause, ST_NONE)
1046     match ("print", gfc_match_print, ST_WRITE)
1047     match ("read", gfc_match_read, ST_READ)
1048     match ("return", gfc_match_return, ST_RETURN)
1049     match ("rewind", gfc_match_rewind, ST_REWIND)
1050     match ("stop", gfc_match_stop, ST_STOP)
1051     match ("where", match_simple_where, ST_WHERE)
1052     match ("write", gfc_match_write, ST_WRITE)
1053
1054   /* All else has failed, so give up.  See if any of the matchers has
1055      stored an error message of some sort.  */
1056     if (gfc_error_check () == 0)
1057     gfc_error ("Unclassifiable statement in IF-clause at %C");
1058
1059   gfc_free_expr (expr);
1060   return MATCH_ERROR;
1061
1062 got_match:
1063   if (m == MATCH_NO)
1064     gfc_error ("Syntax error in IF-clause at %C");
1065   if (m != MATCH_YES)
1066     {
1067       gfc_free_expr (expr);
1068       return MATCH_ERROR;
1069     }
1070
1071   /* At this point, we've matched the single IF and the action clause
1072      is in new_st.  Rearrange things so that the IF statement appears
1073      in new_st.  */
1074
1075   p = gfc_get_code ();
1076   p->next = gfc_get_code ();
1077   *p->next = new_st;
1078   p->next->loc = gfc_current_locus;
1079
1080   p->expr = expr;
1081   p->op = EXEC_IF;
1082
1083   gfc_clear_new_st ();
1084
1085   new_st.op = EXEC_IF;
1086   new_st.block = p;
1087
1088   return MATCH_YES;
1089 }
1090
1091 #undef match
1092
1093
1094 /* Match an ELSE statement.  */
1095
1096 match
1097 gfc_match_else (void)
1098 {
1099   char name[GFC_MAX_SYMBOL_LEN + 1];
1100
1101   if (gfc_match_eos () == MATCH_YES)
1102     return MATCH_YES;
1103
1104   if (gfc_match_name (name) != MATCH_YES
1105       || gfc_current_block () == NULL
1106       || gfc_match_eos () != MATCH_YES)
1107     {
1108       gfc_error ("Unexpected junk after ELSE statement at %C");
1109       return MATCH_ERROR;
1110     }
1111
1112   if (strcmp (name, gfc_current_block ()->name) != 0)
1113     {
1114       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1115                  name, gfc_current_block ()->name);
1116       return MATCH_ERROR;
1117     }
1118
1119   return MATCH_YES;
1120 }
1121
1122
1123 /* Match an ELSE IF statement.  */
1124
1125 match
1126 gfc_match_elseif (void)
1127 {
1128   char name[GFC_MAX_SYMBOL_LEN + 1];
1129   gfc_expr *expr;
1130   match m;
1131
1132   m = gfc_match (" ( %e ) then", &expr);
1133   if (m != MATCH_YES)
1134     return m;
1135
1136   if (gfc_match_eos () == MATCH_YES)
1137     goto done;
1138
1139   if (gfc_match_name (name) != MATCH_YES
1140       || gfc_current_block () == NULL
1141       || gfc_match_eos () != MATCH_YES)
1142     {
1143       gfc_error ("Unexpected junk after ELSE IF statement at %C");
1144       goto cleanup;
1145     }
1146
1147   if (strcmp (name, gfc_current_block ()->name) != 0)
1148     {
1149       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1150                  name, gfc_current_block ()->name);
1151       goto cleanup;
1152     }
1153
1154 done:
1155   new_st.op = EXEC_IF;
1156   new_st.expr = expr;
1157   return MATCH_YES;
1158
1159 cleanup:
1160   gfc_free_expr (expr);
1161   return MATCH_ERROR;
1162 }
1163
1164
1165 /* Free a gfc_iterator structure.  */
1166
1167 void
1168 gfc_free_iterator (gfc_iterator * iter, int flag)
1169 {
1170
1171   if (iter == NULL)
1172     return;
1173
1174   gfc_free_expr (iter->var);
1175   gfc_free_expr (iter->start);
1176   gfc_free_expr (iter->end);
1177   gfc_free_expr (iter->step);
1178
1179   if (flag)
1180     gfc_free (iter);
1181 }
1182
1183
1184 /* Match a DO statement.  */
1185
1186 match
1187 gfc_match_do (void)
1188 {
1189   gfc_iterator iter, *ip;
1190   locus old_loc;
1191   gfc_st_label *label;
1192   match m;
1193
1194   old_loc = gfc_current_locus;
1195
1196   label = NULL;
1197   iter.var = iter.start = iter.end = iter.step = NULL;
1198
1199   m = gfc_match_label ();
1200   if (m == MATCH_ERROR)
1201     return m;
1202
1203   if (gfc_match (" do") != MATCH_YES)
1204     return MATCH_NO;
1205
1206   m = gfc_match_st_label (&label, 0);
1207   if (m == MATCH_ERROR)
1208     goto cleanup;
1209
1210 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1211
1212   if (gfc_match_eos () == MATCH_YES)
1213     {
1214       iter.end = gfc_logical_expr (1, NULL);
1215       new_st.op = EXEC_DO_WHILE;
1216       goto done;
1217     }
1218
1219   /* match an optional comma, if no comma is found a space is obligatory.  */
1220   if (gfc_match_char(',') != MATCH_YES
1221       && gfc_match ("% ") != MATCH_YES)
1222     return MATCH_NO;
1223
1224   /* See if we have a DO WHILE.  */
1225   if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1226     {
1227       new_st.op = EXEC_DO_WHILE;
1228       goto done;
1229     }
1230
1231   /* The abortive DO WHILE may have done something to the symbol
1232      table, so we start over: */
1233   gfc_undo_symbols ();
1234   gfc_current_locus = old_loc;
1235
1236   gfc_match_label ();           /* This won't error */
1237   gfc_match (" do ");           /* This will work */
1238
1239   gfc_match_st_label (&label, 0);       /* Can't error out */
1240   gfc_match_char (',');         /* Optional comma */
1241
1242   m = gfc_match_iterator (&iter, 0);
1243   if (m == MATCH_NO)
1244     return MATCH_NO;
1245   if (m == MATCH_ERROR)
1246     goto cleanup;
1247
1248   gfc_check_do_variable (iter.var->symtree);
1249
1250   if (gfc_match_eos () != MATCH_YES)
1251     {
1252       gfc_syntax_error (ST_DO);
1253       goto cleanup;
1254     }
1255
1256   new_st.op = EXEC_DO;
1257
1258 done:
1259   if (label != NULL
1260       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1261     goto cleanup;
1262
1263   new_st.label = label;
1264
1265   if (new_st.op == EXEC_DO_WHILE)
1266     new_st.expr = iter.end;
1267   else
1268     {
1269       new_st.ext.iterator = ip = gfc_get_iterator ();
1270       *ip = iter;
1271     }
1272
1273   return MATCH_YES;
1274
1275 cleanup:
1276   gfc_free_iterator (&iter, 0);
1277
1278   return MATCH_ERROR;
1279 }
1280
1281
1282 /* Match an EXIT or CYCLE statement.  */
1283
1284 static match
1285 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1286 {
1287   gfc_state_data *p;
1288   gfc_symbol *sym;
1289   match m;
1290
1291   if (gfc_match_eos () == MATCH_YES)
1292     sym = NULL;
1293   else
1294     {
1295       m = gfc_match ("% %s%t", &sym);
1296       if (m == MATCH_ERROR)
1297         return MATCH_ERROR;
1298       if (m == MATCH_NO)
1299         {
1300           gfc_syntax_error (st);
1301           return MATCH_ERROR;
1302         }
1303
1304       if (sym->attr.flavor != FL_LABEL)
1305         {
1306           gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1307                      sym->name, gfc_ascii_statement (st));
1308           return MATCH_ERROR;
1309         }
1310     }
1311
1312   /* Find the loop mentioned specified by the label (or lack of a
1313      label).  */
1314   for (p = gfc_state_stack; p; p = p->previous)
1315     if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1316       break;
1317
1318   if (p == NULL)
1319     {
1320       if (sym == NULL)
1321         gfc_error ("%s statement at %C is not within a loop",
1322                    gfc_ascii_statement (st));
1323       else
1324         gfc_error ("%s statement at %C is not within loop '%s'",
1325                    gfc_ascii_statement (st), sym->name);
1326
1327       return MATCH_ERROR;
1328     }
1329
1330   /* Save the first statement in the loop - needed by the backend.  */
1331   new_st.ext.whichloop = p->head;
1332
1333   new_st.op = op;
1334 /*  new_st.sym = sym;*/
1335
1336   return MATCH_YES;
1337 }
1338
1339
1340 /* Match the EXIT statement.  */
1341
1342 match
1343 gfc_match_exit (void)
1344 {
1345
1346   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1347 }
1348
1349
1350 /* Match the CYCLE statement.  */
1351
1352 match
1353 gfc_match_cycle (void)
1354 {
1355
1356   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1357 }
1358
1359
1360 /* Match a number or character constant after a STOP or PAUSE statement.  */
1361
1362 static match
1363 gfc_match_stopcode (gfc_statement st)
1364 {
1365   int stop_code;
1366   gfc_expr *e;
1367   match m;
1368
1369   stop_code = 0;
1370   e = NULL;
1371
1372   if (gfc_match_eos () != MATCH_YES)
1373     {
1374       m = gfc_match_small_literal_int (&stop_code);
1375       if (m == MATCH_ERROR)
1376         goto cleanup;
1377
1378       if (m == MATCH_YES && stop_code > 99999)
1379         {
1380           gfc_error ("STOP code out of range at %C");
1381           goto cleanup;
1382         }
1383
1384       if (m == MATCH_NO)
1385         {
1386           /* Try a character constant.  */
1387           m = gfc_match_expr (&e);
1388           if (m == MATCH_ERROR)
1389             goto cleanup;
1390           if (m == MATCH_NO)
1391             goto syntax;
1392           if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1393             goto syntax;
1394         }
1395
1396       if (gfc_match_eos () != MATCH_YES)
1397         goto syntax;
1398     }
1399
1400   if (gfc_pure (NULL))
1401     {
1402       gfc_error ("%s statement not allowed in PURE procedure at %C",
1403                  gfc_ascii_statement (st));
1404       goto cleanup;
1405     }
1406
1407   new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1408   new_st.expr = e;
1409   new_st.ext.stop_code = stop_code;
1410
1411   return MATCH_YES;
1412
1413 syntax:
1414   gfc_syntax_error (st);
1415
1416 cleanup:
1417
1418   gfc_free_expr (e);
1419   return MATCH_ERROR;
1420 }
1421
1422 /* Match the (deprecated) PAUSE statement.  */
1423
1424 match
1425 gfc_match_pause (void)
1426 {
1427   match m;
1428
1429   m = gfc_match_stopcode (ST_PAUSE);
1430   if (m == MATCH_YES)
1431     {
1432       if (gfc_notify_std (GFC_STD_F95_DEL,
1433             "Obsolete: PAUSE statement at %C")
1434           == FAILURE)
1435         m = MATCH_ERROR;
1436     }
1437   return m;
1438 }
1439
1440
1441 /* Match the STOP statement.  */
1442
1443 match
1444 gfc_match_stop (void)
1445 {
1446   return gfc_match_stopcode (ST_STOP);
1447 }
1448
1449
1450 /* Match a CONTINUE statement.  */
1451
1452 match
1453 gfc_match_continue (void)
1454 {
1455
1456   if (gfc_match_eos () != MATCH_YES)
1457     {
1458       gfc_syntax_error (ST_CONTINUE);
1459       return MATCH_ERROR;
1460     }
1461
1462   new_st.op = EXEC_CONTINUE;
1463   return MATCH_YES;
1464 }
1465
1466
1467 /* Match the (deprecated) ASSIGN statement.  */
1468
1469 match
1470 gfc_match_assign (void)
1471 {
1472   gfc_expr *expr;
1473   gfc_st_label *label;
1474
1475   if (gfc_match (" %l", &label) == MATCH_YES)
1476     {
1477       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
1478         return MATCH_ERROR;
1479       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
1480         {
1481           if (gfc_notify_std (GFC_STD_F95_DEL,
1482                 "Obsolete: ASSIGN statement at %C")
1483               == FAILURE)
1484             return MATCH_ERROR;
1485
1486           expr->symtree->n.sym->attr.assign = 1;
1487
1488           new_st.op = EXEC_LABEL_ASSIGN;
1489           new_st.label = label;
1490           new_st.expr = expr;
1491           return MATCH_YES;
1492         }
1493     }
1494   return MATCH_NO;
1495 }
1496
1497
1498 /* Match the GO TO statement.  As a computed GOTO statement is
1499    matched, it is transformed into an equivalent SELECT block.  No
1500    tree is necessary, and the resulting jumps-to-jumps are
1501    specifically optimized away by the back end.  */
1502
1503 match
1504 gfc_match_goto (void)
1505 {
1506   gfc_code *head, *tail;
1507   gfc_expr *expr;
1508   gfc_case *cp;
1509   gfc_st_label *label;
1510   int i;
1511   match m;
1512
1513   if (gfc_match (" %l%t", &label) == MATCH_YES)
1514     {
1515       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1516         return MATCH_ERROR;
1517
1518       new_st.op = EXEC_GOTO;
1519       new_st.label = label;
1520       return MATCH_YES;
1521     }
1522
1523   /* The assigned GO TO statement.  */
1524
1525   if (gfc_match_variable (&expr, 0) == MATCH_YES)
1526     {
1527       if (gfc_notify_std (GFC_STD_F95_DEL,
1528                           "Obsolete: Assigned GOTO statement at %C")
1529           == FAILURE)
1530         return MATCH_ERROR;
1531
1532       expr->symtree->n.sym->attr.assign = 1;
1533       new_st.op = EXEC_GOTO;
1534       new_st.expr = expr;
1535
1536       if (gfc_match_eos () == MATCH_YES)
1537         return MATCH_YES;
1538
1539       /* Match label list.  */
1540       gfc_match_char (',');
1541       if (gfc_match_char ('(') != MATCH_YES)
1542         {
1543           gfc_syntax_error (ST_GOTO);
1544           return MATCH_ERROR;
1545         }
1546       head = tail = NULL;
1547
1548       do
1549         {
1550           m = gfc_match_st_label (&label, 0);
1551           if (m != MATCH_YES)
1552             goto syntax;
1553
1554           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1555             goto cleanup;
1556
1557           if (head == NULL)
1558             head = tail = gfc_get_code ();
1559           else
1560             {
1561               tail->block = gfc_get_code ();
1562               tail = tail->block;
1563             }
1564
1565           tail->label = label;
1566           tail->op = EXEC_GOTO;
1567         }
1568       while (gfc_match_char (',') == MATCH_YES);
1569
1570       if (gfc_match (")%t") != MATCH_YES)
1571         goto syntax;
1572
1573       if (head == NULL)
1574         {
1575            gfc_error (
1576                "Statement label list in GOTO at %C cannot be empty");
1577            goto syntax;
1578         }
1579       new_st.block = head;
1580
1581       return MATCH_YES;
1582     }
1583
1584   /* Last chance is a computed GO TO statement.  */
1585   if (gfc_match_char ('(') != MATCH_YES)
1586     {
1587       gfc_syntax_error (ST_GOTO);
1588       return MATCH_ERROR;
1589     }
1590
1591   head = tail = NULL;
1592   i = 1;
1593
1594   do
1595     {
1596       m = gfc_match_st_label (&label, 0);
1597       if (m != MATCH_YES)
1598         goto syntax;
1599
1600       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1601         goto cleanup;
1602
1603       if (head == NULL)
1604         head = tail = gfc_get_code ();
1605       else
1606         {
1607           tail->block = gfc_get_code ();
1608           tail = tail->block;
1609         }
1610
1611       cp = gfc_get_case ();
1612       cp->low = cp->high = gfc_int_expr (i++);
1613
1614       tail->op = EXEC_SELECT;
1615       tail->ext.case_list = cp;
1616
1617       tail->next = gfc_get_code ();
1618       tail->next->op = EXEC_GOTO;
1619       tail->next->label = label;
1620     }
1621   while (gfc_match_char (',') == MATCH_YES);
1622
1623   if (gfc_match_char (')') != MATCH_YES)
1624     goto syntax;
1625
1626   if (head == NULL)
1627     {
1628       gfc_error ("Statement label list in GOTO at %C cannot be empty");
1629       goto syntax;
1630     }
1631
1632   /* Get the rest of the statement.  */
1633   gfc_match_char (',');
1634
1635   if (gfc_match (" %e%t", &expr) != MATCH_YES)
1636     goto syntax;
1637
1638   /* At this point, a computed GOTO has been fully matched and an
1639      equivalent SELECT statement constructed.  */
1640
1641   new_st.op = EXEC_SELECT;
1642   new_st.expr = NULL;
1643
1644   /* Hack: For a "real" SELECT, the expression is in expr. We put
1645      it in expr2 so we can distinguish then and produce the correct
1646      diagnostics.  */
1647   new_st.expr2 = expr;
1648   new_st.block = head;
1649   return MATCH_YES;
1650
1651 syntax:
1652   gfc_syntax_error (ST_GOTO);
1653 cleanup:
1654   gfc_free_statements (head);
1655   return MATCH_ERROR;
1656 }
1657
1658
1659 /* Frees a list of gfc_alloc structures.  */
1660
1661 void
1662 gfc_free_alloc_list (gfc_alloc * p)
1663 {
1664   gfc_alloc *q;
1665
1666   for (; p; p = q)
1667     {
1668       q = p->next;
1669       gfc_free_expr (p->expr);
1670       gfc_free (p);
1671     }
1672 }
1673
1674
1675 /* Match an ALLOCATE statement.  */
1676
1677 match
1678 gfc_match_allocate (void)
1679 {
1680   gfc_alloc *head, *tail;
1681   gfc_expr *stat;
1682   match m;
1683
1684   head = tail = NULL;
1685   stat = NULL;
1686
1687   if (gfc_match_char ('(') != MATCH_YES)
1688     goto syntax;
1689
1690   for (;;)
1691     {
1692       if (head == NULL)
1693         head = tail = gfc_get_alloc ();
1694       else
1695         {
1696           tail->next = gfc_get_alloc ();
1697           tail = tail->next;
1698         }
1699
1700       m = gfc_match_variable (&tail->expr, 0);
1701       if (m == MATCH_NO)
1702         goto syntax;
1703       if (m == MATCH_ERROR)
1704         goto cleanup;
1705
1706       if (gfc_check_do_variable (tail->expr->symtree))
1707         goto cleanup;
1708
1709       if (gfc_pure (NULL)
1710           && gfc_impure_variable (tail->expr->symtree->n.sym))
1711         {
1712           gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1713                      "PURE procedure");
1714           goto cleanup;
1715         }
1716
1717       if (gfc_match_char (',') != MATCH_YES)
1718         break;
1719
1720       m = gfc_match (" stat = %v", &stat);
1721       if (m == MATCH_ERROR)
1722         goto cleanup;
1723       if (m == MATCH_YES)
1724         break;
1725     }
1726
1727   if (stat != NULL)
1728     {
1729       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1730         {
1731           gfc_error
1732             ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1733              "INTENT(IN)", stat->symtree->n.sym->name);
1734           goto cleanup;
1735         }
1736
1737       if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
1738         {
1739           gfc_error
1740             ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1741              "procedure");
1742           goto cleanup;
1743         }
1744
1745       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1746         {
1747           gfc_error("STAT expression at %C must be a variable");
1748           goto cleanup;
1749         }
1750
1751       gfc_check_do_variable(stat->symtree);
1752     }
1753
1754   if (gfc_match (" )%t") != MATCH_YES)
1755     goto syntax;
1756
1757   new_st.op = EXEC_ALLOCATE;
1758   new_st.expr = stat;
1759   new_st.ext.alloc_list = head;
1760
1761   return MATCH_YES;
1762
1763 syntax:
1764   gfc_syntax_error (ST_ALLOCATE);
1765
1766 cleanup:
1767   gfc_free_expr (stat);
1768   gfc_free_alloc_list (head);
1769   return MATCH_ERROR;
1770 }
1771
1772
1773 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1774    a set of pointer assignments to intrinsic NULL().  */
1775
1776 match
1777 gfc_match_nullify (void)
1778 {
1779   gfc_code *tail;
1780   gfc_expr *e, *p;
1781   match m;
1782
1783   tail = NULL;
1784
1785   if (gfc_match_char ('(') != MATCH_YES)
1786     goto syntax;
1787
1788   for (;;)
1789     {
1790       m = gfc_match_variable (&p, 0);
1791       if (m == MATCH_ERROR)
1792         goto cleanup;
1793       if (m == MATCH_NO)
1794         goto syntax;
1795
1796       if (gfc_check_do_variable(p->symtree))
1797         goto cleanup;
1798
1799       if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
1800         {
1801           gfc_error
1802             ("Illegal variable in NULLIFY at %C for a PURE procedure");
1803           goto cleanup;
1804         }
1805
1806       /* build ' => NULL() ' */
1807       e = gfc_get_expr ();
1808       e->where = gfc_current_locus;
1809       e->expr_type = EXPR_NULL;
1810       e->ts.type = BT_UNKNOWN;
1811
1812       /* Chain to list */
1813       if (tail == NULL)
1814         tail = &new_st;
1815       else
1816         {
1817           tail->next = gfc_get_code ();
1818           tail = tail->next;
1819         }
1820
1821       tail->op = EXEC_POINTER_ASSIGN;
1822       tail->expr = p;
1823       tail->expr2 = e;
1824
1825       if (gfc_match_char (')') == MATCH_YES)
1826         break;
1827       if (gfc_match_char (',') != MATCH_YES)
1828         goto syntax;
1829     }
1830
1831   return MATCH_YES;
1832
1833 syntax:
1834   gfc_syntax_error (ST_NULLIFY);
1835
1836 cleanup:
1837   gfc_free_statements (tail);
1838   return MATCH_ERROR;
1839 }
1840
1841
1842 /* Match a DEALLOCATE statement.  */
1843
1844 match
1845 gfc_match_deallocate (void)
1846 {
1847   gfc_alloc *head, *tail;
1848   gfc_expr *stat;
1849   match m;
1850
1851   head = tail = NULL;
1852   stat = NULL;
1853
1854   if (gfc_match_char ('(') != MATCH_YES)
1855     goto syntax;
1856
1857   for (;;)
1858     {
1859       if (head == NULL)
1860         head = tail = gfc_get_alloc ();
1861       else
1862         {
1863           tail->next = gfc_get_alloc ();
1864           tail = tail->next;
1865         }
1866
1867       m = gfc_match_variable (&tail->expr, 0);
1868       if (m == MATCH_ERROR)
1869         goto cleanup;
1870       if (m == MATCH_NO)
1871         goto syntax;
1872
1873       if (gfc_check_do_variable (tail->expr->symtree))
1874         goto cleanup;
1875
1876       if (gfc_pure (NULL)
1877           && gfc_impure_variable (tail->expr->symtree->n.sym))
1878         {
1879           gfc_error
1880             ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
1881              "procedure");
1882           goto cleanup;
1883         }
1884
1885       if (gfc_match_char (',') != MATCH_YES)
1886         break;
1887
1888       m = gfc_match (" stat = %v", &stat);
1889       if (m == MATCH_ERROR)
1890         goto cleanup;
1891       if (m == MATCH_YES)
1892         break;
1893     }
1894
1895   if (stat != NULL)
1896     {
1897       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1898         {
1899           gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
1900                      "cannot be INTENT(IN)", stat->symtree->n.sym->name);
1901           goto cleanup;
1902         }
1903
1904       if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
1905         {
1906           gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
1907                      "for a PURE procedure");
1908           goto cleanup;
1909         }
1910
1911       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1912         {
1913           gfc_error("STAT expression at %C must be a variable");
1914           goto cleanup;
1915         }
1916
1917       gfc_check_do_variable(stat->symtree);
1918     }
1919
1920   if (gfc_match (" )%t") != MATCH_YES)
1921     goto syntax;
1922
1923   new_st.op = EXEC_DEALLOCATE;
1924   new_st.expr = stat;
1925   new_st.ext.alloc_list = head;
1926
1927   return MATCH_YES;
1928
1929 syntax:
1930   gfc_syntax_error (ST_DEALLOCATE);
1931
1932 cleanup:
1933   gfc_free_expr (stat);
1934   gfc_free_alloc_list (head);
1935   return MATCH_ERROR;
1936 }
1937
1938
1939 /* Match a RETURN statement.  */
1940
1941 match
1942 gfc_match_return (void)
1943 {
1944   gfc_expr *e;
1945   match m;
1946   gfc_compile_state s;
1947
1948   gfc_enclosing_unit (&s);
1949   if (s == COMP_PROGRAM
1950       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
1951                          "main program at %C") == FAILURE)
1952       return MATCH_ERROR;
1953
1954   e = NULL;
1955   if (gfc_match_eos () == MATCH_YES)
1956     goto done;
1957
1958   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
1959     {
1960       gfc_error ("Alternate RETURN statement at %C is only allowed within "
1961                  "a SUBROUTINE");
1962       goto cleanup;
1963     }
1964
1965   m = gfc_match ("% %e%t", &e);
1966   if (m == MATCH_YES)
1967     goto done;
1968   if (m == MATCH_ERROR)
1969     goto cleanup;
1970
1971   gfc_syntax_error (ST_RETURN);
1972
1973 cleanup:
1974   gfc_free_expr (e);
1975   return MATCH_ERROR;
1976
1977 done:
1978   new_st.op = EXEC_RETURN;
1979   new_st.expr = e;
1980
1981   return MATCH_YES;
1982 }
1983
1984
1985 /* Match a CALL statement.  The tricky part here are possible
1986    alternate return specifiers.  We handle these by having all
1987    "subroutines" actually return an integer via a register that gives
1988    the return number.  If the call specifies alternate returns, we
1989    generate code for a SELECT statement whose case clauses contain
1990    GOTOs to the various labels.  */
1991
1992 match
1993 gfc_match_call (void)
1994 {
1995   char name[GFC_MAX_SYMBOL_LEN + 1];
1996   gfc_actual_arglist *a, *arglist;
1997   gfc_case *new_case;
1998   gfc_symbol *sym;
1999   gfc_symtree *st;
2000   gfc_code *c;
2001   match m;
2002   int i;
2003
2004   arglist = NULL;
2005
2006   m = gfc_match ("% %n", name);
2007   if (m == MATCH_NO)
2008     goto syntax;
2009   if (m != MATCH_YES)
2010     return m;
2011
2012   if (gfc_get_ha_sym_tree (name, &st))
2013     return MATCH_ERROR;
2014
2015   sym = st->n.sym;
2016   gfc_set_sym_referenced (sym);
2017
2018   if (!sym->attr.generic
2019       && !sym->attr.subroutine
2020       && gfc_add_subroutine (&sym->attr, NULL) == FAILURE)
2021     return MATCH_ERROR;
2022
2023   if (gfc_match_eos () != MATCH_YES)
2024     {
2025       m = gfc_match_actual_arglist (1, &arglist);
2026       if (m == MATCH_NO)
2027         goto syntax;
2028       if (m == MATCH_ERROR)
2029         goto cleanup;
2030
2031       if (gfc_match_eos () != MATCH_YES)
2032         goto syntax;
2033     }
2034
2035   /* If any alternate return labels were found, construct a SELECT
2036      statement that will jump to the right place.  */
2037
2038   i = 0;
2039   for (a = arglist; a; a = a->next)
2040     if (a->expr == NULL)
2041         i = 1;
2042
2043   if (i)
2044     {
2045       gfc_symtree *select_st;
2046       gfc_symbol *select_sym;
2047       char name[GFC_MAX_SYMBOL_LEN + 1];
2048
2049       new_st.next = c = gfc_get_code ();
2050       c->op = EXEC_SELECT;
2051       sprintf (name, "_result_%s",sym->name);
2052       gfc_get_ha_sym_tree (name, &select_st);  /* Can't fail */
2053
2054       select_sym = select_st->n.sym;
2055       select_sym->ts.type = BT_INTEGER;
2056       select_sym->ts.kind = gfc_default_integer_kind ();
2057       gfc_set_sym_referenced (select_sym);
2058       c->expr = gfc_get_expr ();
2059       c->expr->expr_type = EXPR_VARIABLE;
2060       c->expr->symtree = select_st;
2061       c->expr->ts = select_sym->ts;
2062       c->expr->where = gfc_current_locus;
2063
2064       i = 0;
2065       for (a = arglist; a; a = a->next)
2066         {
2067           if (a->expr != NULL)
2068             continue;
2069
2070           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2071             continue;
2072
2073           i++;
2074
2075           c->block = gfc_get_code ();
2076           c = c->block;
2077           c->op = EXEC_SELECT;
2078
2079           new_case = gfc_get_case ();
2080           new_case->high = new_case->low = gfc_int_expr (i);
2081           c->ext.case_list = new_case;
2082
2083           c->next = gfc_get_code ();
2084           c->next->op = EXEC_GOTO;
2085           c->next->label = a->label;
2086         }
2087     }
2088
2089   new_st.op = EXEC_CALL;
2090   new_st.symtree = st;
2091   new_st.ext.actual = arglist;
2092
2093   return MATCH_YES;
2094
2095 syntax:
2096   gfc_syntax_error (ST_CALL);
2097
2098 cleanup:
2099   gfc_free_actual_arglist (arglist);
2100   return MATCH_ERROR;
2101 }
2102
2103
2104 /* Given a name, return a pointer to the common head structure,
2105    creating it if it does not exist. If FROM_MODULE is non-zero, we
2106    mangle the name so that it doesn't interfere with commons defined
2107    in the using namespace.
2108    TODO: Add to global symbol tree.  */
2109
2110 gfc_common_head *
2111 gfc_get_common (const char *name, int from_module)
2112 {
2113   gfc_symtree *st;
2114   static int serial = 0;
2115   char mangled_name[GFC_MAX_SYMBOL_LEN+1];
2116
2117   if (from_module)
2118     {
2119       /* A use associated common block is only needed to correctly layout
2120          the variables it contains.  */
2121       snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2122       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2123     }
2124   else
2125     {
2126       st = gfc_find_symtree (gfc_current_ns->common_root, name);
2127
2128       if (st == NULL)
2129         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2130     }
2131
2132   if (st->n.common == NULL)
2133     {
2134       st->n.common = gfc_get_common_head ();
2135       st->n.common->where = gfc_current_locus;
2136       strcpy (st->n.common->name, name);
2137     }
2138
2139   return st->n.common;
2140 }
2141
2142
2143 /* Match a common block name.  */
2144
2145 static match
2146 match_common_name (char *name)
2147 {
2148   match m;
2149
2150   if (gfc_match_char ('/') == MATCH_NO)
2151     {
2152       name[0] = '\0';
2153       return MATCH_YES;
2154     }
2155
2156   if (gfc_match_char ('/') == MATCH_YES)
2157     {
2158       name[0] = '\0';
2159       return MATCH_YES;
2160     }
2161
2162   m = gfc_match_name (name);
2163
2164   if (m == MATCH_ERROR)
2165     return MATCH_ERROR;
2166   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2167     return MATCH_YES;
2168
2169   gfc_error ("Syntax error in common block name at %C");
2170   return MATCH_ERROR;
2171 }
2172
2173
2174 /* Match a COMMON statement.  */
2175
2176 match
2177 gfc_match_common (void)
2178 {
2179   gfc_symbol *sym, **head, *tail, *old_blank_common;
2180   char name[GFC_MAX_SYMBOL_LEN+1];
2181   gfc_common_head *t;
2182   gfc_array_spec *as;
2183   match m;
2184
2185   old_blank_common = gfc_current_ns->blank_common.head;
2186   if (old_blank_common)
2187     {
2188       while (old_blank_common->common_next)
2189         old_blank_common = old_blank_common->common_next;
2190     }
2191
2192   as = NULL;
2193
2194   if (gfc_match_eos () == MATCH_YES)
2195     goto syntax;
2196
2197   for (;;)
2198     {
2199       m = match_common_name (name);
2200       if (m == MATCH_ERROR)
2201         goto cleanup;
2202
2203       if (name[0] == '\0')
2204         {
2205           t = &gfc_current_ns->blank_common;
2206           if (t->head == NULL)
2207             t->where = gfc_current_locus;
2208           head = &t->head;
2209         }
2210       else
2211         {
2212           t = gfc_get_common (name, 0);
2213           head = &t->head;
2214         }
2215
2216       if (*head == NULL)
2217         tail = NULL;
2218       else
2219         {
2220           tail = *head;
2221           while (tail->common_next)
2222             tail = tail->common_next;
2223         }
2224
2225       /* Grab the list of symbols.  */
2226       if (gfc_match_eos () == MATCH_YES)
2227         goto done;
2228
2229       for (;;)
2230         {
2231           m = gfc_match_symbol (&sym, 0);
2232           if (m == MATCH_ERROR)
2233             goto cleanup;
2234           if (m == MATCH_NO)
2235             goto syntax;
2236
2237           if (sym->attr.in_common)
2238             {
2239               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2240                          sym->name);
2241               goto cleanup;
2242             }
2243
2244           if (gfc_add_in_common (&sym->attr, NULL) == FAILURE)
2245             goto cleanup;
2246
2247           if (sym->value != NULL
2248               && (name[0] == '\0' || !sym->attr.data))
2249             {
2250               if (name[0] == '\0')
2251                 gfc_error ("Previously initialized symbol '%s' in "
2252                            "blank COMMON block at %C", sym->name);
2253               else
2254                 gfc_error ("Previously initialized symbol '%s' in "
2255                            "COMMON block '%s' at %C", sym->name, name);
2256               goto cleanup;
2257             }
2258
2259           if (gfc_add_in_common (&sym->attr, NULL) == FAILURE)
2260             goto cleanup;
2261
2262           /* Derived type names must have the SEQUENCE attribute.  */
2263           if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2264             {
2265               gfc_error
2266                 ("Derived type variable in COMMON at %C does not have the "
2267                  "SEQUENCE attribute");
2268               goto cleanup;
2269             }
2270
2271           if (tail != NULL)
2272             tail->common_next = sym;
2273           else
2274             *head = sym;
2275
2276           tail = sym;
2277
2278           /* Deal with an optional array specification after the
2279              symbol name.  */
2280           m = gfc_match_array_spec (&as);
2281           if (m == MATCH_ERROR)
2282             goto cleanup;
2283
2284           if (m == MATCH_YES)
2285             {
2286               if (as->type != AS_EXPLICIT)
2287                 {
2288                   gfc_error
2289                     ("Array specification for symbol '%s' in COMMON at %C "
2290                      "must be explicit", sym->name);
2291                   goto cleanup;
2292                 }
2293
2294               if (gfc_add_dimension (&sym->attr, NULL) == FAILURE)
2295                 goto cleanup;
2296
2297               if (sym->attr.pointer)
2298                 {
2299                   gfc_error
2300                     ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2301                      sym->name);
2302                   goto cleanup;
2303                 }
2304
2305               sym->as = as;
2306               as = NULL;
2307             }
2308
2309           if (gfc_match_eos () == MATCH_YES)
2310             goto done;
2311           if (gfc_peek_char () == '/')
2312             break;
2313           if (gfc_match_char (',') != MATCH_YES)
2314             goto syntax;
2315           if (gfc_peek_char () == '/')
2316             break;
2317         }
2318     }
2319
2320 done:
2321   return MATCH_YES;
2322
2323 syntax:
2324   gfc_syntax_error (ST_COMMON);
2325
2326 cleanup:
2327   if (old_blank_common)
2328     old_blank_common->common_next = NULL;
2329   else
2330     gfc_current_ns->blank_common.head = NULL;
2331   gfc_free_array_spec (as);
2332   return MATCH_ERROR;
2333 }
2334
2335
2336 /* Match a BLOCK DATA program unit.  */
2337
2338 match
2339 gfc_match_block_data (void)
2340 {
2341   char name[GFC_MAX_SYMBOL_LEN + 1];
2342   gfc_symbol *sym;
2343   match m;
2344
2345   if (gfc_match_eos () == MATCH_YES)
2346     {
2347       gfc_new_block = NULL;
2348       return MATCH_YES;
2349     }
2350
2351   m = gfc_match ("% %n%t", name);
2352   if (m != MATCH_YES)
2353     return MATCH_ERROR;
2354
2355   if (gfc_get_symbol (name, NULL, &sym))
2356     return MATCH_ERROR;
2357
2358   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, NULL) == FAILURE)
2359     return MATCH_ERROR;
2360
2361   gfc_new_block = sym;
2362
2363   return MATCH_YES;
2364 }
2365
2366
2367 /* Free a namelist structure.  */
2368
2369 void
2370 gfc_free_namelist (gfc_namelist * name)
2371 {
2372   gfc_namelist *n;
2373
2374   for (; name; name = n)
2375     {
2376       n = name->next;
2377       gfc_free (name);
2378     }
2379 }
2380
2381
2382 /* Match a NAMELIST statement.  */
2383
2384 match
2385 gfc_match_namelist (void)
2386 {
2387   gfc_symbol *group_name, *sym;
2388   gfc_namelist *nl;
2389   match m, m2;
2390
2391   m = gfc_match (" / %s /", &group_name);
2392   if (m == MATCH_NO)
2393     goto syntax;
2394   if (m == MATCH_ERROR)
2395     goto error;
2396
2397   for (;;)
2398     {
2399       if (group_name->ts.type != BT_UNKNOWN)
2400         {
2401           gfc_error
2402             ("Namelist group name '%s' at %C already has a basic type "
2403              "of %s", group_name->name, gfc_typename (&group_name->ts));
2404           return MATCH_ERROR;
2405         }
2406
2407       if (group_name->attr.flavor != FL_NAMELIST
2408           && gfc_add_flavor (&group_name->attr, FL_NAMELIST, NULL) == FAILURE)
2409         return MATCH_ERROR;
2410
2411       for (;;)
2412         {
2413           m = gfc_match_symbol (&sym, 1);
2414           if (m == MATCH_NO)
2415             goto syntax;
2416           if (m == MATCH_ERROR)
2417             goto error;
2418
2419           if (sym->attr.in_namelist == 0
2420               && gfc_add_in_namelist (&sym->attr, NULL) == FAILURE)
2421             goto error;
2422
2423           /* TODO: worry about PRIVATE members of a PUBLIC namelist
2424              group.  */
2425
2426           nl = gfc_get_namelist ();
2427           nl->sym = sym;
2428
2429           if (group_name->namelist == NULL)
2430             group_name->namelist = group_name->namelist_tail = nl;
2431           else
2432             {
2433               group_name->namelist_tail->next = nl;
2434               group_name->namelist_tail = nl;
2435             }
2436
2437           if (gfc_match_eos () == MATCH_YES)
2438             goto done;
2439
2440           m = gfc_match_char (',');
2441
2442           if (gfc_match_char ('/') == MATCH_YES)
2443             {
2444               m2 = gfc_match (" %s /", &group_name);
2445               if (m2 == MATCH_YES)
2446                 break;
2447               if (m2 == MATCH_ERROR)
2448                 goto error;
2449               goto syntax;
2450             }
2451
2452           if (m != MATCH_YES)
2453             goto syntax;
2454         }
2455     }
2456
2457 done:
2458   return MATCH_YES;
2459
2460 syntax:
2461   gfc_syntax_error (ST_NAMELIST);
2462
2463 error:
2464   return MATCH_ERROR;
2465 }
2466
2467
2468 /* Match a MODULE statement.  */
2469
2470 match
2471 gfc_match_module (void)
2472 {
2473   match m;
2474
2475   m = gfc_match (" %s%t", &gfc_new_block);
2476   if (m != MATCH_YES)
2477     return m;
2478
2479   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, NULL) == FAILURE)
2480     return MATCH_ERROR;
2481
2482   return MATCH_YES;
2483 }
2484
2485
2486 /* Free equivalence sets and lists.  Recursively is the easiest way to
2487    do this.  */
2488
2489 void
2490 gfc_free_equiv (gfc_equiv * eq)
2491 {
2492
2493   if (eq == NULL)
2494     return;
2495
2496   gfc_free_equiv (eq->eq);
2497   gfc_free_equiv (eq->next);
2498
2499   gfc_free_expr (eq->expr);
2500   gfc_free (eq);
2501 }
2502
2503
2504 /* Match an EQUIVALENCE statement.  */
2505
2506 match
2507 gfc_match_equivalence (void)
2508 {
2509   gfc_equiv *eq, *set, *tail;
2510   gfc_ref *ref;
2511   match m;
2512
2513   tail = NULL;
2514
2515   for (;;)
2516     {
2517       eq = gfc_get_equiv ();
2518       if (tail == NULL)
2519         tail = eq;
2520
2521       eq->next = gfc_current_ns->equiv;
2522       gfc_current_ns->equiv = eq;
2523
2524       if (gfc_match_char ('(') != MATCH_YES)
2525         goto syntax;
2526
2527       set = eq;
2528
2529       for (;;)
2530         {
2531           m = gfc_match_variable (&set->expr, 1);
2532           if (m == MATCH_ERROR)
2533             goto cleanup;
2534           if (m == MATCH_NO)
2535             goto syntax;
2536
2537           for (ref = set->expr->ref; ref; ref = ref->next)
2538             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2539               {
2540                 gfc_error
2541                   ("Array reference in EQUIVALENCE at %C cannot be an "
2542                    "array section");
2543                 goto cleanup;
2544               }
2545
2546           if (gfc_match_char (')') == MATCH_YES)
2547             break;
2548           if (gfc_match_char (',') != MATCH_YES)
2549             goto syntax;
2550
2551           set->eq = gfc_get_equiv ();
2552           set = set->eq;
2553         }
2554
2555       if (gfc_match_eos () == MATCH_YES)
2556         break;
2557       if (gfc_match_char (',') != MATCH_YES)
2558         goto syntax;
2559     }
2560
2561   return MATCH_YES;
2562
2563 syntax:
2564   gfc_syntax_error (ST_EQUIVALENCE);
2565
2566 cleanup:
2567   eq = tail->next;
2568   tail->next = NULL;
2569
2570   gfc_free_equiv (gfc_current_ns->equiv);
2571   gfc_current_ns->equiv = eq;
2572
2573   return MATCH_ERROR;
2574 }
2575
2576
2577 /* Match a statement function declaration.  It is so easy to match
2578    non-statement function statements with a MATCH_ERROR as opposed to
2579    MATCH_NO that we suppress error message in most cases.  */
2580
2581 match
2582 gfc_match_st_function (void)
2583 {
2584   gfc_error_buf old_error;
2585   gfc_symbol *sym;
2586   gfc_expr *expr;
2587   match m;
2588
2589   m = gfc_match_symbol (&sym, 0);
2590   if (m != MATCH_YES)
2591     return m;
2592
2593   gfc_push_error (&old_error);
2594
2595   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, NULL) == FAILURE)
2596     goto undo_error;
2597
2598   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2599     goto undo_error;
2600
2601   m = gfc_match (" = %e%t", &expr);
2602   if (m == MATCH_NO)
2603     goto undo_error;
2604   if (m == MATCH_ERROR)
2605     return m;
2606
2607   sym->value = expr;
2608
2609   return MATCH_YES;
2610
2611 undo_error:
2612   gfc_pop_error (&old_error);
2613   return MATCH_NO;
2614 }
2615
2616
2617 /********************* DATA statement subroutines *********************/
2618
2619 /* Free a gfc_data_variable structure and everything beneath it.  */
2620
2621 static void
2622 free_variable (gfc_data_variable * p)
2623 {
2624   gfc_data_variable *q;
2625
2626   for (; p; p = q)
2627     {
2628       q = p->next;
2629       gfc_free_expr (p->expr);
2630       gfc_free_iterator (&p->iter, 0);
2631       free_variable (p->list);
2632
2633       gfc_free (p);
2634     }
2635 }
2636
2637
2638 /* Free a gfc_data_value structure and everything beneath it.  */
2639
2640 static void
2641 free_value (gfc_data_value * p)
2642 {
2643   gfc_data_value *q;
2644
2645   for (; p; p = q)
2646     {
2647       q = p->next;
2648       gfc_free_expr (p->expr);
2649       gfc_free (p);
2650     }
2651 }
2652
2653
2654 /* Free a list of gfc_data structures.  */
2655
2656 void
2657 gfc_free_data (gfc_data * p)
2658 {
2659   gfc_data *q;
2660
2661   for (; p; p = q)
2662     {
2663       q = p->next;
2664
2665       free_variable (p->var);
2666       free_value (p->value);
2667
2668       gfc_free (p);
2669     }
2670 }
2671
2672
2673 static match var_element (gfc_data_variable *);
2674
2675 /* Match a list of variables terminated by an iterator and a right
2676    parenthesis.  */
2677
2678 static match
2679 var_list (gfc_data_variable * parent)
2680 {
2681   gfc_data_variable *tail, var;
2682   match m;
2683
2684   m = var_element (&var);
2685   if (m == MATCH_ERROR)
2686     return MATCH_ERROR;
2687   if (m == MATCH_NO)
2688     goto syntax;
2689
2690   tail = gfc_get_data_variable ();
2691   *tail = var;
2692
2693   parent->list = tail;
2694
2695   for (;;)
2696     {
2697       if (gfc_match_char (',') != MATCH_YES)
2698         goto syntax;
2699
2700       m = gfc_match_iterator (&parent->iter, 1);
2701       if (m == MATCH_YES)
2702         break;
2703       if (m == MATCH_ERROR)
2704         return MATCH_ERROR;
2705
2706       m = var_element (&var);
2707       if (m == MATCH_ERROR)
2708         return MATCH_ERROR;
2709       if (m == MATCH_NO)
2710         goto syntax;
2711
2712       tail->next = gfc_get_data_variable ();
2713       tail = tail->next;
2714
2715       *tail = var;
2716     }
2717
2718   if (gfc_match_char (')') != MATCH_YES)
2719     goto syntax;
2720   return MATCH_YES;
2721
2722 syntax:
2723   gfc_syntax_error (ST_DATA);
2724   return MATCH_ERROR;
2725 }
2726
2727
2728 /* Match a single element in a data variable list, which can be a
2729    variable-iterator list.  */
2730
2731 static match
2732 var_element (gfc_data_variable * new)
2733 {
2734   match m;
2735   gfc_symbol *sym;
2736
2737   memset (new, '\0', sizeof (gfc_data_variable));
2738
2739   if (gfc_match_char ('(') == MATCH_YES)
2740     return var_list (new);
2741
2742   m = gfc_match_variable (&new->expr, 0);
2743   if (m != MATCH_YES)
2744     return m;
2745
2746   sym = new->expr->symtree->n.sym;
2747
2748   if(sym->value != NULL)
2749     {
2750       gfc_error ("Variable '%s' at %C already has an initialization",
2751                  sym->name);
2752       return MATCH_ERROR;
2753     }
2754
2755 #if 0 // TODO: Find out where to move this message
2756   if (sym->attr.in_common)
2757     /* See if sym is in the blank common block.  */
2758     for (t = &sym->ns->blank_common; t; t = t->common_next)
2759       if (sym == t->head)
2760         {
2761           gfc_error ("DATA statement at %C may not initialize variable "
2762                      "'%s' from blank COMMON", sym->name);
2763           return MATCH_ERROR;
2764         }
2765 #endif
2766
2767   if (gfc_add_data (&sym->attr, &new->expr->where) == FAILURE)
2768     return MATCH_ERROR;
2769
2770   return MATCH_YES;
2771 }
2772
2773
2774 /* Match the top-level list of data variables.  */
2775
2776 static match
2777 top_var_list (gfc_data * d)
2778 {
2779   gfc_data_variable var, *tail, *new;
2780   match m;
2781
2782   tail = NULL;
2783
2784   for (;;)
2785     {
2786       m = var_element (&var);
2787       if (m == MATCH_NO)
2788         goto syntax;
2789       if (m == MATCH_ERROR)
2790         return MATCH_ERROR;
2791
2792       new = gfc_get_data_variable ();
2793       *new = var;
2794
2795       if (tail == NULL)
2796         d->var = new;
2797       else
2798         tail->next = new;
2799
2800       tail = new;
2801
2802       if (gfc_match_char ('/') == MATCH_YES)
2803         break;
2804       if (gfc_match_char (',') != MATCH_YES)
2805         goto syntax;
2806     }
2807
2808   return MATCH_YES;
2809
2810 syntax:
2811   gfc_syntax_error (ST_DATA);
2812   return MATCH_ERROR;
2813 }
2814
2815
2816 static match
2817 match_data_constant (gfc_expr ** result)
2818 {
2819   char name[GFC_MAX_SYMBOL_LEN + 1];
2820   gfc_symbol *sym;
2821   gfc_expr *expr;
2822   match m;
2823
2824   m = gfc_match_literal_constant (&expr, 1);
2825   if (m == MATCH_YES)
2826     {
2827       *result = expr;
2828       return MATCH_YES;
2829     }
2830
2831   if (m == MATCH_ERROR)
2832     return MATCH_ERROR;
2833
2834   m = gfc_match_null (result);
2835   if (m != MATCH_NO)
2836     return m;
2837
2838   m = gfc_match_name (name);
2839   if (m != MATCH_YES)
2840     return m;
2841
2842   if (gfc_find_symbol (name, NULL, 1, &sym))
2843     return MATCH_ERROR;
2844
2845   if (sym == NULL
2846       || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
2847     {
2848       gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
2849                  name);
2850       return MATCH_ERROR;
2851     }
2852   else if (sym->attr.flavor == FL_DERIVED)
2853     return gfc_match_structure_constructor (sym, result);
2854
2855   *result = gfc_copy_expr (sym->value);
2856   return MATCH_YES;
2857 }
2858
2859
2860 /* Match a list of values in a DATA statement.  The leading '/' has
2861    already been seen at this point.  */
2862
2863 static match
2864 top_val_list (gfc_data * data)
2865 {
2866   gfc_data_value *new, *tail;
2867   gfc_expr *expr;
2868   const char *msg;
2869   match m;
2870
2871   tail = NULL;
2872
2873   for (;;)
2874     {
2875       m = match_data_constant (&expr);
2876       if (m == MATCH_NO)
2877         goto syntax;
2878       if (m == MATCH_ERROR)
2879         return MATCH_ERROR;
2880
2881       new = gfc_get_data_value ();
2882
2883       if (tail == NULL)
2884         data->value = new;
2885       else
2886         tail->next = new;
2887
2888       tail = new;
2889
2890       if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
2891         {
2892           tail->expr = expr;
2893           tail->repeat = 1;
2894         }
2895       else
2896         {
2897           msg = gfc_extract_int (expr, &tail->repeat);
2898           gfc_free_expr (expr);
2899           if (msg != NULL)
2900             {
2901               gfc_error (msg);
2902               return MATCH_ERROR;
2903             }
2904
2905           m = match_data_constant (&tail->expr);
2906           if (m == MATCH_NO)
2907             goto syntax;
2908           if (m == MATCH_ERROR)
2909             return MATCH_ERROR;
2910         }
2911
2912       if (gfc_match_char ('/') == MATCH_YES)
2913         break;
2914       if (gfc_match_char (',') == MATCH_NO)
2915         goto syntax;
2916     }
2917
2918   return MATCH_YES;
2919
2920 syntax:
2921   gfc_syntax_error (ST_DATA);
2922   return MATCH_ERROR;
2923 }
2924
2925
2926 /* Match a DATA statement.  */
2927
2928 match
2929 gfc_match_data (void)
2930 {
2931   gfc_data *new;
2932   match m;
2933
2934   for (;;)
2935     {
2936       new = gfc_get_data ();
2937       new->where = gfc_current_locus;
2938
2939       m = top_var_list (new);
2940       if (m != MATCH_YES)
2941         goto cleanup;
2942
2943       m = top_val_list (new);
2944       if (m != MATCH_YES)
2945         goto cleanup;
2946
2947       new->next = gfc_current_ns->data;
2948       gfc_current_ns->data = new;
2949
2950       if (gfc_match_eos () == MATCH_YES)
2951         break;
2952
2953       gfc_match_char (',');     /* Optional comma */
2954     }
2955
2956   if (gfc_pure (NULL))
2957     {
2958       gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
2959       return MATCH_ERROR;
2960     }
2961
2962   return MATCH_YES;
2963
2964 cleanup:
2965   gfc_free_data (new);
2966   return MATCH_ERROR;
2967 }
2968
2969
2970 /***************** SELECT CASE subroutines ******************/
2971
2972 /* Free a single case structure.  */
2973
2974 static void
2975 free_case (gfc_case * p)
2976 {
2977   if (p->low == p->high)
2978     p->high = NULL;
2979   gfc_free_expr (p->low);
2980   gfc_free_expr (p->high);
2981   gfc_free (p);
2982 }
2983
2984
2985 /* Free a list of case structures.  */
2986
2987 void
2988 gfc_free_case_list (gfc_case * p)
2989 {
2990   gfc_case *q;
2991
2992   for (; p; p = q)
2993     {
2994       q = p->next;
2995       free_case (p);
2996     }
2997 }
2998
2999
3000 /* Match a single case selector.  */
3001
3002 static match
3003 match_case_selector (gfc_case ** cp)
3004 {
3005   gfc_case *c;
3006   match m;
3007
3008   c = gfc_get_case ();
3009   c->where = gfc_current_locus;
3010
3011   if (gfc_match_char (':') == MATCH_YES)
3012     {
3013       m = gfc_match_init_expr (&c->high);
3014       if (m == MATCH_NO)
3015         goto need_expr;
3016       if (m == MATCH_ERROR)
3017         goto cleanup;
3018     }
3019
3020   else
3021     {
3022       m = gfc_match_init_expr (&c->low);
3023       if (m == MATCH_ERROR)
3024         goto cleanup;
3025       if (m == MATCH_NO)
3026         goto need_expr;
3027
3028       /* If we're not looking at a ':' now, make a range out of a single
3029          target.  Else get the upper bound for the case range. */
3030       if (gfc_match_char (':') != MATCH_YES)
3031         c->high = c->low;
3032       else
3033         {
3034           m = gfc_match_init_expr (&c->high);
3035           if (m == MATCH_ERROR)
3036             goto cleanup;
3037           /* MATCH_NO is fine.  It's OK if nothing is there!  */
3038         }
3039     }
3040
3041   *cp = c;
3042   return MATCH_YES;
3043
3044 need_expr:
3045   gfc_error ("Expected initialization expression in CASE at %C");
3046
3047 cleanup:
3048   free_case (c);
3049   return MATCH_ERROR;
3050 }
3051
3052
3053 /* Match the end of a case statement.  */
3054
3055 static match
3056 match_case_eos (void)
3057 {
3058   char name[GFC_MAX_SYMBOL_LEN + 1];
3059   match m;
3060
3061   if (gfc_match_eos () == MATCH_YES)
3062     return MATCH_YES;
3063
3064   gfc_gobble_whitespace ();
3065
3066   m = gfc_match_name (name);
3067   if (m != MATCH_YES)
3068     return m;
3069
3070   if (strcmp (name, gfc_current_block ()->name) != 0)
3071     {
3072       gfc_error ("Expected case name of '%s' at %C",
3073                  gfc_current_block ()->name);
3074       return MATCH_ERROR;
3075     }
3076
3077   return gfc_match_eos ();
3078 }
3079
3080
3081 /* Match a SELECT statement.  */
3082
3083 match
3084 gfc_match_select (void)
3085 {
3086   gfc_expr *expr;
3087   match m;
3088
3089   m = gfc_match_label ();
3090   if (m == MATCH_ERROR)
3091     return m;
3092
3093   m = gfc_match (" select case ( %e )%t", &expr);
3094   if (m != MATCH_YES)
3095     return m;
3096
3097   new_st.op = EXEC_SELECT;
3098   new_st.expr = expr;
3099
3100   return MATCH_YES;
3101 }
3102
3103
3104 /* Match a CASE statement.  */
3105
3106 match
3107 gfc_match_case (void)
3108 {
3109   gfc_case *c, *head, *tail;
3110   match m;
3111
3112   head = tail = NULL;
3113
3114   if (gfc_current_state () != COMP_SELECT)
3115     {
3116       gfc_error ("Unexpected CASE statement at %C");
3117       return MATCH_ERROR;
3118     }
3119
3120   if (gfc_match ("% default") == MATCH_YES)
3121     {
3122       m = match_case_eos ();
3123       if (m == MATCH_NO)
3124         goto syntax;
3125       if (m == MATCH_ERROR)
3126         goto cleanup;
3127
3128       new_st.op = EXEC_SELECT;
3129       c = gfc_get_case ();
3130       c->where = gfc_current_locus;
3131       new_st.ext.case_list = c;
3132       return MATCH_YES;
3133     }
3134
3135   if (gfc_match_char ('(') != MATCH_YES)
3136     goto syntax;
3137
3138   for (;;)
3139     {
3140       if (match_case_selector (&c) == MATCH_ERROR)
3141         goto cleanup;
3142
3143       if (head == NULL)
3144         head = c;
3145       else
3146         tail->next = c;
3147
3148       tail = c;
3149
3150       if (gfc_match_char (')') == MATCH_YES)
3151         break;
3152       if (gfc_match_char (',') != MATCH_YES)
3153         goto syntax;
3154     }
3155
3156   m = match_case_eos ();
3157   if (m == MATCH_NO)
3158     goto syntax;
3159   if (m == MATCH_ERROR)
3160     goto cleanup;
3161
3162   new_st.op = EXEC_SELECT;
3163   new_st.ext.case_list = head;
3164
3165   return MATCH_YES;
3166
3167 syntax:
3168   gfc_error ("Syntax error in CASE-specification at %C");
3169
3170 cleanup:
3171   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
3172   return MATCH_ERROR;
3173 }
3174
3175 /********************* WHERE subroutines ********************/
3176
3177 /* Match the rest of a simple WHERE statement that follows an IF statement.
3178  */
3179
3180 static match
3181 match_simple_where (void)
3182 {
3183   gfc_expr *expr;
3184   gfc_code *c;
3185   match m;
3186
3187   m = gfc_match (" ( %e )", &expr);
3188   if (m != MATCH_YES)
3189     return m;
3190
3191   m = gfc_match_assignment ();
3192   if (m == MATCH_NO)
3193     goto syntax;
3194   if (m == MATCH_ERROR)
3195     goto cleanup;
3196
3197   if (gfc_match_eos () != MATCH_YES)
3198     goto syntax;
3199
3200   c = gfc_get_code ();
3201
3202   c->op = EXEC_WHERE;
3203   c->expr = expr;
3204   c->next = gfc_get_code ();
3205
3206   *c->next = new_st;
3207   gfc_clear_new_st ();
3208
3209   new_st.op = EXEC_WHERE;
3210   new_st.block = c;
3211
3212   return MATCH_YES;
3213
3214 syntax:
3215   gfc_syntax_error (ST_WHERE);
3216
3217 cleanup:
3218   gfc_free_expr (expr);
3219   return MATCH_ERROR;
3220 }
3221
3222 /* Match a WHERE statement.  */
3223
3224 match
3225 gfc_match_where (gfc_statement * st)
3226 {
3227   gfc_expr *expr;
3228   match m0, m;
3229   gfc_code *c;
3230
3231   m0 = gfc_match_label ();
3232   if (m0 == MATCH_ERROR)
3233     return m0;
3234
3235   m = gfc_match (" where ( %e )", &expr);
3236   if (m != MATCH_YES)
3237     return m;
3238
3239   if (gfc_match_eos () == MATCH_YES)
3240     {
3241       *st = ST_WHERE_BLOCK;
3242
3243       new_st.op = EXEC_WHERE;
3244       new_st.expr = expr;
3245       return MATCH_YES;
3246     }
3247
3248   m = gfc_match_assignment ();
3249   if (m == MATCH_NO)
3250     gfc_syntax_error (ST_WHERE);
3251
3252   if (m != MATCH_YES)
3253     {
3254       gfc_free_expr (expr);
3255       return MATCH_ERROR;
3256     }
3257
3258   /* We've got a simple WHERE statement.  */
3259   *st = ST_WHERE;
3260   c = gfc_get_code ();
3261
3262   c->op = EXEC_WHERE;
3263   c->expr = expr;
3264   c->next = gfc_get_code ();
3265
3266   *c->next = new_st;
3267   gfc_clear_new_st ();
3268
3269   new_st.op = EXEC_WHERE;
3270   new_st.block = c;
3271
3272   return MATCH_YES;
3273 }
3274
3275
3276 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
3277    new_st if successful.  */
3278
3279 match
3280 gfc_match_elsewhere (void)
3281 {
3282   char name[GFC_MAX_SYMBOL_LEN + 1];
3283   gfc_expr *expr;
3284   match m;
3285
3286   if (gfc_current_state () != COMP_WHERE)
3287     {
3288       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3289       return MATCH_ERROR;
3290     }
3291
3292   expr = NULL;
3293
3294   if (gfc_match_char ('(') == MATCH_YES)
3295     {
3296       m = gfc_match_expr (&expr);
3297       if (m == MATCH_NO)
3298         goto syntax;
3299       if (m == MATCH_ERROR)
3300         return MATCH_ERROR;
3301
3302       if (gfc_match_char (')') != MATCH_YES)
3303         goto syntax;
3304     }
3305
3306   if (gfc_match_eos () != MATCH_YES)
3307     {                           /* Better be a name at this point */
3308       m = gfc_match_name (name);
3309       if (m == MATCH_NO)
3310         goto syntax;
3311       if (m == MATCH_ERROR)
3312         goto cleanup;
3313
3314       if (gfc_match_eos () != MATCH_YES)
3315         goto syntax;
3316
3317       if (strcmp (name, gfc_current_block ()->name) != 0)
3318         {
3319           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3320                      name, gfc_current_block ()->name);
3321           goto cleanup;
3322         }
3323     }
3324
3325   new_st.op = EXEC_WHERE;
3326   new_st.expr = expr;
3327   return MATCH_YES;
3328
3329 syntax:
3330   gfc_syntax_error (ST_ELSEWHERE);
3331
3332 cleanup:
3333   gfc_free_expr (expr);
3334   return MATCH_ERROR;
3335 }
3336
3337
3338 /******************** FORALL subroutines ********************/
3339
3340 /* Free a list of FORALL iterators.  */
3341
3342 void
3343 gfc_free_forall_iterator (gfc_forall_iterator * iter)
3344 {
3345   gfc_forall_iterator *next;
3346
3347   while (iter)
3348     {
3349       next = iter->next;
3350
3351       gfc_free_expr (iter->var);
3352       gfc_free_expr (iter->start);
3353       gfc_free_expr (iter->end);
3354       gfc_free_expr (iter->stride);
3355
3356       gfc_free (iter);
3357       iter = next;
3358     }
3359 }
3360
3361
3362 /* Match an iterator as part of a FORALL statement.  The format is:
3363
3364      <var> = <start>:<end>[:<stride>][, <scalar mask>]  */
3365
3366 static match
3367 match_forall_iterator (gfc_forall_iterator ** result)
3368 {
3369   gfc_forall_iterator *iter;
3370   locus where;
3371   match m;
3372
3373   where = gfc_current_locus;
3374   iter = gfc_getmem (sizeof (gfc_forall_iterator));
3375
3376   m = gfc_match_variable (&iter->var, 0);
3377   if (m != MATCH_YES)
3378     goto cleanup;
3379
3380   if (gfc_match_char ('=') != MATCH_YES)
3381     {
3382       m = MATCH_NO;
3383       goto cleanup;
3384     }
3385
3386   m = gfc_match_expr (&iter->start);
3387   if (m == MATCH_NO)
3388     goto syntax;
3389   if (m == MATCH_ERROR)
3390     goto cleanup;
3391
3392   if (gfc_match_char (':') != MATCH_YES)
3393     goto syntax;
3394
3395   m = gfc_match_expr (&iter->end);
3396   if (m == MATCH_NO)
3397     goto syntax;
3398   if (m == MATCH_ERROR)
3399     goto cleanup;
3400
3401   if (gfc_match_char (':') == MATCH_NO)
3402     iter->stride = gfc_int_expr (1);
3403   else
3404     {
3405       m = gfc_match_expr (&iter->stride);
3406       if (m == MATCH_NO)
3407         goto syntax;
3408       if (m == MATCH_ERROR)
3409         goto cleanup;
3410     }
3411
3412   *result = iter;
3413   return MATCH_YES;
3414
3415 syntax:
3416   gfc_error ("Syntax error in FORALL iterator at %C");
3417   m = MATCH_ERROR;
3418
3419 cleanup:
3420   gfc_current_locus = where;
3421   gfc_free_forall_iterator (iter);
3422   return m;
3423 }
3424
3425
3426 /* Match the header of a FORALL statement.  */
3427
3428 static match
3429 match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
3430 {
3431   gfc_forall_iterator *head, *tail, *new;
3432   match m;
3433
3434   gfc_gobble_whitespace ();
3435
3436   head = tail = NULL;
3437   *mask = NULL;
3438
3439   if (gfc_match_char ('(') != MATCH_YES)
3440     return MATCH_NO;
3441
3442   m = match_forall_iterator (&new);
3443   if (m == MATCH_ERROR)
3444     goto cleanup;
3445   if (m == MATCH_NO)
3446     goto syntax;
3447
3448   head = tail = new;
3449
3450   for (;;)
3451     {
3452       if (gfc_match_char (',') != MATCH_YES)
3453         break;
3454
3455       m = match_forall_iterator (&new);
3456       if (m == MATCH_ERROR)
3457         goto cleanup;
3458       if (m == MATCH_YES)
3459         {
3460           tail->next = new;
3461           tail = new;
3462           continue;
3463         }
3464
3465       /* Have to have a mask expression */
3466
3467       m = gfc_match_expr (mask);
3468       if (m == MATCH_NO)
3469         goto syntax;
3470       if (m == MATCH_ERROR)
3471         goto cleanup;
3472
3473       break;
3474     }
3475
3476   if (gfc_match_char (')') == MATCH_NO)
3477     goto syntax;
3478
3479   *phead = head;
3480   return MATCH_YES;
3481
3482 syntax:
3483   gfc_syntax_error (ST_FORALL);
3484
3485 cleanup:
3486   gfc_free_expr (*mask);
3487   gfc_free_forall_iterator (head);
3488
3489   return MATCH_ERROR;
3490 }
3491
3492 /* Match the rest of a simple FORALL statement that follows an IF statement.
3493  */
3494
3495 static match
3496 match_simple_forall (void)
3497 {
3498   gfc_forall_iterator *head;
3499   gfc_expr *mask;
3500   gfc_code *c;
3501   match m;
3502
3503   mask = NULL;
3504   head = NULL;
3505   c = NULL;
3506
3507   m = match_forall_header (&head, &mask);
3508
3509   if (m == MATCH_NO)
3510     goto syntax;
3511   if (m != MATCH_YES)
3512     goto cleanup;
3513
3514   m = gfc_match_assignment ();
3515
3516   if (m == MATCH_ERROR)
3517     goto cleanup;
3518   if (m == MATCH_NO)
3519     {
3520       m = gfc_match_pointer_assignment ();
3521       if (m == MATCH_ERROR)
3522         goto cleanup;
3523       if (m == MATCH_NO)
3524         goto syntax;
3525     }
3526
3527   c = gfc_get_code ();
3528   *c = new_st;
3529   c->loc = gfc_current_locus;
3530
3531   if (gfc_match_eos () != MATCH_YES)
3532     goto syntax;
3533
3534   gfc_clear_new_st ();
3535   new_st.op = EXEC_FORALL;
3536   new_st.expr = mask;
3537   new_st.ext.forall_iterator = head;
3538   new_st.block = gfc_get_code ();
3539
3540   new_st.block->op = EXEC_FORALL;
3541   new_st.block->next = c;
3542
3543   return MATCH_YES;
3544
3545 syntax:
3546   gfc_syntax_error (ST_FORALL);
3547
3548 cleanup:
3549   gfc_free_forall_iterator (head);
3550   gfc_free_expr (mask);
3551
3552   return MATCH_ERROR;
3553 }
3554
3555
3556 /* Match a FORALL statement.  */
3557
3558 match
3559 gfc_match_forall (gfc_statement * st)
3560 {
3561   gfc_forall_iterator *head;
3562   gfc_expr *mask;
3563   gfc_code *c;
3564   match m0, m;
3565
3566   head = NULL;
3567   mask = NULL;
3568   c = NULL;
3569
3570   m0 = gfc_match_label ();
3571   if (m0 == MATCH_ERROR)
3572     return MATCH_ERROR;
3573
3574   m = gfc_match (" forall");
3575   if (m != MATCH_YES)
3576     return m;
3577
3578   m = match_forall_header (&head, &mask);
3579   if (m == MATCH_ERROR)
3580     goto cleanup;
3581   if (m == MATCH_NO)
3582     goto syntax;
3583
3584   if (gfc_match_eos () == MATCH_YES)
3585     {
3586       *st = ST_FORALL_BLOCK;
3587
3588       new_st.op = EXEC_FORALL;
3589       new_st.expr = mask;
3590       new_st.ext.forall_iterator = head;
3591
3592       return MATCH_YES;
3593     }
3594
3595   m = gfc_match_assignment ();
3596   if (m == MATCH_ERROR)
3597     goto cleanup;
3598   if (m == MATCH_NO)
3599     {
3600       m = gfc_match_pointer_assignment ();
3601       if (m == MATCH_ERROR)
3602         goto cleanup;
3603       if (m == MATCH_NO)
3604         goto syntax;
3605     }
3606
3607   c = gfc_get_code ();
3608   *c = new_st;
3609
3610   if (gfc_match_eos () != MATCH_YES)
3611     goto syntax;
3612
3613   gfc_clear_new_st ();
3614   new_st.op = EXEC_FORALL;
3615   new_st.expr = mask;
3616   new_st.ext.forall_iterator = head;
3617   new_st.block = gfc_get_code ();
3618
3619   new_st.block->op = EXEC_FORALL;
3620   new_st.block->next = c;
3621
3622   *st = ST_FORALL;
3623   return MATCH_YES;
3624
3625 syntax:
3626   gfc_syntax_error (ST_FORALL);
3627
3628 cleanup:
3629   gfc_free_forall_iterator (head);
3630   gfc_free_expr (mask);
3631   gfc_free_statements (c);
3632   return MATCH_NO;
3633 }