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