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