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
2603   tail = NULL;
2604
2605   for (;;)
2606     {
2607       eq = gfc_get_equiv ();
2608       if (tail == NULL)
2609         tail = eq;
2610
2611       eq->next = gfc_current_ns->equiv;
2612       gfc_current_ns->equiv = eq;
2613
2614       if (gfc_match_char ('(') != MATCH_YES)
2615         goto syntax;
2616
2617       set = eq;
2618       common_flag = FALSE;
2619
2620       for (;;)
2621         {
2622           m = gfc_match_equiv_variable (&set->expr);
2623           if (m == MATCH_ERROR)
2624             goto cleanup;
2625           if (m == MATCH_NO)
2626             goto syntax;
2627
2628           if (gfc_match_char ('%') == MATCH_YES)
2629             {
2630               gfc_error ("Derived type component %C is not a "
2631                          "permitted EQUIVALENCE member");
2632               goto cleanup;
2633             }
2634
2635           for (ref = set->expr->ref; ref; ref = ref->next)
2636             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2637               {
2638                 gfc_error
2639                   ("Array reference in EQUIVALENCE at %C cannot be an "
2640                    "array section");
2641                 goto cleanup;
2642               }
2643
2644           sym = set->expr->symtree->n.sym;
2645
2646           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL)
2647                 == FAILURE)
2648             goto cleanup;
2649
2650           if (sym->attr.in_common)
2651             {
2652               common_flag = TRUE;
2653               common_head = sym->common_head;
2654             }
2655
2656           if (gfc_match_char (')') == MATCH_YES)
2657             break;
2658           if (gfc_match_char (',') != MATCH_YES)
2659             goto syntax;
2660
2661           set->eq = gfc_get_equiv ();
2662           set = set->eq;
2663         }
2664
2665       /* If one of the members of an equivalence is in common, then
2666          mark them all as being in common.  Before doing this, check
2667          that members of the equivalence group are not in different
2668          common blocks. */
2669       if (common_flag)
2670         for (set = eq; set; set = set->eq)
2671           {
2672             sym = set->expr->symtree->n.sym;
2673             if (sym->common_head && sym->common_head != common_head)
2674               {
2675                 gfc_error ("Attempt to indirectly overlap COMMON "
2676                            "blocks %s and %s by EQUIVALENCE at %C",
2677                            sym->common_head->name,
2678                            common_head->name);
2679                 goto cleanup;
2680               }
2681             sym->attr.in_common = 1;
2682             sym->common_head = common_head;
2683           }
2684
2685       if (gfc_match_eos () == MATCH_YES)
2686         break;
2687       if (gfc_match_char (',') != MATCH_YES)
2688         goto syntax;
2689     }
2690
2691   return MATCH_YES;
2692
2693 syntax:
2694   gfc_syntax_error (ST_EQUIVALENCE);
2695
2696 cleanup:
2697   eq = tail->next;
2698   tail->next = NULL;
2699
2700   gfc_free_equiv (gfc_current_ns->equiv);
2701   gfc_current_ns->equiv = eq;
2702
2703   return MATCH_ERROR;
2704 }
2705
2706 /* Check that a statement function is not recursive. This is done by looking
2707    for the statement function symbol(sym) by looking recursively through its
2708    expression(e).  If a reference to sym is found, true is returned.  */
2709 static bool
2710 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
2711 {
2712   gfc_actual_arglist *arg;
2713   gfc_ref *ref;
2714   int i;
2715
2716   if (e == NULL)
2717     return false;
2718
2719   switch (e->expr_type)
2720     {
2721     case EXPR_FUNCTION:
2722       for (arg = e->value.function.actual; arg; arg = arg->next)
2723         {
2724           if (sym->name == arg->name
2725                 || recursive_stmt_fcn (arg->expr, sym))
2726             return true;
2727         }
2728
2729       if (e->symtree == NULL)
2730         return false;
2731
2732       /* Check the name before testing for nested recursion!  */
2733       if (sym->name == e->symtree->n.sym->name)
2734         return true;
2735
2736       /* Catch recursion via other statement functions.  */
2737       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
2738             && e->symtree->n.sym->value
2739             && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
2740         return true;
2741
2742       break;
2743
2744     case EXPR_VARIABLE:
2745       if (e->symtree && sym->name == e->symtree->n.sym->name)
2746         return true;
2747       break;
2748
2749     case EXPR_OP:
2750       if (recursive_stmt_fcn (e->value.op.op1, sym)
2751             || recursive_stmt_fcn (e->value.op.op2, sym))
2752         return true;
2753       break;
2754
2755     default:
2756       break;
2757     }
2758
2759   /* Component references do not need to be checked.  */
2760   if (e->ref)
2761     {
2762       for (ref = e->ref; ref; ref = ref->next)
2763         {
2764           switch (ref->type)
2765             {
2766             case REF_ARRAY:
2767               for (i = 0; i < ref->u.ar.dimen; i++)
2768                 {
2769                   if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
2770                         || recursive_stmt_fcn (ref->u.ar.end[i], sym)
2771                         || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
2772                     return true;
2773                 }
2774               break;
2775
2776             case REF_SUBSTRING:
2777               if (recursive_stmt_fcn (ref->u.ss.start, sym)
2778                     || recursive_stmt_fcn (ref->u.ss.end, sym))
2779                 return true;
2780
2781               break;
2782
2783             default:
2784               break;
2785             }
2786         }
2787     }
2788   return false;
2789 }
2790
2791
2792 /* Match a statement function declaration.  It is so easy to match
2793    non-statement function statements with a MATCH_ERROR as opposed to
2794    MATCH_NO that we suppress error message in most cases.  */
2795
2796 match
2797 gfc_match_st_function (void)
2798 {
2799   gfc_error_buf old_error;
2800   gfc_symbol *sym;
2801   gfc_expr *expr;
2802   match m;
2803
2804   m = gfc_match_symbol (&sym, 0);
2805   if (m != MATCH_YES)
2806     return m;
2807
2808   gfc_push_error (&old_error);
2809
2810   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
2811                          sym->name, NULL) == FAILURE)
2812     goto undo_error;
2813
2814   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2815     goto undo_error;
2816
2817   m = gfc_match (" = %e%t", &expr);
2818   if (m == MATCH_NO)
2819     goto undo_error;
2820
2821   gfc_free_error (&old_error);
2822   if (m == MATCH_ERROR)
2823     return m;
2824
2825   if (recursive_stmt_fcn (expr, sym))
2826     {
2827       gfc_error ("Statement function at %L is recursive",
2828                  &expr->where);
2829       return MATCH_ERROR;
2830     }
2831
2832   sym->value = expr;
2833
2834   return MATCH_YES;
2835
2836 undo_error:
2837   gfc_pop_error (&old_error);
2838   return MATCH_NO;
2839 }
2840
2841
2842 /***************** SELECT CASE subroutines ******************/
2843
2844 /* Free a single case structure.  */
2845
2846 static void
2847 free_case (gfc_case * p)
2848 {
2849   if (p->low == p->high)
2850     p->high = NULL;
2851   gfc_free_expr (p->low);
2852   gfc_free_expr (p->high);
2853   gfc_free (p);
2854 }
2855
2856
2857 /* Free a list of case structures.  */
2858
2859 void
2860 gfc_free_case_list (gfc_case * p)
2861 {
2862   gfc_case *q;
2863
2864   for (; p; p = q)
2865     {
2866       q = p->next;
2867       free_case (p);
2868     }
2869 }
2870
2871
2872 /* Match a single case selector.  */
2873
2874 static match
2875 match_case_selector (gfc_case ** cp)
2876 {
2877   gfc_case *c;
2878   match m;
2879
2880   c = gfc_get_case ();
2881   c->where = gfc_current_locus;
2882
2883   if (gfc_match_char (':') == MATCH_YES)
2884     {
2885       m = gfc_match_init_expr (&c->high);
2886       if (m == MATCH_NO)
2887         goto need_expr;
2888       if (m == MATCH_ERROR)
2889         goto cleanup;
2890     }
2891
2892   else
2893     {
2894       m = gfc_match_init_expr (&c->low);
2895       if (m == MATCH_ERROR)
2896         goto cleanup;
2897       if (m == MATCH_NO)
2898         goto need_expr;
2899
2900       /* If we're not looking at a ':' now, make a range out of a single
2901          target.  Else get the upper bound for the case range.  */
2902       if (gfc_match_char (':') != MATCH_YES)
2903         c->high = c->low;
2904       else
2905         {
2906           m = gfc_match_init_expr (&c->high);
2907           if (m == MATCH_ERROR)
2908             goto cleanup;
2909           /* MATCH_NO is fine.  It's OK if nothing is there!  */
2910         }
2911     }
2912
2913   *cp = c;
2914   return MATCH_YES;
2915
2916 need_expr:
2917   gfc_error ("Expected initialization expression in CASE at %C");
2918
2919 cleanup:
2920   free_case (c);
2921   return MATCH_ERROR;
2922 }
2923
2924
2925 /* Match the end of a case statement.  */
2926
2927 static match
2928 match_case_eos (void)
2929 {
2930   char name[GFC_MAX_SYMBOL_LEN + 1];
2931   match m;
2932
2933   if (gfc_match_eos () == MATCH_YES)
2934     return MATCH_YES;
2935
2936   gfc_gobble_whitespace ();
2937
2938   m = gfc_match_name (name);
2939   if (m != MATCH_YES)
2940     return m;
2941
2942   if (strcmp (name, gfc_current_block ()->name) != 0)
2943     {
2944       gfc_error ("Expected case name of '%s' at %C",
2945                  gfc_current_block ()->name);
2946       return MATCH_ERROR;
2947     }
2948
2949   return gfc_match_eos ();
2950 }
2951
2952
2953 /* Match a SELECT statement.  */
2954
2955 match
2956 gfc_match_select (void)
2957 {
2958   gfc_expr *expr;
2959   match m;
2960
2961   m = gfc_match_label ();
2962   if (m == MATCH_ERROR)
2963     return m;
2964
2965   m = gfc_match (" select case ( %e )%t", &expr);
2966   if (m != MATCH_YES)
2967     return m;
2968
2969   new_st.op = EXEC_SELECT;
2970   new_st.expr = expr;
2971
2972   return MATCH_YES;
2973 }
2974
2975
2976 /* Match a CASE statement.  */
2977
2978 match
2979 gfc_match_case (void)
2980 {
2981   gfc_case *c, *head, *tail;
2982   match m;
2983
2984   head = tail = NULL;
2985
2986   if (gfc_current_state () != COMP_SELECT)
2987     {
2988       gfc_error ("Unexpected CASE statement at %C");
2989       return MATCH_ERROR;
2990     }
2991
2992   if (gfc_match ("% default") == MATCH_YES)
2993     {
2994       m = match_case_eos ();
2995       if (m == MATCH_NO)
2996         goto syntax;
2997       if (m == MATCH_ERROR)
2998         goto cleanup;
2999
3000       new_st.op = EXEC_SELECT;
3001       c = gfc_get_case ();
3002       c->where = gfc_current_locus;
3003       new_st.ext.case_list = c;
3004       return MATCH_YES;
3005     }
3006
3007   if (gfc_match_char ('(') != MATCH_YES)
3008     goto syntax;
3009
3010   for (;;)
3011     {
3012       if (match_case_selector (&c) == MATCH_ERROR)
3013         goto cleanup;
3014
3015       if (head == NULL)
3016         head = c;
3017       else
3018         tail->next = c;
3019
3020       tail = c;
3021
3022       if (gfc_match_char (')') == MATCH_YES)
3023         break;
3024       if (gfc_match_char (',') != MATCH_YES)
3025         goto syntax;
3026     }
3027
3028   m = match_case_eos ();
3029   if (m == MATCH_NO)
3030     goto syntax;
3031   if (m == MATCH_ERROR)
3032     goto cleanup;
3033
3034   new_st.op = EXEC_SELECT;
3035   new_st.ext.case_list = head;
3036
3037   return MATCH_YES;
3038
3039 syntax:
3040   gfc_error ("Syntax error in CASE-specification at %C");
3041
3042 cleanup:
3043   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
3044   return MATCH_ERROR;
3045 }
3046
3047 /********************* WHERE subroutines ********************/
3048
3049 /* Match the rest of a simple WHERE statement that follows an IF statement.
3050  */
3051
3052 static match
3053 match_simple_where (void)
3054 {
3055   gfc_expr *expr;
3056   gfc_code *c;
3057   match m;
3058
3059   m = gfc_match (" ( %e )", &expr);
3060   if (m != MATCH_YES)
3061     return m;
3062
3063   m = gfc_match_assignment ();
3064   if (m == MATCH_NO)
3065     goto syntax;
3066   if (m == MATCH_ERROR)
3067     goto cleanup;
3068
3069   if (gfc_match_eos () != MATCH_YES)
3070     goto syntax;
3071
3072   c = gfc_get_code ();
3073
3074   c->op = EXEC_WHERE;
3075   c->expr = expr;
3076   c->next = gfc_get_code ();
3077
3078   *c->next = new_st;
3079   gfc_clear_new_st ();
3080
3081   new_st.op = EXEC_WHERE;
3082   new_st.block = c;
3083
3084   return MATCH_YES;
3085
3086 syntax:
3087   gfc_syntax_error (ST_WHERE);
3088
3089 cleanup:
3090   gfc_free_expr (expr);
3091   return MATCH_ERROR;
3092 }
3093
3094 /* Match a WHERE statement.  */
3095
3096 match
3097 gfc_match_where (gfc_statement * st)
3098 {
3099   gfc_expr *expr;
3100   match m0, m;
3101   gfc_code *c;
3102
3103   m0 = gfc_match_label ();
3104   if (m0 == MATCH_ERROR)
3105     return m0;
3106
3107   m = gfc_match (" where ( %e )", &expr);
3108   if (m != MATCH_YES)
3109     return m;
3110
3111   if (gfc_match_eos () == MATCH_YES)
3112     {
3113       *st = ST_WHERE_BLOCK;
3114
3115       new_st.op = EXEC_WHERE;
3116       new_st.expr = expr;
3117       return MATCH_YES;
3118     }
3119
3120   m = gfc_match_assignment ();
3121   if (m == MATCH_NO)
3122     gfc_syntax_error (ST_WHERE);
3123
3124   if (m != MATCH_YES)
3125     {
3126       gfc_free_expr (expr);
3127       return MATCH_ERROR;
3128     }
3129
3130   /* We've got a simple WHERE statement.  */
3131   *st = ST_WHERE;
3132   c = gfc_get_code ();
3133
3134   c->op = EXEC_WHERE;
3135   c->expr = expr;
3136   c->next = gfc_get_code ();
3137
3138   *c->next = new_st;
3139   gfc_clear_new_st ();
3140
3141   new_st.op = EXEC_WHERE;
3142   new_st.block = c;
3143
3144   return MATCH_YES;
3145 }
3146
3147
3148 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
3149    new_st if successful.  */
3150
3151 match
3152 gfc_match_elsewhere (void)
3153 {
3154   char name[GFC_MAX_SYMBOL_LEN + 1];
3155   gfc_expr *expr;
3156   match m;
3157
3158   if (gfc_current_state () != COMP_WHERE)
3159     {
3160       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3161       return MATCH_ERROR;
3162     }
3163
3164   expr = NULL;
3165
3166   if (gfc_match_char ('(') == MATCH_YES)
3167     {
3168       m = gfc_match_expr (&expr);
3169       if (m == MATCH_NO)
3170         goto syntax;
3171       if (m == MATCH_ERROR)
3172         return MATCH_ERROR;
3173
3174       if (gfc_match_char (')') != MATCH_YES)
3175         goto syntax;
3176     }
3177
3178   if (gfc_match_eos () != MATCH_YES)
3179     {                           /* Better be a name at this point */
3180       m = gfc_match_name (name);
3181       if (m == MATCH_NO)
3182         goto syntax;
3183       if (m == MATCH_ERROR)
3184         goto cleanup;
3185
3186       if (gfc_match_eos () != MATCH_YES)
3187         goto syntax;
3188
3189       if (strcmp (name, gfc_current_block ()->name) != 0)
3190         {
3191           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3192                      name, gfc_current_block ()->name);
3193           goto cleanup;
3194         }
3195     }
3196
3197   new_st.op = EXEC_WHERE;
3198   new_st.expr = expr;
3199   return MATCH_YES;
3200
3201 syntax:
3202   gfc_syntax_error (ST_ELSEWHERE);
3203
3204 cleanup:
3205   gfc_free_expr (expr);
3206   return MATCH_ERROR;
3207 }
3208
3209
3210 /******************** FORALL subroutines ********************/
3211
3212 /* Free a list of FORALL iterators.  */
3213
3214 void
3215 gfc_free_forall_iterator (gfc_forall_iterator * iter)
3216 {
3217   gfc_forall_iterator *next;
3218
3219   while (iter)
3220     {
3221       next = iter->next;
3222
3223       gfc_free_expr (iter->var);
3224       gfc_free_expr (iter->start);
3225       gfc_free_expr (iter->end);
3226       gfc_free_expr (iter->stride);
3227
3228       gfc_free (iter);
3229       iter = next;
3230     }
3231 }
3232
3233
3234 /* Match an iterator as part of a FORALL statement.  The format is:
3235
3236      <var> = <start>:<end>[:<stride>][, <scalar mask>]  */
3237
3238 static match
3239 match_forall_iterator (gfc_forall_iterator ** result)
3240 {
3241   gfc_forall_iterator *iter;
3242   locus where;
3243   match m;
3244
3245   where = gfc_current_locus;
3246   iter = gfc_getmem (sizeof (gfc_forall_iterator));
3247
3248   m = gfc_match_variable (&iter->var, 0);
3249   if (m != MATCH_YES)
3250     goto cleanup;
3251
3252   if (gfc_match_char ('=') != MATCH_YES)
3253     {
3254       m = MATCH_NO;
3255       goto cleanup;
3256     }
3257
3258   m = gfc_match_expr (&iter->start);
3259   if (m != MATCH_YES)
3260     goto cleanup;
3261
3262   if (gfc_match_char (':') != MATCH_YES)
3263     goto syntax;
3264
3265   m = gfc_match_expr (&iter->end);
3266   if (m == MATCH_NO)
3267     goto syntax;
3268   if (m == MATCH_ERROR)
3269     goto cleanup;
3270
3271   if (gfc_match_char (':') == MATCH_NO)
3272     iter->stride = gfc_int_expr (1);
3273   else
3274     {
3275       m = gfc_match_expr (&iter->stride);
3276       if (m == MATCH_NO)
3277         goto syntax;
3278       if (m == MATCH_ERROR)
3279         goto cleanup;
3280     }
3281
3282   *result = iter;
3283   return MATCH_YES;
3284
3285 syntax:
3286   gfc_error ("Syntax error in FORALL iterator at %C");
3287   m = MATCH_ERROR;
3288
3289 cleanup:
3290   gfc_current_locus = where;
3291   gfc_free_forall_iterator (iter);
3292   return m;
3293 }
3294
3295
3296 /* Match the header of a FORALL statement.  */
3297
3298 static match
3299 match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
3300 {
3301   gfc_forall_iterator *head, *tail, *new;
3302   match m;
3303
3304   gfc_gobble_whitespace ();
3305
3306   head = tail = NULL;
3307   *mask = NULL;
3308
3309   if (gfc_match_char ('(') != MATCH_YES)
3310     return MATCH_NO;
3311
3312   m = match_forall_iterator (&new);
3313   if (m == MATCH_ERROR)
3314     goto cleanup;
3315   if (m == MATCH_NO)
3316     goto syntax;
3317
3318   head = tail = new;
3319
3320   for (;;)
3321     {
3322       if (gfc_match_char (',') != MATCH_YES)
3323         break;
3324
3325       m = match_forall_iterator (&new);
3326       if (m == MATCH_ERROR)
3327         goto cleanup;
3328       if (m == MATCH_YES)
3329         {
3330           tail->next = new;
3331           tail = new;
3332           continue;
3333         }
3334
3335       /* Have to have a mask expression */
3336
3337       m = gfc_match_expr (mask);
3338       if (m == MATCH_NO)
3339         goto syntax;
3340       if (m == MATCH_ERROR)
3341         goto cleanup;
3342
3343       break;
3344     }
3345
3346   if (gfc_match_char (')') == MATCH_NO)
3347     goto syntax;
3348
3349   *phead = head;
3350   return MATCH_YES;
3351
3352 syntax:
3353   gfc_syntax_error (ST_FORALL);
3354
3355 cleanup:
3356   gfc_free_expr (*mask);
3357   gfc_free_forall_iterator (head);
3358
3359   return MATCH_ERROR;
3360 }
3361
3362 /* Match the rest of a simple FORALL statement that follows an IF statement.
3363  */
3364
3365 static match
3366 match_simple_forall (void)
3367 {
3368   gfc_forall_iterator *head;
3369   gfc_expr *mask;
3370   gfc_code *c;
3371   match m;
3372
3373   mask = NULL;
3374   head = NULL;
3375   c = NULL;
3376
3377   m = match_forall_header (&head, &mask);
3378
3379   if (m == MATCH_NO)
3380     goto syntax;
3381   if (m != MATCH_YES)
3382     goto cleanup;
3383
3384   m = gfc_match_assignment ();
3385
3386   if (m == MATCH_ERROR)
3387     goto cleanup;
3388   if (m == MATCH_NO)
3389     {
3390       m = gfc_match_pointer_assignment ();
3391       if (m == MATCH_ERROR)
3392         goto cleanup;
3393       if (m == MATCH_NO)
3394         goto syntax;
3395     }
3396
3397   c = gfc_get_code ();
3398   *c = new_st;
3399   c->loc = gfc_current_locus;
3400
3401   if (gfc_match_eos () != MATCH_YES)
3402     goto syntax;
3403
3404   gfc_clear_new_st ();
3405   new_st.op = EXEC_FORALL;
3406   new_st.expr = mask;
3407   new_st.ext.forall_iterator = head;
3408   new_st.block = gfc_get_code ();
3409
3410   new_st.block->op = EXEC_FORALL;
3411   new_st.block->next = c;
3412
3413   return MATCH_YES;
3414
3415 syntax:
3416   gfc_syntax_error (ST_FORALL);
3417
3418 cleanup:
3419   gfc_free_forall_iterator (head);
3420   gfc_free_expr (mask);
3421
3422   return MATCH_ERROR;
3423 }
3424
3425
3426 /* Match a FORALL statement.  */
3427
3428 match
3429 gfc_match_forall (gfc_statement * st)
3430 {
3431   gfc_forall_iterator *head;
3432   gfc_expr *mask;
3433   gfc_code *c;
3434   match m0, m;
3435
3436   head = NULL;
3437   mask = NULL;
3438   c = NULL;
3439
3440   m0 = gfc_match_label ();
3441   if (m0 == MATCH_ERROR)
3442     return MATCH_ERROR;
3443
3444   m = gfc_match (" forall");
3445   if (m != MATCH_YES)
3446     return m;
3447
3448   m = match_forall_header (&head, &mask);
3449   if (m == MATCH_ERROR)
3450     goto cleanup;
3451   if (m == MATCH_NO)
3452     goto syntax;
3453
3454   if (gfc_match_eos () == MATCH_YES)
3455     {
3456       *st = ST_FORALL_BLOCK;
3457
3458       new_st.op = EXEC_FORALL;
3459       new_st.expr = mask;
3460       new_st.ext.forall_iterator = head;
3461
3462       return MATCH_YES;
3463     }
3464
3465   m = gfc_match_assignment ();
3466   if (m == MATCH_ERROR)
3467     goto cleanup;
3468   if (m == MATCH_NO)
3469     {
3470       m = gfc_match_pointer_assignment ();
3471       if (m == MATCH_ERROR)
3472         goto cleanup;
3473       if (m == MATCH_NO)
3474         goto syntax;
3475     }
3476
3477   c = gfc_get_code ();
3478   *c = new_st;
3479
3480   if (gfc_match_eos () != MATCH_YES)
3481     goto syntax;
3482
3483   gfc_clear_new_st ();
3484   new_st.op = EXEC_FORALL;
3485   new_st.expr = mask;
3486   new_st.ext.forall_iterator = head;
3487   new_st.block = gfc_get_code ();
3488
3489   new_st.block->op = EXEC_FORALL;
3490   new_st.block->next = c;
3491
3492   *st = ST_FORALL;
3493   return MATCH_YES;
3494
3495 syntax:
3496   gfc_syntax_error (ST_FORALL);
3497
3498 cleanup:
3499   gfc_free_forall_iterator (head);
3500   gfc_free_expr (mask);
3501   gfc_free_statements (c);
3502   return MATCH_NO;
3503 }