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           nl = gfc_get_namelist ();
2422           nl->sym = sym;
2423
2424           if (group_name->namelist == NULL)
2425             group_name->namelist = group_name->namelist_tail = nl;
2426           else
2427             {
2428               group_name->namelist_tail->next = nl;
2429               group_name->namelist_tail = nl;
2430             }
2431
2432           if (gfc_match_eos () == MATCH_YES)
2433             goto done;
2434
2435           m = gfc_match_char (',');
2436
2437           if (gfc_match_char ('/') == MATCH_YES)
2438             {
2439               m2 = gfc_match (" %s /", &group_name);
2440               if (m2 == MATCH_YES)
2441                 break;
2442               if (m2 == MATCH_ERROR)
2443                 goto error;
2444               goto syntax;
2445             }
2446
2447           if (m != MATCH_YES)
2448             goto syntax;
2449         }
2450     }
2451
2452 done:
2453   return MATCH_YES;
2454
2455 syntax:
2456   gfc_syntax_error (ST_NAMELIST);
2457
2458 error:
2459   return MATCH_ERROR;
2460 }
2461
2462
2463 /* Match a MODULE statement.  */
2464
2465 match
2466 gfc_match_module (void)
2467 {
2468   match m;
2469
2470   m = gfc_match (" %s%t", &gfc_new_block);
2471   if (m != MATCH_YES)
2472     return m;
2473
2474   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, NULL) == FAILURE)
2475     return MATCH_ERROR;
2476
2477   return MATCH_YES;
2478 }
2479
2480
2481 /* Free equivalence sets and lists.  Recursively is the easiest way to
2482    do this.  */
2483
2484 void
2485 gfc_free_equiv (gfc_equiv * eq)
2486 {
2487
2488   if (eq == NULL)
2489     return;
2490
2491   gfc_free_equiv (eq->eq);
2492   gfc_free_equiv (eq->next);
2493
2494   gfc_free_expr (eq->expr);
2495   gfc_free (eq);
2496 }
2497
2498
2499 /* Match an EQUIVALENCE statement.  */
2500
2501 match
2502 gfc_match_equivalence (void)
2503 {
2504   gfc_equiv *eq, *set, *tail;
2505   gfc_ref *ref;
2506   match m;
2507
2508   tail = NULL;
2509
2510   for (;;)
2511     {
2512       eq = gfc_get_equiv ();
2513       if (tail == NULL)
2514         tail = eq;
2515
2516       eq->next = gfc_current_ns->equiv;
2517       gfc_current_ns->equiv = eq;
2518
2519       if (gfc_match_char ('(') != MATCH_YES)
2520         goto syntax;
2521
2522       set = eq;
2523
2524       for (;;)
2525         {
2526           m = gfc_match_variable (&set->expr, 1);
2527           if (m == MATCH_ERROR)
2528             goto cleanup;
2529           if (m == MATCH_NO)
2530             goto syntax;
2531
2532           for (ref = set->expr->ref; ref; ref = ref->next)
2533             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2534               {
2535                 gfc_error
2536                   ("Array reference in EQUIVALENCE at %C cannot be an "
2537                    "array section");
2538                 goto cleanup;
2539               }
2540
2541           if (gfc_match_char (')') == MATCH_YES)
2542             break;
2543           if (gfc_match_char (',') != MATCH_YES)
2544             goto syntax;
2545
2546           set->eq = gfc_get_equiv ();
2547           set = set->eq;
2548         }
2549
2550       if (gfc_match_eos () == MATCH_YES)
2551         break;
2552       if (gfc_match_char (',') != MATCH_YES)
2553         goto syntax;
2554     }
2555
2556   return MATCH_YES;
2557
2558 syntax:
2559   gfc_syntax_error (ST_EQUIVALENCE);
2560
2561 cleanup:
2562   eq = tail->next;
2563   tail->next = NULL;
2564
2565   gfc_free_equiv (gfc_current_ns->equiv);
2566   gfc_current_ns->equiv = eq;
2567
2568   return MATCH_ERROR;
2569 }
2570
2571
2572 /* Match a statement function declaration.  It is so easy to match
2573    non-statement function statements with a MATCH_ERROR as opposed to
2574    MATCH_NO that we suppress error message in most cases.  */
2575
2576 match
2577 gfc_match_st_function (void)
2578 {
2579   gfc_error_buf old_error;
2580   gfc_symbol *sym;
2581   gfc_expr *expr;
2582   match m;
2583
2584   m = gfc_match_symbol (&sym, 0);
2585   if (m != MATCH_YES)
2586     return m;
2587
2588   gfc_push_error (&old_error);
2589
2590   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, NULL) == FAILURE)
2591     goto undo_error;
2592
2593   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2594     goto undo_error;
2595
2596   m = gfc_match (" = %e%t", &expr);
2597   if (m == MATCH_NO)
2598     goto undo_error;
2599   if (m == MATCH_ERROR)
2600     return m;
2601
2602   sym->value = expr;
2603
2604   return MATCH_YES;
2605
2606 undo_error:
2607   gfc_pop_error (&old_error);
2608   return MATCH_NO;
2609 }
2610
2611
2612 /***************** SELECT CASE subroutines ******************/
2613
2614 /* Free a single case structure.  */
2615
2616 static void
2617 free_case (gfc_case * p)
2618 {
2619   if (p->low == p->high)
2620     p->high = NULL;
2621   gfc_free_expr (p->low);
2622   gfc_free_expr (p->high);
2623   gfc_free (p);
2624 }
2625
2626
2627 /* Free a list of case structures.  */
2628
2629 void
2630 gfc_free_case_list (gfc_case * p)
2631 {
2632   gfc_case *q;
2633
2634   for (; p; p = q)
2635     {
2636       q = p->next;
2637       free_case (p);
2638     }
2639 }
2640
2641
2642 /* Match a single case selector.  */
2643
2644 static match
2645 match_case_selector (gfc_case ** cp)
2646 {
2647   gfc_case *c;
2648   match m;
2649
2650   c = gfc_get_case ();
2651   c->where = gfc_current_locus;
2652
2653   if (gfc_match_char (':') == MATCH_YES)
2654     {
2655       m = gfc_match_init_expr (&c->high);
2656       if (m == MATCH_NO)
2657         goto need_expr;
2658       if (m == MATCH_ERROR)
2659         goto cleanup;
2660     }
2661
2662   else
2663     {
2664       m = gfc_match_init_expr (&c->low);
2665       if (m == MATCH_ERROR)
2666         goto cleanup;
2667       if (m == MATCH_NO)
2668         goto need_expr;
2669
2670       /* If we're not looking at a ':' now, make a range out of a single
2671          target.  Else get the upper bound for the case range.  */
2672       if (gfc_match_char (':') != MATCH_YES)
2673         c->high = c->low;
2674       else
2675         {
2676           m = gfc_match_init_expr (&c->high);
2677           if (m == MATCH_ERROR)
2678             goto cleanup;
2679           /* MATCH_NO is fine.  It's OK if nothing is there!  */
2680         }
2681     }
2682
2683   *cp = c;
2684   return MATCH_YES;
2685
2686 need_expr:
2687   gfc_error ("Expected initialization expression in CASE at %C");
2688
2689 cleanup:
2690   free_case (c);
2691   return MATCH_ERROR;
2692 }
2693
2694
2695 /* Match the end of a case statement.  */
2696
2697 static match
2698 match_case_eos (void)
2699 {
2700   char name[GFC_MAX_SYMBOL_LEN + 1];
2701   match m;
2702
2703   if (gfc_match_eos () == MATCH_YES)
2704     return MATCH_YES;
2705
2706   gfc_gobble_whitespace ();
2707
2708   m = gfc_match_name (name);
2709   if (m != MATCH_YES)
2710     return m;
2711
2712   if (strcmp (name, gfc_current_block ()->name) != 0)
2713     {
2714       gfc_error ("Expected case name of '%s' at %C",
2715                  gfc_current_block ()->name);
2716       return MATCH_ERROR;
2717     }
2718
2719   return gfc_match_eos ();
2720 }
2721
2722
2723 /* Match a SELECT statement.  */
2724
2725 match
2726 gfc_match_select (void)
2727 {
2728   gfc_expr *expr;
2729   match m;
2730
2731   m = gfc_match_label ();
2732   if (m == MATCH_ERROR)
2733     return m;
2734
2735   m = gfc_match (" select case ( %e )%t", &expr);
2736   if (m != MATCH_YES)
2737     return m;
2738
2739   new_st.op = EXEC_SELECT;
2740   new_st.expr = expr;
2741
2742   return MATCH_YES;
2743 }
2744
2745
2746 /* Match a CASE statement.  */
2747
2748 match
2749 gfc_match_case (void)
2750 {
2751   gfc_case *c, *head, *tail;
2752   match m;
2753
2754   head = tail = NULL;
2755
2756   if (gfc_current_state () != COMP_SELECT)
2757     {
2758       gfc_error ("Unexpected CASE statement at %C");
2759       return MATCH_ERROR;
2760     }
2761
2762   if (gfc_match ("% default") == MATCH_YES)
2763     {
2764       m = match_case_eos ();
2765       if (m == MATCH_NO)
2766         goto syntax;
2767       if (m == MATCH_ERROR)
2768         goto cleanup;
2769
2770       new_st.op = EXEC_SELECT;
2771       c = gfc_get_case ();
2772       c->where = gfc_current_locus;
2773       new_st.ext.case_list = c;
2774       return MATCH_YES;
2775     }
2776
2777   if (gfc_match_char ('(') != MATCH_YES)
2778     goto syntax;
2779
2780   for (;;)
2781     {
2782       if (match_case_selector (&c) == MATCH_ERROR)
2783         goto cleanup;
2784
2785       if (head == NULL)
2786         head = c;
2787       else
2788         tail->next = c;
2789
2790       tail = c;
2791
2792       if (gfc_match_char (')') == MATCH_YES)
2793         break;
2794       if (gfc_match_char (',') != MATCH_YES)
2795         goto syntax;
2796     }
2797
2798   m = match_case_eos ();
2799   if (m == MATCH_NO)
2800     goto syntax;
2801   if (m == MATCH_ERROR)
2802     goto cleanup;
2803
2804   new_st.op = EXEC_SELECT;
2805   new_st.ext.case_list = head;
2806
2807   return MATCH_YES;
2808
2809 syntax:
2810   gfc_error ("Syntax error in CASE-specification at %C");
2811
2812 cleanup:
2813   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
2814   return MATCH_ERROR;
2815 }
2816
2817 /********************* WHERE subroutines ********************/
2818
2819 /* Match the rest of a simple WHERE statement that follows an IF statement.
2820  */
2821
2822 static match
2823 match_simple_where (void)
2824 {
2825   gfc_expr *expr;
2826   gfc_code *c;
2827   match m;
2828
2829   m = gfc_match (" ( %e )", &expr);
2830   if (m != MATCH_YES)
2831     return m;
2832
2833   m = gfc_match_assignment ();
2834   if (m == MATCH_NO)
2835     goto syntax;
2836   if (m == MATCH_ERROR)
2837     goto cleanup;
2838
2839   if (gfc_match_eos () != MATCH_YES)
2840     goto syntax;
2841
2842   c = gfc_get_code ();
2843
2844   c->op = EXEC_WHERE;
2845   c->expr = expr;
2846   c->next = gfc_get_code ();
2847
2848   *c->next = new_st;
2849   gfc_clear_new_st ();
2850
2851   new_st.op = EXEC_WHERE;
2852   new_st.block = c;
2853
2854   return MATCH_YES;
2855
2856 syntax:
2857   gfc_syntax_error (ST_WHERE);
2858
2859 cleanup:
2860   gfc_free_expr (expr);
2861   return MATCH_ERROR;
2862 }
2863
2864 /* Match a WHERE statement.  */
2865
2866 match
2867 gfc_match_where (gfc_statement * st)
2868 {
2869   gfc_expr *expr;
2870   match m0, m;
2871   gfc_code *c;
2872
2873   m0 = gfc_match_label ();
2874   if (m0 == MATCH_ERROR)
2875     return m0;
2876
2877   m = gfc_match (" where ( %e )", &expr);
2878   if (m != MATCH_YES)
2879     return m;
2880
2881   if (gfc_match_eos () == MATCH_YES)
2882     {
2883       *st = ST_WHERE_BLOCK;
2884
2885       new_st.op = EXEC_WHERE;
2886       new_st.expr = expr;
2887       return MATCH_YES;
2888     }
2889
2890   m = gfc_match_assignment ();
2891   if (m == MATCH_NO)
2892     gfc_syntax_error (ST_WHERE);
2893
2894   if (m != MATCH_YES)
2895     {
2896       gfc_free_expr (expr);
2897       return MATCH_ERROR;
2898     }
2899
2900   /* We've got a simple WHERE statement.  */
2901   *st = ST_WHERE;
2902   c = gfc_get_code ();
2903
2904   c->op = EXEC_WHERE;
2905   c->expr = expr;
2906   c->next = gfc_get_code ();
2907
2908   *c->next = new_st;
2909   gfc_clear_new_st ();
2910
2911   new_st.op = EXEC_WHERE;
2912   new_st.block = c;
2913
2914   return MATCH_YES;
2915 }
2916
2917
2918 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
2919    new_st if successful.  */
2920
2921 match
2922 gfc_match_elsewhere (void)
2923 {
2924   char name[GFC_MAX_SYMBOL_LEN + 1];
2925   gfc_expr *expr;
2926   match m;
2927
2928   if (gfc_current_state () != COMP_WHERE)
2929     {
2930       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
2931       return MATCH_ERROR;
2932     }
2933
2934   expr = NULL;
2935
2936   if (gfc_match_char ('(') == MATCH_YES)
2937     {
2938       m = gfc_match_expr (&expr);
2939       if (m == MATCH_NO)
2940         goto syntax;
2941       if (m == MATCH_ERROR)
2942         return MATCH_ERROR;
2943
2944       if (gfc_match_char (')') != MATCH_YES)
2945         goto syntax;
2946     }
2947
2948   if (gfc_match_eos () != MATCH_YES)
2949     {                           /* Better be a name at this point */
2950       m = gfc_match_name (name);
2951       if (m == MATCH_NO)
2952         goto syntax;
2953       if (m == MATCH_ERROR)
2954         goto cleanup;
2955
2956       if (gfc_match_eos () != MATCH_YES)
2957         goto syntax;
2958
2959       if (strcmp (name, gfc_current_block ()->name) != 0)
2960         {
2961           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
2962                      name, gfc_current_block ()->name);
2963           goto cleanup;
2964         }
2965     }
2966
2967   new_st.op = EXEC_WHERE;
2968   new_st.expr = expr;
2969   return MATCH_YES;
2970
2971 syntax:
2972   gfc_syntax_error (ST_ELSEWHERE);
2973
2974 cleanup:
2975   gfc_free_expr (expr);
2976   return MATCH_ERROR;
2977 }
2978
2979
2980 /******************** FORALL subroutines ********************/
2981
2982 /* Free a list of FORALL iterators.  */
2983
2984 void
2985 gfc_free_forall_iterator (gfc_forall_iterator * iter)
2986 {
2987   gfc_forall_iterator *next;
2988
2989   while (iter)
2990     {
2991       next = iter->next;
2992
2993       gfc_free_expr (iter->var);
2994       gfc_free_expr (iter->start);
2995       gfc_free_expr (iter->end);
2996       gfc_free_expr (iter->stride);
2997
2998       gfc_free (iter);
2999       iter = next;
3000     }
3001 }
3002
3003
3004 /* Match an iterator as part of a FORALL statement.  The format is:
3005
3006      <var> = <start>:<end>[:<stride>][, <scalar mask>]  */
3007
3008 static match
3009 match_forall_iterator (gfc_forall_iterator ** result)
3010 {
3011   gfc_forall_iterator *iter;
3012   locus where;
3013   match m;
3014
3015   where = gfc_current_locus;
3016   iter = gfc_getmem (sizeof (gfc_forall_iterator));
3017
3018   m = gfc_match_variable (&iter->var, 0);
3019   if (m != MATCH_YES)
3020     goto cleanup;
3021
3022   if (gfc_match_char ('=') != MATCH_YES)
3023     {
3024       m = MATCH_NO;
3025       goto cleanup;
3026     }
3027
3028   m = gfc_match_expr (&iter->start);
3029   if (m == MATCH_NO)
3030     goto syntax;
3031   if (m == MATCH_ERROR)
3032     goto cleanup;
3033
3034   if (gfc_match_char (':') != MATCH_YES)
3035     goto syntax;
3036
3037   m = gfc_match_expr (&iter->end);
3038   if (m == MATCH_NO)
3039     goto syntax;
3040   if (m == MATCH_ERROR)
3041     goto cleanup;
3042
3043   if (gfc_match_char (':') == MATCH_NO)
3044     iter->stride = gfc_int_expr (1);
3045   else
3046     {
3047       m = gfc_match_expr (&iter->stride);
3048       if (m == MATCH_NO)
3049         goto syntax;
3050       if (m == MATCH_ERROR)
3051         goto cleanup;
3052     }
3053
3054   *result = iter;
3055   return MATCH_YES;
3056
3057 syntax:
3058   gfc_error ("Syntax error in FORALL iterator at %C");
3059   m = MATCH_ERROR;
3060
3061 cleanup:
3062   gfc_current_locus = where;
3063   gfc_free_forall_iterator (iter);
3064   return m;
3065 }
3066
3067
3068 /* Match the header of a FORALL statement.  */
3069
3070 static match
3071 match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
3072 {
3073   gfc_forall_iterator *head, *tail, *new;
3074   match m;
3075
3076   gfc_gobble_whitespace ();
3077
3078   head = tail = NULL;
3079   *mask = NULL;
3080
3081   if (gfc_match_char ('(') != MATCH_YES)
3082     return MATCH_NO;
3083
3084   m = match_forall_iterator (&new);
3085   if (m == MATCH_ERROR)
3086     goto cleanup;
3087   if (m == MATCH_NO)
3088     goto syntax;
3089
3090   head = tail = new;
3091
3092   for (;;)
3093     {
3094       if (gfc_match_char (',') != MATCH_YES)
3095         break;
3096
3097       m = match_forall_iterator (&new);
3098       if (m == MATCH_ERROR)
3099         goto cleanup;
3100       if (m == MATCH_YES)
3101         {
3102           tail->next = new;
3103           tail = new;
3104           continue;
3105         }
3106
3107       /* Have to have a mask expression */
3108
3109       m = gfc_match_expr (mask);
3110       if (m == MATCH_NO)
3111         goto syntax;
3112       if (m == MATCH_ERROR)
3113         goto cleanup;
3114
3115       break;
3116     }
3117
3118   if (gfc_match_char (')') == MATCH_NO)
3119     goto syntax;
3120
3121   *phead = head;
3122   return MATCH_YES;
3123
3124 syntax:
3125   gfc_syntax_error (ST_FORALL);
3126
3127 cleanup:
3128   gfc_free_expr (*mask);
3129   gfc_free_forall_iterator (head);
3130
3131   return MATCH_ERROR;
3132 }
3133
3134 /* Match the rest of a simple FORALL statement that follows an IF statement.
3135  */
3136
3137 static match
3138 match_simple_forall (void)
3139 {
3140   gfc_forall_iterator *head;
3141   gfc_expr *mask;
3142   gfc_code *c;
3143   match m;
3144
3145   mask = NULL;
3146   head = NULL;
3147   c = NULL;
3148
3149   m = match_forall_header (&head, &mask);
3150
3151   if (m == MATCH_NO)
3152     goto syntax;
3153   if (m != MATCH_YES)
3154     goto cleanup;
3155
3156   m = gfc_match_assignment ();
3157
3158   if (m == MATCH_ERROR)
3159     goto cleanup;
3160   if (m == MATCH_NO)
3161     {
3162       m = gfc_match_pointer_assignment ();
3163       if (m == MATCH_ERROR)
3164         goto cleanup;
3165       if (m == MATCH_NO)
3166         goto syntax;
3167     }
3168
3169   c = gfc_get_code ();
3170   *c = new_st;
3171   c->loc = gfc_current_locus;
3172
3173   if (gfc_match_eos () != MATCH_YES)
3174     goto syntax;
3175
3176   gfc_clear_new_st ();
3177   new_st.op = EXEC_FORALL;
3178   new_st.expr = mask;
3179   new_st.ext.forall_iterator = head;
3180   new_st.block = gfc_get_code ();
3181
3182   new_st.block->op = EXEC_FORALL;
3183   new_st.block->next = c;
3184
3185   return MATCH_YES;
3186
3187 syntax:
3188   gfc_syntax_error (ST_FORALL);
3189
3190 cleanup:
3191   gfc_free_forall_iterator (head);
3192   gfc_free_expr (mask);
3193
3194   return MATCH_ERROR;
3195 }
3196
3197
3198 /* Match a FORALL statement.  */
3199
3200 match
3201 gfc_match_forall (gfc_statement * st)
3202 {
3203   gfc_forall_iterator *head;
3204   gfc_expr *mask;
3205   gfc_code *c;
3206   match m0, m;
3207
3208   head = NULL;
3209   mask = NULL;
3210   c = NULL;
3211
3212   m0 = gfc_match_label ();
3213   if (m0 == MATCH_ERROR)
3214     return MATCH_ERROR;
3215
3216   m = gfc_match (" forall");
3217   if (m != MATCH_YES)
3218     return m;
3219
3220   m = match_forall_header (&head, &mask);
3221   if (m == MATCH_ERROR)
3222     goto cleanup;
3223   if (m == MATCH_NO)
3224     goto syntax;
3225
3226   if (gfc_match_eos () == MATCH_YES)
3227     {
3228       *st = ST_FORALL_BLOCK;
3229
3230       new_st.op = EXEC_FORALL;
3231       new_st.expr = mask;
3232       new_st.ext.forall_iterator = head;
3233
3234       return MATCH_YES;
3235     }
3236
3237   m = gfc_match_assignment ();
3238   if (m == MATCH_ERROR)
3239     goto cleanup;
3240   if (m == MATCH_NO)
3241     {
3242       m = gfc_match_pointer_assignment ();
3243       if (m == MATCH_ERROR)
3244         goto cleanup;
3245       if (m == MATCH_NO)
3246         goto syntax;
3247     }
3248
3249   c = gfc_get_code ();
3250   *c = new_st;
3251
3252   if (gfc_match_eos () != MATCH_YES)
3253     goto syntax;
3254
3255   gfc_clear_new_st ();
3256   new_st.op = EXEC_FORALL;
3257   new_st.expr = mask;
3258   new_st.ext.forall_iterator = head;
3259   new_st.block = gfc_get_code ();
3260
3261   new_st.block->op = EXEC_FORALL;
3262   new_st.block->next = c;
3263
3264   *st = ST_FORALL;
3265   return MATCH_YES;
3266
3267 syntax:
3268   gfc_syntax_error (ST_FORALL);
3269
3270 cleanup:
3271   gfc_free_forall_iterator (head);
3272   gfc_free_expr (mask);
3273   gfc_free_statements (c);
3274   return MATCH_NO;
3275 }