gcc/fortran/match.c

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