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