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 gfc_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   new_st.op = EXEC_ARITHMETIC_IF;
 926   new_st.expr = expr;
 927   new_st.label = l1;
 928   new_st.label2 = l2;
 929   new_st.label3 = l3;
 930
 931   return MATCH_YES;
 932 }
 933
 934
 935 /* The IF statement is a bit of a pain.  First of all, there are three
 936    forms of it, the simple IF, the IF that starts a block and the
 937    arithmetic IF.
 938
 939    There is a problem with the simple IF and that is the fact that we
 940    only have a single level of undo information on symbols.  What this
 941    means is for a simple IF, we must re-match the whole IF statement
 942    multiple times in order to guarantee that the symbol table ends up
 943    in the proper state.  */
 944
 945 static match match_simple_forall (void);
 946 static match match_simple_where (void);
 947
 948 match
 949 gfc_match_if (gfc_statement * if_type)
 950 {
 951   gfc_expr *expr;
 952   gfc_st_label *l1, *l2, *l3;
 953   locus old_loc;
 954   gfc_code *p;
 955   match m, n;
 956
 957   n = gfc_match_label ();
 958   if (n == MATCH_ERROR)
 959     return n;
 960
 961   old_loc = gfc_current_locus;
 962
 963   m = gfc_match (" if ( %e", &expr);
 964   if (m != MATCH_YES)
 965     return m;
 966
 967   if (gfc_match_char (')') != MATCH_YES)
 968     {
 969       gfc_error ("Syntax error in IF-expression at %C");
 970       gfc_free_expr (expr);
 971       return MATCH_ERROR;
 972     }
 973
 974   m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
 975
 976   if (m == MATCH_YES)
 977     {
 978       if (n == MATCH_YES)
 979         {
 980           gfc_error
 981             ("Block label not appropriate for arithmetic IF statement "
 982              "at %C");
 983
 984           gfc_free_expr (expr);
 985           return MATCH_ERROR;
 986         }
 987
 988       if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
 989           || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
 990           || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
 991         {
 992
 993           gfc_free_expr (expr);
 994           return MATCH_ERROR;
 995         }
 996
 997       new_st.op = EXEC_ARITHMETIC_IF;
 998       new_st.expr = expr;
 999       new_st.label = l1;
1000       new_st.label2 = l2;
1001       new_st.label3 = l3;
1002
1003       *if_type = ST_ARITHMETIC_IF;
1004       return MATCH_YES;
1005     }
1006
1007   if (gfc_match (" then%t") == MATCH_YES)
1008     {
1009       new_st.op = EXEC_IF;
1010       new_st.expr = expr;
1011
1012       *if_type = ST_IF_BLOCK;
1013       return MATCH_YES;
1014     }
1015
1016   if (n == MATCH_YES)
1017     {
1018       gfc_error ("Block label is not appropriate IF statement at %C");
1019
1020       gfc_free_expr (expr);
1021       return MATCH_ERROR;
1022     }
1023
1024   /* At this point the only thing left is a simple IF statement.  At
1025      this point, n has to be MATCH_NO, so we don't have to worry about
1026      re-matching a block label.  From what we've got so far, try
1027      matching an assignment.  */
1028
1029   *if_type = ST_SIMPLE_IF;
1030
1031   m = gfc_match_assignment ();
1032   if (m == MATCH_YES)
1033     goto got_match;
1034
1035   gfc_free_expr (expr);
1036   gfc_undo_symbols ();
1037   gfc_current_locus = old_loc;
1038
1039   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match */
1040
1041   m = gfc_match_pointer_assignment ();
1042   if (m == MATCH_YES)
1043     goto got_match;
1044
1045   gfc_free_expr (expr);
1046   gfc_undo_symbols ();
1047   gfc_current_locus = old_loc;
1048
1049   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match */
1050
1051   /* Look at the next keyword to see which matcher to call.  Matching
1052      the keyword doesn't affect the symbol table, so we don't have to
1053      restore between tries.  */
1054
1055 #define match(string, subr, statement) \
1056   if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1057
1058   gfc_clear_error ();
1059
1060   match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1061     match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1062     match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1063     match ("call", gfc_match_call, ST_CALL)
1064     match ("close", gfc_match_close, ST_CLOSE)
1065     match ("continue", gfc_match_continue, ST_CONTINUE)
1066     match ("cycle", gfc_match_cycle, ST_CYCLE)
1067     match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1068     match ("end file", gfc_match_endfile, ST_END_FILE)
1069     match ("exit", gfc_match_exit, ST_EXIT)
1070     match ("forall", match_simple_forall, ST_FORALL)
1071     match ("go to", gfc_match_goto, ST_GOTO)
1072     match ("if", gfc_match_arithmetic_if, ST_ARITHMETIC_IF)
1073     match ("inquire", gfc_match_inquire, ST_INQUIRE)
1074     match ("nullify", gfc_match_nullify, ST_NULLIFY)
1075     match ("open", gfc_match_open, ST_OPEN)
1076     match ("pause", gfc_match_pause, ST_NONE)
1077     match ("print", gfc_match_print, ST_WRITE)
1078     match ("read", gfc_match_read, ST_READ)
1079     match ("return", gfc_match_return, ST_RETURN)
1080     match ("rewind", gfc_match_rewind, ST_REWIND)
1081     match ("stop", gfc_match_stop, ST_STOP)
1082     match ("where", match_simple_where, ST_WHERE)
1083     match ("write", gfc_match_write, ST_WRITE)
1084
1085   /* All else has failed, so give up.  See if any of the matchers has
1086      stored an error message of some sort.  */
1087     if (gfc_error_check () == 0)
1088     gfc_error ("Unclassifiable statement in IF-clause at %C");
1089
1090   gfc_free_expr (expr);
1091   return MATCH_ERROR;
1092
1093 got_match:
1094   if (m == MATCH_NO)
1095     gfc_error ("Syntax error in IF-clause at %C");
1096   if (m != MATCH_YES)
1097     {
1098       gfc_free_expr (expr);
1099       return MATCH_ERROR;
1100     }
1101
1102   /* At this point, we've matched the single IF and the action clause
1103      is in new_st.  Rearrange things so that the IF statement appears
1104      in new_st.  */
1105
1106   p = gfc_get_code ();
1107   p->next = gfc_get_code ();
1108   *p->next = new_st;
1109   p->next->loc = gfc_current_locus;
1110
1111   p->expr = expr;
1112   p->op = EXEC_IF;
1113
1114   gfc_clear_new_st ();
1115
1116   new_st.op = EXEC_IF;
1117   new_st.block = p;
1118
1119   return MATCH_YES;
1120 }
1121
1122 #undef match
1123
1124
1125 /* Match an ELSE statement.  */
1126
1127 match
1128 gfc_match_else (void)
1129 {
1130   char name[GFC_MAX_SYMBOL_LEN + 1];
1131
1132   if (gfc_match_eos () == MATCH_YES)
1133     return MATCH_YES;
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 statement at %C");
1140       return MATCH_ERROR;
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       return MATCH_ERROR;
1148     }
1149
1150   return MATCH_YES;
1151 }
1152
1153
1154 /* Match an ELSE IF statement.  */
1155
1156 match
1157 gfc_match_elseif (void)
1158 {
1159   char name[GFC_MAX_SYMBOL_LEN + 1];
1160   gfc_expr *expr;
1161   match m;
1162
1163   m = gfc_match (" ( %e ) then", &expr);
1164   if (m != MATCH_YES)
1165     return m;
1166
1167   if (gfc_match_eos () == MATCH_YES)
1168     goto done;
1169
1170   if (gfc_match_name (name) != MATCH_YES
1171       || gfc_current_block () == NULL
1172       || gfc_match_eos () != MATCH_YES)
1173     {
1174       gfc_error ("Unexpected junk after ELSE IF statement at %C");
1175       goto cleanup;
1176     }
1177
1178   if (strcmp (name, gfc_current_block ()->name) != 0)
1179     {
1180       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1181                  name, gfc_current_block ()->name);
1182       goto cleanup;
1183     }
1184
1185 done:
1186   new_st.op = EXEC_IF;
1187   new_st.expr = expr;
1188   return MATCH_YES;
1189
1190 cleanup:
1191   gfc_free_expr (expr);
1192   return MATCH_ERROR;
1193 }
1194
1195
1196 /* Free a gfc_iterator structure.  */
1197
1198 void
1199 gfc_free_iterator (gfc_iterator * iter, int flag)
1200 {
1201
1202   if (iter == NULL)
1203     return;
1204
1205   gfc_free_expr (iter->var);
1206   gfc_free_expr (iter->start);
1207   gfc_free_expr (iter->end);
1208   gfc_free_expr (iter->step);
1209
1210   if (flag)
1211     gfc_free (iter);
1212 }
1213
1214
1215 /* Match a DO statement.  */
1216
1217 match
1218 gfc_match_do (void)
1219 {
1220   gfc_iterator iter, *ip;
1221   locus old_loc;
1222   gfc_st_label *label;
1223   match m;
1224
1225   old_loc = gfc_current_locus;
1226
1227   label = NULL;
1228   iter.var = iter.start = iter.end = iter.step = NULL;
1229
1230   m = gfc_match_label ();
1231   if (m == MATCH_ERROR)
1232     return m;
1233
1234   if (gfc_match (" do") != MATCH_YES)
1235     return MATCH_NO;
1236
1237   m = gfc_match_st_label (&label, 0);
1238   if (m == MATCH_ERROR)
1239     goto cleanup;
1240
1241 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1242
1243   if (gfc_match_eos () == MATCH_YES)
1244     {
1245       iter.end = gfc_logical_expr (1, NULL);
1246       new_st.op = EXEC_DO_WHILE;
1247       goto done;
1248     }
1249
1250   /* match an optional comma, if no comma is found a space is obligatory.  */
1251   if (gfc_match_char(',') != MATCH_YES
1252       && gfc_match ("% ") != MATCH_YES)
1253     return MATCH_NO;
1254
1255   /* See if we have a DO WHILE.  */
1256   if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1257     {
1258       new_st.op = EXEC_DO_WHILE;
1259       goto done;
1260     }
1261
1262   /* The abortive DO WHILE may have done something to the symbol
1263      table, so we start over: */
1264   gfc_undo_symbols ();
1265   gfc_current_locus = old_loc;
1266
1267   gfc_match_label ();           /* This won't error */
1268   gfc_match (" do ");           /* This will work */
1269
1270   gfc_match_st_label (&label, 0);       /* Can't error out */
1271   gfc_match_char (',');         /* Optional comma */
1272
1273   m = gfc_match_iterator (&iter, 0);
1274   if (m == MATCH_NO)
1275     return MATCH_NO;
1276   if (m == MATCH_ERROR)
1277     goto cleanup;
1278
1279   gfc_check_do_variable (iter.var->symtree);
1280
1281   if (gfc_match_eos () != MATCH_YES)
1282     {
1283       gfc_syntax_error (ST_DO);
1284       goto cleanup;
1285     }
1286
1287   new_st.op = EXEC_DO;
1288
1289 done:
1290   if (label != NULL
1291       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1292     goto cleanup;
1293
1294   new_st.label = label;
1295
1296   if (new_st.op == EXEC_DO_WHILE)
1297     new_st.expr = iter.end;
1298   else
1299     {
1300       new_st.ext.iterator = ip = gfc_get_iterator ();
1301       *ip = iter;
1302     }
1303
1304   return MATCH_YES;
1305
1306 cleanup:
1307   gfc_free_iterator (&iter, 0);
1308
1309   return MATCH_ERROR;
1310 }
1311
1312
1313 /* Match an EXIT or CYCLE statement.  */
1314
1315 static match
1316 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1317 {
1318   gfc_state_data *p;
1319   gfc_symbol *sym;
1320   match m;
1321
1322   if (gfc_match_eos () == MATCH_YES)
1323     sym = NULL;
1324   else
1325     {
1326       m = gfc_match ("% %s%t", &sym);
1327       if (m == MATCH_ERROR)
1328         return MATCH_ERROR;
1329       if (m == MATCH_NO)
1330         {
1331           gfc_syntax_error (st);
1332           return MATCH_ERROR;
1333         }
1334
1335       if (sym->attr.flavor != FL_LABEL)
1336         {
1337           gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1338                      sym->name, gfc_ascii_statement (st));
1339           return MATCH_ERROR;
1340         }
1341     }
1342
1343   /* Find the loop mentioned specified by the label (or lack of a
1344      label).  */
1345   for (p = gfc_state_stack; p; p = p->previous)
1346     if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1347       break;
1348
1349   if (p == NULL)
1350     {
1351       if (sym == NULL)
1352         gfc_error ("%s statement at %C is not within a loop",
1353                    gfc_ascii_statement (st));
1354       else
1355         gfc_error ("%s statement at %C is not within loop '%s'",
1356                    gfc_ascii_statement (st), sym->name);
1357
1358       return MATCH_ERROR;
1359     }
1360
1361   /* Save the first statement in the loop - needed by the backend.  */
1362   new_st.ext.whichloop = p->head;
1363
1364   new_st.op = op;
1365 /*  new_st.sym = sym;*/
1366
1367   return MATCH_YES;
1368 }
1369
1370
1371 /* Match the EXIT statement.  */
1372
1373 match
1374 gfc_match_exit (void)
1375 {
1376
1377   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1378 }
1379
1380
1381 /* Match the CYCLE statement.  */
1382
1383 match
1384 gfc_match_cycle (void)
1385 {
1386
1387   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1388 }
1389
1390
1391 /* Match a number or character constant after a STOP or PAUSE statement.  */
1392
1393 static match
1394 gfc_match_stopcode (gfc_statement st)
1395 {
1396   int stop_code;
1397   gfc_expr *e;
1398   match m;
1399
1400   stop_code = 0;
1401   e = NULL;
1402
1403   if (gfc_match_eos () != MATCH_YES)
1404     {
1405       m = gfc_match_small_literal_int (&stop_code);
1406       if (m == MATCH_ERROR)
1407         goto cleanup;
1408
1409       if (m == MATCH_YES && stop_code > 99999)
1410         {
1411           gfc_error ("STOP code out of range at %C");
1412           goto cleanup;
1413         }
1414
1415       if (m == MATCH_NO)
1416         {
1417           /* Try a character constant.  */
1418           m = gfc_match_expr (&e);
1419           if (m == MATCH_ERROR)
1420             goto cleanup;
1421           if (m == MATCH_NO)
1422             goto syntax;
1423           if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1424             goto syntax;
1425         }
1426
1427       if (gfc_match_eos () != MATCH_YES)
1428         goto syntax;
1429     }
1430
1431   if (gfc_pure (NULL))
1432     {
1433       gfc_error ("%s statement not allowed in PURE procedure at %C",
1434                  gfc_ascii_statement (st));
1435       goto cleanup;
1436     }
1437
1438   new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1439   new_st.expr = e;
1440   new_st.ext.stop_code = stop_code;
1441
1442   return MATCH_YES;
1443
1444 syntax:
1445   gfc_syntax_error (st);
1446
1447 cleanup:
1448
1449   gfc_free_expr (e);
1450   return MATCH_ERROR;
1451 }
1452
1453 /* Match the (deprecated) PAUSE statement.  */
1454
1455 match
1456 gfc_match_pause (void)
1457 {
1458   match m;
1459
1460   m = gfc_match_stopcode (ST_PAUSE);
1461   if (m == MATCH_YES)
1462     {
1463       if (gfc_notify_std (GFC_STD_F95_DEL,
1464             "Obsolete: PAUSE statement at %C")
1465           == FAILURE)
1466         m = MATCH_ERROR;
1467     }
1468   return m;
1469 }
1470
1471
1472 /* Match the STOP statement.  */
1473
1474 match
1475 gfc_match_stop (void)
1476 {
1477   return gfc_match_stopcode (ST_STOP);
1478 }
1479
1480
1481 /* Match a CONTINUE statement.  */
1482
1483 match
1484 gfc_match_continue (void)
1485 {
1486
1487   if (gfc_match_eos () != MATCH_YES)
1488     {
1489       gfc_syntax_error (ST_CONTINUE);
1490       return MATCH_ERROR;
1491     }
1492
1493   new_st.op = EXEC_CONTINUE;
1494   return MATCH_YES;
1495 }
1496
1497
1498 /* Match the (deprecated) ASSIGN statement.  */
1499
1500 match
1501 gfc_match_assign (void)
1502 {
1503   gfc_expr *expr;
1504   gfc_st_label *label;
1505
1506   if (gfc_match (" %l", &label) == MATCH_YES)
1507     {
1508       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
1509         return MATCH_ERROR;
1510       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
1511         {
1512           if (gfc_notify_std (GFC_STD_F95_DEL,
1513                 "Obsolete: ASSIGN statement at %C")
1514               == FAILURE)
1515             return MATCH_ERROR;
1516
1517           expr->symtree->n.sym->attr.assign = 1;
1518
1519           new_st.op = EXEC_LABEL_ASSIGN;
1520           new_st.label = label;
1521           new_st.expr = expr;
1522           return MATCH_YES;
1523         }
1524     }
1525   return MATCH_NO;
1526 }
1527
1528
1529 /* Match the GO TO statement.  As a computed GOTO statement is
1530    matched, it is transformed into an equivalent SELECT block.  No
1531    tree is necessary, and the resulting jumps-to-jumps are
1532    specifically optimized away by the back end.  */
1533
1534 match
1535 gfc_match_goto (void)
1536 {
1537   gfc_code *head, *tail;
1538   gfc_expr *expr;
1539   gfc_case *cp;
1540   gfc_st_label *label;
1541   int i;
1542   match m;
1543
1544   if (gfc_match (" %l%t", &label) == MATCH_YES)
1545     {
1546       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1547         return MATCH_ERROR;
1548
1549       new_st.op = EXEC_GOTO;
1550       new_st.label = label;
1551       return MATCH_YES;
1552     }
1553
1554   /* The assigned GO TO statement.  */
1555
1556   if (gfc_match_variable (&expr, 0) == MATCH_YES)
1557     {
1558       if (gfc_notify_std (GFC_STD_F95_DEL,
1559                           "Obsolete: Assigned GOTO statement at %C")
1560           == FAILURE)
1561         return MATCH_ERROR;
1562
1563       new_st.op = EXEC_GOTO;
1564       new_st.expr = expr;
1565
1566       if (gfc_match_eos () == MATCH_YES)
1567         return MATCH_YES;
1568
1569       /* Match label list.  */
1570       gfc_match_char (',');
1571       if (gfc_match_char ('(') != MATCH_YES)
1572         {
1573           gfc_syntax_error (ST_GOTO);
1574           return MATCH_ERROR;
1575         }
1576       head = tail = NULL;
1577
1578       do
1579         {
1580           m = gfc_match_st_label (&label, 0);
1581           if (m != MATCH_YES)
1582             goto syntax;
1583
1584           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1585             goto cleanup;
1586
1587           if (head == NULL)
1588             head = tail = gfc_get_code ();
1589           else
1590             {
1591               tail->block = gfc_get_code ();
1592               tail = tail->block;
1593             }
1594
1595           tail->label = label;
1596           tail->op = EXEC_GOTO;
1597         }
1598       while (gfc_match_char (',') == MATCH_YES);
1599
1600       if (gfc_match (")%t") != MATCH_YES)
1601         goto syntax;
1602
1603       if (head == NULL)
1604         {
1605            gfc_error (
1606                "Statement label list in GOTO at %C cannot be empty");
1607            goto syntax;
1608         }
1609       new_st.block = head;
1610
1611       return MATCH_YES;
1612     }
1613
1614   /* Last chance is a computed GO TO statement.  */
1615   if (gfc_match_char ('(') != MATCH_YES)
1616     {
1617       gfc_syntax_error (ST_GOTO);
1618       return MATCH_ERROR;
1619     }
1620
1621   head = tail = NULL;
1622   i = 1;
1623
1624   do
1625     {
1626       m = gfc_match_st_label (&label, 0);
1627       if (m != MATCH_YES)
1628         goto syntax;
1629
1630       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1631         goto cleanup;
1632
1633       if (head == NULL)
1634         head = tail = gfc_get_code ();
1635       else
1636         {
1637           tail->block = gfc_get_code ();
1638           tail = tail->block;
1639         }
1640
1641       cp = gfc_get_case ();
1642       cp->low = cp->high = gfc_int_expr (i++);
1643
1644       tail->op = EXEC_SELECT;
1645       tail->ext.case_list = cp;
1646
1647       tail->next = gfc_get_code ();
1648       tail->next->op = EXEC_GOTO;
1649       tail->next->label = label;
1650     }
1651   while (gfc_match_char (',') == MATCH_YES);
1652
1653   if (gfc_match_char (')') != MATCH_YES)
1654     goto syntax;
1655
1656   if (head == NULL)
1657     {
1658       gfc_error ("Statement label list in GOTO at %C cannot be empty");
1659       goto syntax;
1660     }
1661
1662   /* Get the rest of the statement.  */
1663   gfc_match_char (',');
1664
1665   if (gfc_match (" %e%t", &expr) != MATCH_YES)
1666     goto syntax;
1667
1668   /* At this point, a computed GOTO has been fully matched and an
1669      equivalent SELECT statement constructed.  */
1670
1671   new_st.op = EXEC_SELECT;
1672   new_st.expr = NULL;
1673
1674   /* Hack: For a "real" SELECT, the expression is in expr. We put
1675      it in expr2 so we can distinguish then and produce the correct
1676      diagnostics.  */
1677   new_st.expr2 = expr;
1678   new_st.block = head;
1679   return MATCH_YES;
1680
1681 syntax:
1682   gfc_syntax_error (ST_GOTO);
1683 cleanup:
1684   gfc_free_statements (head);
1685   return MATCH_ERROR;
1686 }
1687
1688
1689 /* Frees a list of gfc_alloc structures.  */
1690
1691 void
1692 gfc_free_alloc_list (gfc_alloc * p)
1693 {
1694   gfc_alloc *q;
1695
1696   for (; p; p = q)
1697     {
1698       q = p->next;
1699       gfc_free_expr (p->expr);
1700       gfc_free (p);
1701     }
1702 }
1703
1704
1705 /* Match an ALLOCATE statement.  */
1706
1707 match
1708 gfc_match_allocate (void)
1709 {
1710   gfc_alloc *head, *tail;
1711   gfc_expr *stat;
1712   match m;
1713
1714   head = tail = NULL;
1715   stat = NULL;
1716
1717   if (gfc_match_char ('(') != MATCH_YES)
1718     goto syntax;
1719
1720   for (;;)
1721     {
1722       if (head == NULL)
1723         head = tail = gfc_get_alloc ();
1724       else
1725         {
1726           tail->next = gfc_get_alloc ();
1727           tail = tail->next;
1728         }
1729
1730       m = gfc_match_variable (&tail->expr, 0);
1731       if (m == MATCH_NO)
1732         goto syntax;
1733       if (m == MATCH_ERROR)
1734         goto cleanup;
1735
1736       if (gfc_check_do_variable (tail->expr->symtree))
1737         goto cleanup;
1738
1739       if (gfc_pure (NULL)
1740           && gfc_impure_variable (tail->expr->symtree->n.sym))
1741         {
1742           gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1743                      "PURE procedure");
1744           goto cleanup;
1745         }
1746
1747       if (gfc_match_char (',') != MATCH_YES)
1748         break;
1749
1750       m = gfc_match (" stat = %v", &stat);
1751       if (m == MATCH_ERROR)
1752         goto cleanup;
1753       if (m == MATCH_YES)
1754         break;
1755     }
1756
1757   if (stat != NULL)
1758     {
1759       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1760         {
1761           gfc_error
1762             ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1763              "INTENT(IN)", stat->symtree->n.sym->name);
1764           goto cleanup;
1765         }
1766
1767       if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
1768         {
1769           gfc_error
1770             ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1771              "procedure");
1772           goto cleanup;
1773         }
1774
1775       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1776         {
1777           gfc_error("STAT expression at %C must be a variable");
1778           goto cleanup;
1779         }
1780
1781       gfc_check_do_variable(stat->symtree);
1782     }
1783
1784   if (gfc_match (" )%t") != MATCH_YES)
1785     goto syntax;
1786
1787   new_st.op = EXEC_ALLOCATE;
1788   new_st.expr = stat;
1789   new_st.ext.alloc_list = head;
1790
1791   return MATCH_YES;
1792
1793 syntax:
1794   gfc_syntax_error (ST_ALLOCATE);
1795
1796 cleanup:
1797   gfc_free_expr (stat);
1798   gfc_free_alloc_list (head);
1799   return MATCH_ERROR;
1800 }
1801
1802
1803 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1804    a set of pointer assignments to intrinsic NULL().  */
1805
1806 match
1807 gfc_match_nullify (void)
1808 {
1809   gfc_code *tail;
1810   gfc_expr *e, *p;
1811   match m;
1812
1813   tail = NULL;
1814
1815   if (gfc_match_char ('(') != MATCH_YES)
1816     goto syntax;
1817
1818   for (;;)
1819     {
1820       m = gfc_match_variable (&p, 0);
1821       if (m == MATCH_ERROR)
1822         goto cleanup;
1823       if (m == MATCH_NO)
1824         goto syntax;
1825
1826       if (gfc_check_do_variable(p->symtree))
1827         goto cleanup;
1828
1829       if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
1830         {
1831           gfc_error
1832             ("Illegal variable in NULLIFY at %C for a PURE procedure");
1833           goto cleanup;
1834         }
1835
1836       /* build ' => NULL() ' */
1837       e = gfc_get_expr ();
1838       e->where = gfc_current_locus;
1839       e->expr_type = EXPR_NULL;
1840       e->ts.type = BT_UNKNOWN;
1841
1842       /* Chain to list */
1843       if (tail == NULL)
1844         tail = &new_st;
1845       else
1846         {
1847           tail->next = gfc_get_code ();
1848           tail = tail->next;
1849         }
1850
1851       tail->op = EXEC_POINTER_ASSIGN;
1852       tail->expr = p;
1853       tail->expr2 = e;
1854
1855       if (gfc_match (" )%t") == MATCH_YES)
1856         break;
1857       if (gfc_match_char (',') != MATCH_YES)
1858         goto syntax;
1859     }
1860
1861   return MATCH_YES;
1862
1863 syntax:
1864   gfc_syntax_error (ST_NULLIFY);
1865
1866 cleanup:
1867   gfc_free_statements (tail);
1868   return MATCH_ERROR;
1869 }
1870
1871
1872 /* Match a DEALLOCATE statement.  */
1873
1874 match
1875 gfc_match_deallocate (void)
1876 {
1877   gfc_alloc *head, *tail;
1878   gfc_expr *stat;
1879   match m;
1880
1881   head = tail = NULL;
1882   stat = NULL;
1883
1884   if (gfc_match_char ('(') != MATCH_YES)
1885     goto syntax;
1886
1887   for (;;)
1888     {
1889       if (head == NULL)
1890         head = tail = gfc_get_alloc ();
1891       else
1892         {
1893           tail->next = gfc_get_alloc ();
1894           tail = tail->next;
1895         }
1896
1897       m = gfc_match_variable (&tail->expr, 0);
1898       if (m == MATCH_ERROR)
1899         goto cleanup;
1900       if (m == MATCH_NO)
1901         goto syntax;
1902
1903       if (gfc_check_do_variable (tail->expr->symtree))
1904         goto cleanup;
1905
1906       if (gfc_pure (NULL)
1907           && gfc_impure_variable (tail->expr->symtree->n.sym))
1908         {
1909           gfc_error
1910             ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
1911              "procedure");
1912           goto cleanup;
1913         }
1914
1915       if (gfc_match_char (',') != MATCH_YES)
1916         break;
1917
1918       m = gfc_match (" stat = %v", &stat);
1919       if (m == MATCH_ERROR)
1920         goto cleanup;
1921       if (m == MATCH_YES)
1922         break;
1923     }
1924
1925   if (stat != NULL)
1926     {
1927       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1928         {
1929           gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
1930                      "cannot be INTENT(IN)", stat->symtree->n.sym->name);
1931           goto cleanup;
1932         }
1933
1934       if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
1935         {
1936           gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
1937                      "for a PURE procedure");
1938           goto cleanup;
1939         }
1940
1941       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1942         {
1943           gfc_error("STAT expression at %C must be a variable");
1944           goto cleanup;
1945         }
1946
1947       gfc_check_do_variable(stat->symtree);
1948     }
1949
1950   if (gfc_match (" )%t") != MATCH_YES)
1951     goto syntax;
1952
1953   new_st.op = EXEC_DEALLOCATE;
1954   new_st.expr = stat;
1955   new_st.ext.alloc_list = head;
1956
1957   return MATCH_YES;
1958
1959 syntax:
1960   gfc_syntax_error (ST_DEALLOCATE);
1961
1962 cleanup:
1963   gfc_free_expr (stat);
1964   gfc_free_alloc_list (head);
1965   return MATCH_ERROR;
1966 }
1967
1968
1969 /* Match a RETURN statement.  */
1970
1971 match
1972 gfc_match_return (void)
1973 {
1974   gfc_expr *e;
1975   match m;
1976   gfc_compile_state s;
1977
1978   gfc_enclosing_unit (&s);
1979   if (s == COMP_PROGRAM
1980       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
1981                          "main program at %C") == FAILURE)
1982       return MATCH_ERROR;
1983
1984   e = NULL;
1985   if (gfc_match_eos () == MATCH_YES)
1986     goto done;
1987
1988   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
1989     {
1990       gfc_error ("Alternate RETURN statement at %C is only allowed within "
1991                  "a SUBROUTINE");
1992       goto cleanup;
1993     }
1994
1995   m = gfc_match ("% %e%t", &e);
1996   if (m == MATCH_YES)
1997     goto done;
1998   if (m == MATCH_ERROR)
1999     goto cleanup;
2000
2001   gfc_syntax_error (ST_RETURN);
2002
2003 cleanup:
2004   gfc_free_expr (e);
2005   return MATCH_ERROR;
2006
2007 done:
2008   new_st.op = EXEC_RETURN;
2009   new_st.expr = e;
2010
2011   return MATCH_YES;
2012 }
2013
2014
2015 /* Match a CALL statement.  The tricky part here are possible
2016    alternate return specifiers.  We handle these by having all
2017    "subroutines" actually return an integer via a register that gives
2018    the return number.  If the call specifies alternate returns, we
2019    generate code for a SELECT statement whose case clauses contain
2020    GOTOs to the various labels.  */
2021
2022 match
2023 gfc_match_call (void)
2024 {
2025   char name[GFC_MAX_SYMBOL_LEN + 1];
2026   gfc_actual_arglist *a, *arglist;
2027   gfc_case *new_case;
2028   gfc_symbol *sym;
2029   gfc_symtree *st;
2030   gfc_code *c;
2031   match m;
2032   int i;
2033
2034   arglist = NULL;
2035
2036   m = gfc_match ("% %n", name);
2037   if (m == MATCH_NO)
2038     goto syntax;
2039   if (m != MATCH_YES)
2040     return m;
2041
2042   if (gfc_get_ha_sym_tree (name, &st))
2043     return MATCH_ERROR;
2044
2045   sym = st->n.sym;
2046   gfc_set_sym_referenced (sym);
2047
2048   if (!sym->attr.generic
2049       && !sym->attr.subroutine
2050       && gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2051     return MATCH_ERROR;
2052
2053   if (gfc_match_eos () != MATCH_YES)
2054     {
2055       m = gfc_match_actual_arglist (1, &arglist);
2056       if (m == MATCH_NO)
2057         goto syntax;
2058       if (m == MATCH_ERROR)
2059         goto cleanup;
2060
2061       if (gfc_match_eos () != MATCH_YES)
2062         goto syntax;
2063     }
2064
2065   /* If any alternate return labels were found, construct a SELECT
2066      statement that will jump to the right place.  */
2067
2068   i = 0;
2069   for (a = arglist; a; a = a->next)
2070     if (a->expr == NULL)
2071         i = 1;
2072
2073   if (i)
2074     {
2075       gfc_symtree *select_st;
2076       gfc_symbol *select_sym;
2077       char name[GFC_MAX_SYMBOL_LEN + 1];
2078
2079       new_st.next = c = gfc_get_code ();
2080       c->op = EXEC_SELECT;
2081       sprintf (name, "_result_%s",sym->name);
2082       gfc_get_ha_sym_tree (name, &select_st);  /* Can't fail */
2083
2084       select_sym = select_st->n.sym;
2085       select_sym->ts.type = BT_INTEGER;
2086       select_sym->ts.kind = gfc_default_integer_kind;
2087       gfc_set_sym_referenced (select_sym);
2088       c->expr = gfc_get_expr ();
2089       c->expr->expr_type = EXPR_VARIABLE;
2090       c->expr->symtree = select_st;
2091       c->expr->ts = select_sym->ts;
2092       c->expr->where = gfc_current_locus;
2093
2094       i = 0;
2095       for (a = arglist; a; a = a->next)
2096         {
2097           if (a->expr != NULL)
2098             continue;
2099
2100           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2101             continue;
2102
2103           i++;
2104
2105           c->block = gfc_get_code ();
2106           c = c->block;
2107           c->op = EXEC_SELECT;
2108
2109           new_case = gfc_get_case ();
2110           new_case->high = new_case->low = gfc_int_expr (i);
2111           c->ext.case_list = new_case;
2112
2113           c->next = gfc_get_code ();
2114           c->next->op = EXEC_GOTO;
2115           c->next->label = a->label;
2116         }
2117     }
2118
2119   new_st.op = EXEC_CALL;
2120   new_st.symtree = st;
2121   new_st.ext.actual = arglist;
2122
2123   return MATCH_YES;
2124
2125 syntax:
2126   gfc_syntax_error (ST_CALL);
2127
2128 cleanup:
2129   gfc_free_actual_arglist (arglist);
2130   return MATCH_ERROR;
2131 }
2132
2133
2134 /* Given a name, return a pointer to the common head structure,
2135    creating it if it does not exist. If FROM_MODULE is nonzero, we
2136    mangle the name so that it doesn't interfere with commons defined
2137    in the using namespace.
2138    TODO: Add to global symbol tree.  */
2139
2140 gfc_common_head *
2141 gfc_get_common (const char *name, int from_module)
2142 {
2143   gfc_symtree *st;
2144   static int serial = 0;
2145   char mangled_name[GFC_MAX_SYMBOL_LEN+1];
2146
2147   if (from_module)
2148     {
2149       /* A use associated common block is only needed to correctly layout
2150          the variables it contains.  */
2151       snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2152       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2153     }
2154   else
2155     {
2156       st = gfc_find_symtree (gfc_current_ns->common_root, name);
2157
2158       if (st == NULL)
2159         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2160     }
2161
2162   if (st->n.common == NULL)
2163     {
2164       st->n.common = gfc_get_common_head ();
2165       st->n.common->where = gfc_current_locus;
2166       strcpy (st->n.common->name, name);
2167     }
2168
2169   return st->n.common;
2170 }
2171
2172
2173 /* Match a common block name.  */
2174
2175 static match
2176 match_common_name (char *name)
2177 {
2178   match m;
2179
2180   if (gfc_match_char ('/') == MATCH_NO)
2181     {
2182       name[0] = '\0';
2183       return MATCH_YES;
2184     }
2185
2186   if (gfc_match_char ('/') == MATCH_YES)
2187     {
2188       name[0] = '\0';
2189       return MATCH_YES;
2190     }
2191
2192   m = gfc_match_name (name);
2193
2194   if (m == MATCH_ERROR)
2195     return MATCH_ERROR;
2196   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2197     return MATCH_YES;
2198
2199   gfc_error ("Syntax error in common block name at %C");
2200   return MATCH_ERROR;
2201 }
2202
2203
2204 /* Match a COMMON statement.  */
2205
2206 match
2207 gfc_match_common (void)
2208 {
2209   gfc_symbol *sym, **head, *tail, *old_blank_common;
2210   char name[GFC_MAX_SYMBOL_LEN+1];
2211   gfc_common_head *t;
2212   gfc_array_spec *as;
2213   match m;
2214
2215   old_blank_common = gfc_current_ns->blank_common.head;
2216   if (old_blank_common)
2217     {
2218       while (old_blank_common->common_next)
2219         old_blank_common = old_blank_common->common_next;
2220     }
2221
2222   as = NULL;
2223
2224   if (gfc_match_eos () == MATCH_YES)
2225     goto syntax;
2226
2227   for (;;)
2228     {
2229       m = match_common_name (name);
2230       if (m == MATCH_ERROR)
2231         goto cleanup;
2232
2233       if (name[0] == '\0')
2234         {
2235           t = &gfc_current_ns->blank_common;
2236           if (t->head == NULL)
2237             t->where = gfc_current_locus;
2238           head = &t->head;
2239         }
2240       else
2241         {
2242           t = gfc_get_common (name, 0);
2243           head = &t->head;
2244         }
2245
2246       if (*head == NULL)
2247         tail = NULL;
2248       else
2249         {
2250           tail = *head;
2251           while (tail->common_next)
2252             tail = tail->common_next;
2253         }
2254
2255       /* Grab the list of symbols.  */
2256       if (gfc_match_eos () == MATCH_YES)
2257         goto done;
2258
2259       for (;;)
2260         {
2261           m = gfc_match_symbol (&sym, 0);
2262           if (m == MATCH_ERROR)
2263             goto cleanup;
2264           if (m == MATCH_NO)
2265             goto syntax;
2266
2267           if (sym->attr.in_common)
2268             {
2269               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2270                          sym->name);
2271               goto cleanup;
2272             }
2273
2274           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2275             goto cleanup;
2276
2277           if (sym->value != NULL
2278               && (name[0] == '\0' || !sym->attr.data))
2279             {
2280               if (name[0] == '\0')
2281                 gfc_error ("Previously initialized symbol '%s' in "
2282                            "blank COMMON block at %C", sym->name);
2283               else
2284                 gfc_error ("Previously initialized symbol '%s' in "
2285                            "COMMON block '%s' at %C", sym->name, name);
2286               goto cleanup;
2287             }
2288
2289           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2290             goto cleanup;
2291
2292           /* Derived type names must have the SEQUENCE attribute.  */
2293           if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2294             {
2295               gfc_error
2296                 ("Derived type variable in COMMON at %C does not have the "
2297                  "SEQUENCE attribute");
2298               goto cleanup;
2299             }
2300
2301           if (tail != NULL)
2302             tail->common_next = sym;
2303           else
2304             *head = sym;
2305
2306           tail = sym;
2307
2308           /* Deal with an optional array specification after the
2309              symbol name.  */
2310           m = gfc_match_array_spec (&as);
2311           if (m == MATCH_ERROR)
2312             goto cleanup;
2313
2314           if (m == MATCH_YES)
2315             {
2316               if (as->type != AS_EXPLICIT)
2317                 {
2318                   gfc_error
2319                     ("Array specification for symbol '%s' in COMMON at %C "
2320                      "must be explicit", sym->name);
2321                   goto cleanup;
2322                 }
2323
2324               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2325                 goto cleanup;
2326
2327               if (sym->attr.pointer)
2328                 {
2329                   gfc_error
2330                     ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2331                      sym->name);
2332                   goto cleanup;
2333                 }
2334
2335               sym->as = as;
2336               as = NULL;
2337             }
2338
2339           gfc_gobble_whitespace ();
2340           if (gfc_match_eos () == MATCH_YES)
2341             goto done;
2342           if (gfc_peek_char () == '/')
2343             break;
2344           if (gfc_match_char (',') != MATCH_YES)
2345             goto syntax;
2346           gfc_gobble_whitespace ();
2347           if (gfc_peek_char () == '/')
2348             break;
2349         }
2350     }
2351
2352 done:
2353   return MATCH_YES;
2354
2355 syntax:
2356   gfc_syntax_error (ST_COMMON);
2357
2358 cleanup:
2359   if (old_blank_common)
2360     old_blank_common->common_next = NULL;
2361   else
2362     gfc_current_ns->blank_common.head = NULL;
2363   gfc_free_array_spec (as);
2364   return MATCH_ERROR;
2365 }
2366
2367
2368 /* Match a BLOCK DATA program unit.  */
2369
2370 match
2371 gfc_match_block_data (void)
2372 {
2373   char name[GFC_MAX_SYMBOL_LEN + 1];
2374   gfc_symbol *sym;
2375   match m;
2376
2377   if (gfc_match_eos () == MATCH_YES)
2378     {
2379       gfc_new_block = NULL;
2380       return MATCH_YES;
2381     }
2382
2383   m = gfc_match ("% %n%t", name);
2384   if (m != MATCH_YES)
2385     return MATCH_ERROR;
2386
2387   if (gfc_get_symbol (name, NULL, &sym))
2388     return MATCH_ERROR;
2389
2390   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2391     return MATCH_ERROR;
2392
2393   gfc_new_block = sym;
2394
2395   return MATCH_YES;
2396 }
2397
2398
2399 /* Free a namelist structure.  */
2400
2401 void
2402 gfc_free_namelist (gfc_namelist * name)
2403 {
2404   gfc_namelist *n;
2405
2406   for (; name; name = n)
2407     {
2408       n = name->next;
2409       gfc_free (name);
2410     }
2411 }
2412
2413
2414 /* Match a NAMELIST statement.  */
2415
2416 match
2417 gfc_match_namelist (void)
2418 {
2419   gfc_symbol *group_name, *sym;
2420   gfc_namelist *nl;
2421   match m, m2;
2422
2423   m = gfc_match (" / %s /", &group_name);
2424   if (m == MATCH_NO)
2425     goto syntax;
2426   if (m == MATCH_ERROR)
2427     goto error;
2428
2429   for (;;)
2430     {
2431       if (group_name->ts.type != BT_UNKNOWN)
2432         {
2433           gfc_error
2434             ("Namelist group name '%s' at %C already has a basic type "
2435              "of %s", group_name->name, gfc_typename (&group_name->ts));
2436           return MATCH_ERROR;
2437         }
2438
2439       if (group_name->attr.flavor != FL_NAMELIST
2440           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2441                              group_name->name, NULL) == FAILURE)
2442         return MATCH_ERROR;
2443
2444       for (;;)
2445         {
2446           m = gfc_match_symbol (&sym, 1);
2447           if (m == MATCH_NO)
2448             goto syntax;
2449           if (m == MATCH_ERROR)
2450             goto error;
2451
2452           if (sym->attr.in_namelist == 0
2453               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
2454             goto error;
2455
2456           nl = gfc_get_namelist ();
2457           nl->sym = sym;
2458
2459           if (group_name->namelist == NULL)
2460             group_name->namelist = group_name->namelist_tail = nl;
2461           else
2462             {
2463               group_name->namelist_tail->next = nl;
2464               group_name->namelist_tail = nl;
2465             }
2466
2467           if (gfc_match_eos () == MATCH_YES)
2468             goto done;
2469
2470           m = gfc_match_char (',');
2471
2472           if (gfc_match_char ('/') == MATCH_YES)
2473             {
2474               m2 = gfc_match (" %s /", &group_name);
2475               if (m2 == MATCH_YES)
2476                 break;
2477               if (m2 == MATCH_ERROR)
2478                 goto error;
2479               goto syntax;
2480             }
2481
2482           if (m != MATCH_YES)
2483             goto syntax;
2484         }
2485     }
2486
2487 done:
2488   return MATCH_YES;
2489
2490 syntax:
2491   gfc_syntax_error (ST_NAMELIST);
2492
2493 error:
2494   return MATCH_ERROR;
2495 }
2496
2497
2498 /* Match a MODULE statement.  */
2499
2500 match
2501 gfc_match_module (void)
2502 {
2503   match m;
2504
2505   m = gfc_match (" %s%t", &gfc_new_block);
2506   if (m != MATCH_YES)
2507     return m;
2508
2509   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2510                       gfc_new_block->name, NULL) == FAILURE)
2511     return MATCH_ERROR;
2512
2513   return MATCH_YES;
2514 }
2515
2516
2517 /* Free equivalence sets and lists.  Recursively is the easiest way to
2518    do this.  */
2519
2520 void
2521 gfc_free_equiv (gfc_equiv * eq)
2522 {
2523
2524   if (eq == NULL)
2525     return;
2526
2527   gfc_free_equiv (eq->eq);
2528   gfc_free_equiv (eq->next);
2529
2530   gfc_free_expr (eq->expr);
2531   gfc_free (eq);
2532 }
2533
2534
2535 /* Match an EQUIVALENCE statement.  */
2536
2537 match
2538 gfc_match_equivalence (void)
2539 {
2540   gfc_equiv *eq, *set, *tail;
2541   gfc_ref *ref;
2542   match m;
2543
2544   tail = NULL;
2545
2546   for (;;)
2547     {
2548       eq = gfc_get_equiv ();
2549       if (tail == NULL)
2550         tail = eq;
2551
2552       eq->next = gfc_current_ns->equiv;
2553       gfc_current_ns->equiv = eq;
2554
2555       if (gfc_match_char ('(') != MATCH_YES)
2556         goto syntax;
2557
2558       set = eq;
2559
2560       for (;;)
2561         {
2562           m = gfc_match_variable (&set->expr, 1);
2563           if (m == MATCH_ERROR)
2564             goto cleanup;
2565           if (m == MATCH_NO)
2566             goto syntax;
2567
2568           for (ref = set->expr->ref; ref; ref = ref->next)
2569             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2570               {
2571                 gfc_error
2572                   ("Array reference in EQUIVALENCE at %C cannot be an "
2573                    "array section");
2574                 goto cleanup;
2575               }
2576
2577           if (gfc_match_char (')') == MATCH_YES)
2578             break;
2579           if (gfc_match_char (',') != MATCH_YES)
2580             goto syntax;
2581
2582           set->eq = gfc_get_equiv ();
2583           set = set->eq;
2584         }
2585
2586       if (gfc_match_eos () == MATCH_YES)
2587         break;
2588       if (gfc_match_char (',') != MATCH_YES)
2589         goto syntax;
2590     }
2591
2592   return MATCH_YES;
2593
2594 syntax:
2595   gfc_syntax_error (ST_EQUIVALENCE);
2596
2597 cleanup:
2598   eq = tail->next;
2599   tail->next = NULL;
2600
2601   gfc_free_equiv (gfc_current_ns->equiv);
2602   gfc_current_ns->equiv = eq;
2603
2604   return MATCH_ERROR;
2605 }
2606
2607
2608 /* Match a statement function declaration.  It is so easy to match
2609    non-statement function statements with a MATCH_ERROR as opposed to
2610    MATCH_NO that we suppress error message in most cases.  */
2611
2612 match
2613 gfc_match_st_function (void)
2614 {
2615   gfc_error_buf old_error;
2616   gfc_symbol *sym;
2617   gfc_expr *expr;
2618   match m;
2619
2620   m = gfc_match_symbol (&sym, 0);
2621   if (m != MATCH_YES)
2622     return m;
2623
2624   gfc_push_error (&old_error);
2625
2626   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
2627                          sym->name, NULL) == FAILURE)
2628     goto undo_error;
2629
2630   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2631     goto undo_error;
2632
2633   m = gfc_match (" = %e%t", &expr);
2634   if (m == MATCH_NO)
2635     goto undo_error;
2636   if (m == MATCH_ERROR)
2637     return m;
2638
2639   sym->value = expr;
2640
2641   return MATCH_YES;
2642
2643 undo_error:
2644   gfc_pop_error (&old_error);
2645   return MATCH_NO;
2646 }
2647
2648
2649 /***************** SELECT CASE subroutines ******************/
2650
2651 /* Free a single case structure.  */
2652
2653 static void
2654 free_case (gfc_case * p)
2655 {
2656   if (p->low == p->high)
2657     p->high = NULL;
2658   gfc_free_expr (p->low);
2659   gfc_free_expr (p->high);
2660   gfc_free (p);
2661 }
2662
2663
2664 /* Free a list of case structures.  */
2665
2666 void
2667 gfc_free_case_list (gfc_case * p)
2668 {
2669   gfc_case *q;
2670
2671   for (; p; p = q)
2672     {
2673       q = p->next;
2674       free_case (p);
2675     }
2676 }
2677
2678
2679 /* Match a single case selector.  */
2680
2681 static match
2682 match_case_selector (gfc_case ** cp)
2683 {
2684   gfc_case *c;
2685   match m;
2686
2687   c = gfc_get_case ();
2688   c->where = gfc_current_locus;
2689
2690   if (gfc_match_char (':') == MATCH_YES)
2691     {
2692       m = gfc_match_init_expr (&c->high);
2693       if (m == MATCH_NO)
2694         goto need_expr;
2695       if (m == MATCH_ERROR)
2696         goto cleanup;
2697     }
2698
2699   else
2700     {
2701       m = gfc_match_init_expr (&c->low);
2702       if (m == MATCH_ERROR)
2703         goto cleanup;
2704       if (m == MATCH_NO)
2705         goto need_expr;
2706
2707       /* If we're not looking at a ':' now, make a range out of a single
2708          target.  Else get the upper bound for the case range.  */
2709       if (gfc_match_char (':') != MATCH_YES)
2710         c->high = c->low;
2711       else
2712         {
2713           m = gfc_match_init_expr (&c->high);
2714           if (m == MATCH_ERROR)
2715             goto cleanup;
2716           /* MATCH_NO is fine.  It's OK if nothing is there!  */
2717         }
2718     }
2719
2720   *cp = c;
2721   return MATCH_YES;
2722
2723 need_expr:
2724   gfc_error ("Expected initialization expression in CASE at %C");
2725
2726 cleanup:
2727   free_case (c);
2728   return MATCH_ERROR;
2729 }
2730
2731
2732 /* Match the end of a case statement.  */
2733
2734 static match
2735 match_case_eos (void)
2736 {
2737   char name[GFC_MAX_SYMBOL_LEN + 1];
2738   match m;
2739
2740   if (gfc_match_eos () == MATCH_YES)
2741     return MATCH_YES;
2742
2743   gfc_gobble_whitespace ();
2744
2745   m = gfc_match_name (name);
2746   if (m != MATCH_YES)
2747     return m;
2748
2749   if (strcmp (name, gfc_current_block ()->name) != 0)
2750     {
2751       gfc_error ("Expected case name of '%s' at %C",
2752                  gfc_current_block ()->name);
2753       return MATCH_ERROR;
2754     }
2755
2756   return gfc_match_eos ();
2757 }
2758
2759
2760 /* Match a SELECT statement.  */
2761
2762 match
2763 gfc_match_select (void)
2764 {
2765   gfc_expr *expr;
2766   match m;
2767
2768   m = gfc_match_label ();
2769   if (m == MATCH_ERROR)
2770     return m;
2771
2772   m = gfc_match (" select case ( %e )%t", &expr);
2773   if (m != MATCH_YES)
2774     return m;
2775
2776   new_st.op = EXEC_SELECT;
2777   new_st.expr = expr;
2778
2779   return MATCH_YES;
2780 }
2781
2782
2783 /* Match a CASE statement.  */
2784
2785 match
2786 gfc_match_case (void)
2787 {
2788   gfc_case *c, *head, *tail;
2789   match m;
2790
2791   head = tail = NULL;
2792
2793   if (gfc_current_state () != COMP_SELECT)
2794     {
2795       gfc_error ("Unexpected CASE statement at %C");
2796       return MATCH_ERROR;
2797     }
2798
2799   if (gfc_match ("% default") == MATCH_YES)
2800     {
2801       m = match_case_eos ();
2802       if (m == MATCH_NO)
2803         goto syntax;
2804       if (m == MATCH_ERROR)
2805         goto cleanup;
2806
2807       new_st.op = EXEC_SELECT;
2808       c = gfc_get_case ();
2809       c->where = gfc_current_locus;
2810       new_st.ext.case_list = c;
2811       return MATCH_YES;
2812     }
2813
2814   if (gfc_match_char ('(') != MATCH_YES)
2815     goto syntax;
2816
2817   for (;;)
2818     {
2819       if (match_case_selector (&c) == MATCH_ERROR)
2820         goto cleanup;
2821
2822       if (head == NULL)
2823         head = c;
2824       else
2825         tail->next = c;
2826
2827       tail = c;
2828
2829       if (gfc_match_char (')') == MATCH_YES)
2830         break;
2831       if (gfc_match_char (',') != MATCH_YES)
2832         goto syntax;
2833     }
2834
2835   m = match_case_eos ();
2836   if (m == MATCH_NO)
2837     goto syntax;
2838   if (m == MATCH_ERROR)
2839     goto cleanup;
2840
2841   new_st.op = EXEC_SELECT;
2842   new_st.ext.case_list = head;
2843
2844   return MATCH_YES;
2845
2846 syntax:
2847   gfc_error ("Syntax error in CASE-specification at %C");
2848
2849 cleanup:
2850   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
2851   return MATCH_ERROR;
2852 }
2853
2854 /********************* WHERE subroutines ********************/
2855
2856 /* Match the rest of a simple WHERE statement that follows an IF statement.
2857  */
2858
2859 static match
2860 match_simple_where (void)
2861 {
2862   gfc_expr *expr;
2863   gfc_code *c;
2864   match m;
2865
2866   m = gfc_match (" ( %e )", &expr);
2867   if (m != MATCH_YES)
2868     return m;
2869
2870   m = gfc_match_assignment ();
2871   if (m == MATCH_NO)
2872     goto syntax;
2873   if (m == MATCH_ERROR)
2874     goto cleanup;
2875
2876   if (gfc_match_eos () != MATCH_YES)
2877     goto syntax;
2878
2879   c = gfc_get_code ();
2880
2881   c->op = EXEC_WHERE;
2882   c->expr = expr;
2883   c->next = gfc_get_code ();
2884
2885   *c->next = new_st;
2886   gfc_clear_new_st ();
2887
2888   new_st.op = EXEC_WHERE;
2889   new_st.block = c;
2890
2891   return MATCH_YES;
2892
2893 syntax:
2894   gfc_syntax_error (ST_WHERE);
2895
2896 cleanup:
2897   gfc_free_expr (expr);
2898   return MATCH_ERROR;
2899 }
2900
2901 /* Match a WHERE statement.  */
2902
2903 match
2904 gfc_match_where (gfc_statement * st)
2905 {
2906   gfc_expr *expr;
2907   match m0, m;
2908   gfc_code *c;
2909
2910   m0 = gfc_match_label ();
2911   if (m0 == MATCH_ERROR)
2912     return m0;
2913
2914   m = gfc_match (" where ( %e )", &expr);
2915   if (m != MATCH_YES)
2916     return m;
2917
2918   if (gfc_match_eos () == MATCH_YES)
2919     {
2920       *st = ST_WHERE_BLOCK;
2921
2922       new_st.op = EXEC_WHERE;
2923       new_st.expr = expr;
2924       return MATCH_YES;
2925     }
2926
2927   m = gfc_match_assignment ();
2928   if (m == MATCH_NO)
2929     gfc_syntax_error (ST_WHERE);
2930
2931   if (m != MATCH_YES)
2932     {
2933       gfc_free_expr (expr);
2934       return MATCH_ERROR;
2935     }
2936
2937   /* We've got a simple WHERE statement.  */
2938   *st = ST_WHERE;
2939   c = gfc_get_code ();
2940
2941   c->op = EXEC_WHERE;
2942   c->expr = expr;
2943   c->next = gfc_get_code ();
2944
2945   *c->next = new_st;
2946   gfc_clear_new_st ();
2947
2948   new_st.op = EXEC_WHERE;
2949   new_st.block = c;
2950
2951   return MATCH_YES;
2952 }
2953
2954
2955 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
2956    new_st if successful.  */
2957
2958 match
2959 gfc_match_elsewhere (void)
2960 {
2961   char name[GFC_MAX_SYMBOL_LEN + 1];
2962   gfc_expr *expr;
2963   match m;
2964
2965   if (gfc_current_state () != COMP_WHERE)
2966     {
2967       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
2968       return MATCH_ERROR;
2969     }
2970
2971   expr = NULL;
2972
2973   if (gfc_match_char ('(') == MATCH_YES)
2974     {
2975       m = gfc_match_expr (&expr);
2976       if (m == MATCH_NO)
2977         goto syntax;
2978       if (m == MATCH_ERROR)
2979         return MATCH_ERROR;
2980
2981       if (gfc_match_char (')') != MATCH_YES)
2982         goto syntax;
2983     }
2984
2985   if (gfc_match_eos () != MATCH_YES)
2986     {                           /* Better be a name at this point */
2987       m = gfc_match_name (name);
2988       if (m == MATCH_NO)
2989         goto syntax;
2990       if (m == MATCH_ERROR)
2991         goto cleanup;
2992
2993       if (gfc_match_eos () != MATCH_YES)
2994         goto syntax;
2995
2996       if (strcmp (name, gfc_current_block ()->name) != 0)
2997         {
2998           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
2999                      name, gfc_current_block ()->name);
3000           goto cleanup;
3001         }
3002     }
3003
3004   new_st.op = EXEC_WHERE;
3005   new_st.expr = expr;
3006   return MATCH_YES;
3007
3008 syntax:
3009   gfc_syntax_error (ST_ELSEWHERE);
3010
3011 cleanup:
3012   gfc_free_expr (expr);
3013   return MATCH_ERROR;
3014 }
3015
3016
3017 /******************** FORALL subroutines ********************/
3018
3019 /* Free a list of FORALL iterators.  */
3020
3021 void
3022 gfc_free_forall_iterator (gfc_forall_iterator * iter)
3023 {
3024   gfc_forall_iterator *next;
3025
3026   while (iter)
3027     {
3028       next = iter->next;
3029
3030       gfc_free_expr (iter->var);
3031       gfc_free_expr (iter->start);
3032       gfc_free_expr (iter->end);
3033       gfc_free_expr (iter->stride);
3034
3035       gfc_free (iter);
3036       iter = next;
3037     }
3038 }
3039
3040
3041 /* Match an iterator as part of a FORALL statement.  The format is:
3042
3043      <var> = <start>:<end>[:<stride>][, <scalar mask>]  */
3044
3045 static match
3046 match_forall_iterator (gfc_forall_iterator ** result)
3047 {
3048   gfc_forall_iterator *iter;
3049   locus where;
3050   match m;
3051
3052   where = gfc_current_locus;
3053   iter = gfc_getmem (sizeof (gfc_forall_iterator));
3054
3055   m = gfc_match_variable (&iter->var, 0);
3056   if (m != MATCH_YES)
3057     goto cleanup;
3058
3059   if (gfc_match_char ('=') != MATCH_YES)
3060     {
3061       m = MATCH_NO;
3062       goto cleanup;
3063     }
3064
3065   m = gfc_match_expr (&iter->start);
3066   if (m == MATCH_NO)
3067     goto syntax;
3068   if (m == MATCH_ERROR)
3069     goto cleanup;
3070
3071   if (gfc_match_char (':') != MATCH_YES)
3072     goto syntax;
3073
3074   m = gfc_match_expr (&iter->end);
3075   if (m == MATCH_NO)
3076     goto syntax;
3077   if (m == MATCH_ERROR)
3078     goto cleanup;
3079
3080   if (gfc_match_char (':') == MATCH_NO)
3081     iter->stride = gfc_int_expr (1);
3082   else
3083     {
3084       m = gfc_match_expr (&iter->stride);
3085       if (m == MATCH_NO)
3086         goto syntax;
3087       if (m == MATCH_ERROR)
3088         goto cleanup;
3089     }
3090
3091   *result = iter;
3092   return MATCH_YES;
3093
3094 syntax:
3095   gfc_error ("Syntax error in FORALL iterator at %C");
3096   m = MATCH_ERROR;
3097
3098 cleanup:
3099   gfc_current_locus = where;
3100   gfc_free_forall_iterator (iter);
3101   return m;
3102 }
3103
3104
3105 /* Match the header of a FORALL statement.  */
3106
3107 static match
3108 match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
3109 {
3110   gfc_forall_iterator *head, *tail, *new;
3111   match m;
3112
3113   gfc_gobble_whitespace ();
3114
3115   head = tail = NULL;
3116   *mask = NULL;
3117
3118   if (gfc_match_char ('(') != MATCH_YES)
3119     return MATCH_NO;
3120
3121   m = match_forall_iterator (&new);
3122   if (m == MATCH_ERROR)
3123     goto cleanup;
3124   if (m == MATCH_NO)
3125     goto syntax;
3126
3127   head = tail = new;
3128
3129   for (;;)
3130     {
3131       if (gfc_match_char (',') != MATCH_YES)
3132         break;
3133
3134       m = match_forall_iterator (&new);
3135       if (m == MATCH_ERROR)
3136         goto cleanup;
3137       if (m == MATCH_YES)
3138         {
3139           tail->next = new;
3140           tail = new;
3141           continue;
3142         }
3143
3144       /* Have to have a mask expression */
3145
3146       m = gfc_match_expr (mask);
3147       if (m == MATCH_NO)
3148         goto syntax;
3149       if (m == MATCH_ERROR)
3150         goto cleanup;
3151
3152       break;
3153     }
3154
3155   if (gfc_match_char (')') == MATCH_NO)
3156     goto syntax;
3157
3158   *phead = head;
3159   return MATCH_YES;
3160
3161 syntax:
3162   gfc_syntax_error (ST_FORALL);
3163
3164 cleanup:
3165   gfc_free_expr (*mask);
3166   gfc_free_forall_iterator (head);
3167
3168   return MATCH_ERROR;
3169 }
3170
3171 /* Match the rest of a simple FORALL statement that follows an IF statement.
3172  */
3173
3174 static match
3175 match_simple_forall (void)
3176 {
3177   gfc_forall_iterator *head;
3178   gfc_expr *mask;
3179   gfc_code *c;
3180   match m;
3181
3182   mask = NULL;
3183   head = NULL;
3184   c = NULL;
3185
3186   m = match_forall_header (&head, &mask);
3187
3188   if (m == MATCH_NO)
3189     goto syntax;
3190   if (m != MATCH_YES)
3191     goto cleanup;
3192
3193   m = gfc_match_assignment ();
3194
3195   if (m == MATCH_ERROR)
3196     goto cleanup;
3197   if (m == MATCH_NO)
3198     {
3199       m = gfc_match_pointer_assignment ();
3200       if (m == MATCH_ERROR)
3201         goto cleanup;
3202       if (m == MATCH_NO)
3203         goto syntax;
3204     }
3205
3206   c = gfc_get_code ();
3207   *c = new_st;
3208   c->loc = gfc_current_locus;
3209
3210   if (gfc_match_eos () != MATCH_YES)
3211     goto syntax;
3212
3213   gfc_clear_new_st ();
3214   new_st.op = EXEC_FORALL;
3215   new_st.expr = mask;
3216   new_st.ext.forall_iterator = head;
3217   new_st.block = gfc_get_code ();
3218
3219   new_st.block->op = EXEC_FORALL;
3220   new_st.block->next = c;
3221
3222   return MATCH_YES;
3223
3224 syntax:
3225   gfc_syntax_error (ST_FORALL);
3226
3227 cleanup:
3228   gfc_free_forall_iterator (head);
3229   gfc_free_expr (mask);
3230
3231   return MATCH_ERROR;
3232 }
3233
3234
3235 /* Match a FORALL statement.  */
3236
3237 match
3238 gfc_match_forall (gfc_statement * st)
3239 {
3240   gfc_forall_iterator *head;
3241   gfc_expr *mask;
3242   gfc_code *c;
3243   match m0, m;
3244
3245   head = NULL;
3246   mask = NULL;
3247   c = NULL;
3248
3249   m0 = gfc_match_label ();
3250   if (m0 == MATCH_ERROR)
3251     return MATCH_ERROR;
3252
3253   m = gfc_match (" forall");
3254   if (m != MATCH_YES)
3255     return m;
3256
3257   m = match_forall_header (&head, &mask);
3258   if (m == MATCH_ERROR)
3259     goto cleanup;
3260   if (m == MATCH_NO)
3261     goto syntax;
3262
3263   if (gfc_match_eos () == MATCH_YES)
3264     {
3265       *st = ST_FORALL_BLOCK;
3266
3267       new_st.op = EXEC_FORALL;
3268       new_st.expr = mask;
3269       new_st.ext.forall_iterator = head;
3270
3271       return MATCH_YES;
3272     }
3273
3274   m = gfc_match_assignment ();
3275   if (m == MATCH_ERROR)
3276     goto cleanup;
3277   if (m == MATCH_NO)
3278     {
3279       m = gfc_match_pointer_assignment ();
3280       if (m == MATCH_ERROR)
3281         goto cleanup;
3282       if (m == MATCH_NO)
3283         goto syntax;
3284     }
3285
3286   c = gfc_get_code ();
3287   *c = new_st;
3288
3289   if (gfc_match_eos () != MATCH_YES)
3290     goto syntax;
3291
3292   gfc_clear_new_st ();
3293   new_st.op = EXEC_FORALL;
3294   new_st.expr = mask;
3295   new_st.ext.forall_iterator = head;
3296   new_st.block = gfc_get_code ();
3297
3298   new_st.block->op = EXEC_FORALL;
3299   new_st.block->next = c;
3300
3301   *st = ST_FORALL;
3302   return MATCH_YES;
3303
3304 syntax:
3305   gfc_syntax_error (ST_FORALL);
3306
3307 cleanup:
3308   gfc_free_forall_iterator (head);
3309   gfc_free_expr (mask);
3310   gfc_free_statements (c);
3311   return MATCH_NO;
3312 }