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