gcc/fortran/match.c

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