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
1987   gfc_enclosing_unit (&s);
1988   if (s == COMP_PROGRAM
1989       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
1990                          "main program at %C") == FAILURE)
1991       return MATCH_ERROR;
1992
1993   e = NULL;
1994   if (gfc_match_eos () == MATCH_YES)
1995     goto done;
1996
1997   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
1998     {
1999       gfc_error ("Alternate RETURN statement at %C is only allowed within "
2000                  "a SUBROUTINE");
2001       goto cleanup;
2002     }
2003
2004   m = gfc_match ("% %e%t", &e);
2005   if (m == MATCH_YES)
2006     goto done;
2007   if (m == MATCH_ERROR)
2008     goto cleanup;
2009
2010   gfc_syntax_error (ST_RETURN);
2011
2012 cleanup:
2013   gfc_free_expr (e);
2014   return MATCH_ERROR;
2015
2016 done:
2017   new_st.op = EXEC_RETURN;
2018   new_st.expr = e;
2019
2020   return MATCH_YES;
2021 }
2022
2023
2024 /* Match a CALL statement.  The tricky part here are possible
2025    alternate return specifiers.  We handle these by having all
2026    "subroutines" actually return an integer via a register that gives
2027    the return number.  If the call specifies alternate returns, we
2028    generate code for a SELECT statement whose case clauses contain
2029    GOTOs to the various labels.  */
2030
2031 match
2032 gfc_match_call (void)
2033 {
2034   char name[GFC_MAX_SYMBOL_LEN + 1];
2035   gfc_actual_arglist *a, *arglist;
2036   gfc_case *new_case;
2037   gfc_symbol *sym;
2038   gfc_symtree *st;
2039   gfc_code *c;
2040   match m;
2041   int i;
2042
2043   arglist = NULL;
2044
2045   m = gfc_match ("% %n", name);
2046   if (m == MATCH_NO)
2047     goto syntax;
2048   if (m != MATCH_YES)
2049     return m;
2050
2051   if (gfc_get_ha_sym_tree (name, &st))
2052     return MATCH_ERROR;
2053
2054   sym = st->n.sym;
2055   gfc_set_sym_referenced (sym);
2056
2057   if (!sym->attr.generic
2058       && !sym->attr.subroutine
2059       && gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2060     return MATCH_ERROR;
2061
2062   if (gfc_match_eos () != MATCH_YES)
2063     {
2064       m = gfc_match_actual_arglist (1, &arglist);
2065       if (m == MATCH_NO)
2066         goto syntax;
2067       if (m == MATCH_ERROR)
2068         goto cleanup;
2069
2070       if (gfc_match_eos () != MATCH_YES)
2071         goto syntax;
2072     }
2073
2074   /* If any alternate return labels were found, construct a SELECT
2075      statement that will jump to the right place.  */
2076
2077   i = 0;
2078   for (a = arglist; a; a = a->next)
2079     if (a->expr == NULL)
2080         i = 1;
2081
2082   if (i)
2083     {
2084       gfc_symtree *select_st;
2085       gfc_symbol *select_sym;
2086       char name[GFC_MAX_SYMBOL_LEN + 1];
2087
2088       new_st.next = c = gfc_get_code ();
2089       c->op = EXEC_SELECT;
2090       sprintf (name, "_result_%s",sym->name);
2091       gfc_get_ha_sym_tree (name, &select_st);  /* Can't fail */
2092
2093       select_sym = select_st->n.sym;
2094       select_sym->ts.type = BT_INTEGER;
2095       select_sym->ts.kind = gfc_default_integer_kind;
2096       gfc_set_sym_referenced (select_sym);
2097       c->expr = gfc_get_expr ();
2098       c->expr->expr_type = EXPR_VARIABLE;
2099       c->expr->symtree = select_st;
2100       c->expr->ts = select_sym->ts;
2101       c->expr->where = gfc_current_locus;
2102
2103       i = 0;
2104       for (a = arglist; a; a = a->next)
2105         {
2106           if (a->expr != NULL)
2107             continue;
2108
2109           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2110             continue;
2111
2112           i++;
2113
2114           c->block = gfc_get_code ();
2115           c = c->block;
2116           c->op = EXEC_SELECT;
2117
2118           new_case = gfc_get_case ();
2119           new_case->high = new_case->low = gfc_int_expr (i);
2120           c->ext.case_list = new_case;
2121
2122           c->next = gfc_get_code ();
2123           c->next->op = EXEC_GOTO;
2124           c->next->label = a->label;
2125         }
2126     }
2127
2128   new_st.op = EXEC_CALL;
2129   new_st.symtree = st;
2130   new_st.ext.actual = arglist;
2131
2132   return MATCH_YES;
2133
2134 syntax:
2135   gfc_syntax_error (ST_CALL);
2136
2137 cleanup:
2138   gfc_free_actual_arglist (arglist);
2139   return MATCH_ERROR;
2140 }
2141
2142
2143 /* Given a name, return a pointer to the common head structure,
2144    creating it if it does not exist. If FROM_MODULE is nonzero, we
2145    mangle the name so that it doesn't interfere with commons defined
2146    in the using namespace.
2147    TODO: Add to global symbol tree.  */
2148
2149 gfc_common_head *
2150 gfc_get_common (const char *name, int from_module)
2151 {
2152   gfc_symtree *st;
2153   static int serial = 0;
2154   char mangled_name[GFC_MAX_SYMBOL_LEN+1];
2155
2156   if (from_module)
2157     {
2158       /* A use associated common block is only needed to correctly layout
2159          the variables it contains.  */
2160       snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2161       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2162     }
2163   else
2164     {
2165       st = gfc_find_symtree (gfc_current_ns->common_root, name);
2166
2167       if (st == NULL)
2168         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2169     }
2170
2171   if (st->n.common == NULL)
2172     {
2173       st->n.common = gfc_get_common_head ();
2174       st->n.common->where = gfc_current_locus;
2175       strcpy (st->n.common->name, name);
2176     }
2177
2178   return st->n.common;
2179 }
2180
2181
2182 /* Match a common block name.  */
2183
2184 static match
2185 match_common_name (char *name)
2186 {
2187   match m;
2188
2189   if (gfc_match_char ('/') == MATCH_NO)
2190     {
2191       name[0] = '\0';
2192       return MATCH_YES;
2193     }
2194
2195   if (gfc_match_char ('/') == MATCH_YES)
2196     {
2197       name[0] = '\0';
2198       return MATCH_YES;
2199     }
2200
2201   m = gfc_match_name (name);
2202
2203   if (m == MATCH_ERROR)
2204     return MATCH_ERROR;
2205   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2206     return MATCH_YES;
2207
2208   gfc_error ("Syntax error in common block name at %C");
2209   return MATCH_ERROR;
2210 }
2211
2212
2213 /* Match a COMMON statement.  */
2214
2215 match
2216 gfc_match_common (void)
2217 {
2218   gfc_symbol *sym, **head, *tail, *old_blank_common;
2219   char name[GFC_MAX_SYMBOL_LEN+1];
2220   gfc_common_head *t;
2221   gfc_array_spec *as;
2222   match m;
2223
2224   old_blank_common = gfc_current_ns->blank_common.head;
2225   if (old_blank_common)
2226     {
2227       while (old_blank_common->common_next)
2228         old_blank_common = old_blank_common->common_next;
2229     }
2230
2231   as = NULL;
2232
2233   if (gfc_match_eos () == MATCH_YES)
2234     goto syntax;
2235
2236   for (;;)
2237     {
2238       m = match_common_name (name);
2239       if (m == MATCH_ERROR)
2240         goto cleanup;
2241
2242       if (name[0] == '\0')
2243         {
2244           t = &gfc_current_ns->blank_common;
2245           if (t->head == NULL)
2246             t->where = gfc_current_locus;
2247           head = &t->head;
2248         }
2249       else
2250         {
2251           t = gfc_get_common (name, 0);
2252           head = &t->head;
2253         }
2254
2255       if (*head == NULL)
2256         tail = NULL;
2257       else
2258         {
2259           tail = *head;
2260           while (tail->common_next)
2261             tail = tail->common_next;
2262         }
2263
2264       /* Grab the list of symbols.  */
2265       if (gfc_match_eos () == MATCH_YES)
2266         goto done;
2267
2268       for (;;)
2269         {
2270           m = gfc_match_symbol (&sym, 0);
2271           if (m == MATCH_ERROR)
2272             goto cleanup;
2273           if (m == MATCH_NO)
2274             goto syntax;
2275
2276           if (sym->attr.in_common)
2277             {
2278               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2279                          sym->name);
2280               goto cleanup;
2281             }
2282
2283           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2284             goto cleanup;
2285
2286           if (sym->value != NULL
2287               && (name[0] == '\0' || !sym->attr.data))
2288             {
2289               if (name[0] == '\0')
2290                 gfc_error ("Previously initialized symbol '%s' in "
2291                            "blank COMMON block at %C", sym->name);
2292               else
2293                 gfc_error ("Previously initialized symbol '%s' in "
2294                            "COMMON block '%s' at %C", sym->name, name);
2295               goto cleanup;
2296             }
2297
2298           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2299             goto cleanup;
2300
2301           /* Derived type names must have the SEQUENCE attribute.  */
2302           if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2303             {
2304               gfc_error
2305                 ("Derived type variable in COMMON at %C does not have the "
2306                  "SEQUENCE attribute");
2307               goto cleanup;
2308             }
2309
2310           if (tail != NULL)
2311             tail->common_next = sym;
2312           else
2313             *head = sym;
2314
2315           tail = sym;
2316
2317           /* Deal with an optional array specification after the
2318              symbol name.  */
2319           m = gfc_match_array_spec (&as);
2320           if (m == MATCH_ERROR)
2321             goto cleanup;
2322
2323           if (m == MATCH_YES)
2324             {
2325               if (as->type != AS_EXPLICIT)
2326                 {
2327                   gfc_error
2328                     ("Array specification for symbol '%s' in COMMON at %C "
2329                      "must be explicit", sym->name);
2330                   goto cleanup;
2331                 }
2332
2333               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2334                 goto cleanup;
2335
2336               if (sym->attr.pointer)
2337                 {
2338                   gfc_error
2339                     ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2340                      sym->name);
2341                   goto cleanup;
2342                 }
2343
2344               sym->as = as;
2345               as = NULL;
2346             }
2347
2348           gfc_gobble_whitespace ();
2349           if (gfc_match_eos () == MATCH_YES)
2350             goto done;
2351           if (gfc_peek_char () == '/')
2352             break;
2353           if (gfc_match_char (',') != MATCH_YES)
2354             goto syntax;
2355           gfc_gobble_whitespace ();
2356           if (gfc_peek_char () == '/')
2357             break;
2358         }
2359     }
2360
2361 done:
2362   return MATCH_YES;
2363
2364 syntax:
2365   gfc_syntax_error (ST_COMMON);
2366
2367 cleanup:
2368   if (old_blank_common)
2369     old_blank_common->common_next = NULL;
2370   else
2371     gfc_current_ns->blank_common.head = NULL;
2372   gfc_free_array_spec (as);
2373   return MATCH_ERROR;
2374 }
2375
2376
2377 /* Match a BLOCK DATA program unit.  */
2378
2379 match
2380 gfc_match_block_data (void)
2381 {
2382   char name[GFC_MAX_SYMBOL_LEN + 1];
2383   gfc_symbol *sym;
2384   match m;
2385
2386   if (gfc_match_eos () == MATCH_YES)
2387     {
2388       gfc_new_block = NULL;
2389       return MATCH_YES;
2390     }
2391
2392   m = gfc_match ("% %n%t", name);
2393   if (m != MATCH_YES)
2394     return MATCH_ERROR;
2395
2396   if (gfc_get_symbol (name, NULL, &sym))
2397     return MATCH_ERROR;
2398
2399   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2400     return MATCH_ERROR;
2401
2402   gfc_new_block = sym;
2403
2404   return MATCH_YES;
2405 }
2406
2407
2408 /* Free a namelist structure.  */
2409
2410 void
2411 gfc_free_namelist (gfc_namelist * name)
2412 {
2413   gfc_namelist *n;
2414
2415   for (; name; name = n)
2416     {
2417       n = name->next;
2418       gfc_free (name);
2419     }
2420 }
2421
2422
2423 /* Match a NAMELIST statement.  */
2424
2425 match
2426 gfc_match_namelist (void)
2427 {
2428   gfc_symbol *group_name, *sym;
2429   gfc_namelist *nl;
2430   match m, m2;
2431
2432   m = gfc_match (" / %s /", &group_name);
2433   if (m == MATCH_NO)
2434     goto syntax;
2435   if (m == MATCH_ERROR)
2436     goto error;
2437
2438   for (;;)
2439     {
2440       if (group_name->ts.type != BT_UNKNOWN)
2441         {
2442           gfc_error
2443             ("Namelist group name '%s' at %C already has a basic type "
2444              "of %s", group_name->name, gfc_typename (&group_name->ts));
2445           return MATCH_ERROR;
2446         }
2447
2448       if (group_name->attr.flavor != FL_NAMELIST
2449           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2450                              group_name->name, NULL) == FAILURE)
2451         return MATCH_ERROR;
2452
2453       for (;;)
2454         {
2455           m = gfc_match_symbol (&sym, 1);
2456           if (m == MATCH_NO)
2457             goto syntax;
2458           if (m == MATCH_ERROR)
2459             goto error;
2460
2461           if (sym->attr.in_namelist == 0
2462               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
2463             goto error;
2464
2465           nl = gfc_get_namelist ();
2466           nl->sym = sym;
2467
2468           if (group_name->namelist == NULL)
2469             group_name->namelist = group_name->namelist_tail = nl;
2470           else
2471             {
2472               group_name->namelist_tail->next = nl;
2473               group_name->namelist_tail = nl;
2474             }
2475
2476           if (gfc_match_eos () == MATCH_YES)
2477             goto done;
2478
2479           m = gfc_match_char (',');
2480
2481           if (gfc_match_char ('/') == MATCH_YES)
2482             {
2483               m2 = gfc_match (" %s /", &group_name);
2484               if (m2 == MATCH_YES)
2485                 break;
2486               if (m2 == MATCH_ERROR)
2487                 goto error;
2488               goto syntax;
2489             }
2490
2491           if (m != MATCH_YES)
2492             goto syntax;
2493         }
2494     }
2495
2496 done:
2497   return MATCH_YES;
2498
2499 syntax:
2500   gfc_syntax_error (ST_NAMELIST);
2501
2502 error:
2503   return MATCH_ERROR;
2504 }
2505
2506
2507 /* Match a MODULE statement.  */
2508
2509 match
2510 gfc_match_module (void)
2511 {
2512   match m;
2513
2514   m = gfc_match (" %s%t", &gfc_new_block);
2515   if (m != MATCH_YES)
2516     return m;
2517
2518   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2519                       gfc_new_block->name, NULL) == FAILURE)
2520     return MATCH_ERROR;
2521
2522   return MATCH_YES;
2523 }
2524
2525
2526 /* Free equivalence sets and lists.  Recursively is the easiest way to
2527    do this.  */
2528
2529 void
2530 gfc_free_equiv (gfc_equiv * eq)
2531 {
2532
2533   if (eq == NULL)
2534     return;
2535
2536   gfc_free_equiv (eq->eq);
2537   gfc_free_equiv (eq->next);
2538
2539   gfc_free_expr (eq->expr);
2540   gfc_free (eq);
2541 }
2542
2543
2544 /* Match an EQUIVALENCE statement.  */
2545
2546 match
2547 gfc_match_equivalence (void)
2548 {
2549   gfc_equiv *eq, *set, *tail;
2550   gfc_ref *ref;
2551   match m;
2552
2553   tail = NULL;
2554
2555   for (;;)
2556     {
2557       eq = gfc_get_equiv ();
2558       if (tail == NULL)
2559         tail = eq;
2560
2561       eq->next = gfc_current_ns->equiv;
2562       gfc_current_ns->equiv = eq;
2563
2564       if (gfc_match_char ('(') != MATCH_YES)
2565         goto syntax;
2566
2567       set = eq;
2568
2569       for (;;)
2570         {
2571           m = gfc_match_variable (&set->expr, 1);
2572           if (m == MATCH_ERROR)
2573             goto cleanup;
2574           if (m == MATCH_NO)
2575             goto syntax;
2576
2577           for (ref = set->expr->ref; ref; ref = ref->next)
2578             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2579               {
2580                 gfc_error
2581                   ("Array reference in EQUIVALENCE at %C cannot be an "
2582                    "array section");
2583                 goto cleanup;
2584               }
2585
2586           if (gfc_match_char (')') == MATCH_YES)
2587             break;
2588           if (gfc_match_char (',') != MATCH_YES)
2589             goto syntax;
2590
2591           set->eq = gfc_get_equiv ();
2592           set = set->eq;
2593         }
2594
2595       if (gfc_match_eos () == MATCH_YES)
2596         break;
2597       if (gfc_match_char (',') != MATCH_YES)
2598         goto syntax;
2599     }
2600
2601   return MATCH_YES;
2602
2603 syntax:
2604   gfc_syntax_error (ST_EQUIVALENCE);
2605
2606 cleanup:
2607   eq = tail->next;
2608   tail->next = NULL;
2609
2610   gfc_free_equiv (gfc_current_ns->equiv);
2611   gfc_current_ns->equiv = eq;
2612
2613   return MATCH_ERROR;
2614 }
2615
2616
2617 /* Match a statement function declaration.  It is so easy to match
2618    non-statement function statements with a MATCH_ERROR as opposed to
2619    MATCH_NO that we suppress error message in most cases.  */
2620
2621 match
2622 gfc_match_st_function (void)
2623 {
2624   gfc_error_buf old_error;
2625   gfc_symbol *sym;
2626   gfc_expr *expr;
2627   match m;
2628
2629   m = gfc_match_symbol (&sym, 0);
2630   if (m != MATCH_YES)
2631     return m;
2632
2633   gfc_push_error (&old_error);
2634
2635   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
2636                          sym->name, NULL) == FAILURE)
2637     goto undo_error;
2638
2639   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2640     goto undo_error;
2641
2642   m = gfc_match (" = %e%t", &expr);
2643   if (m == MATCH_NO)
2644     goto undo_error;
2645   if (m == MATCH_ERROR)
2646     return m;
2647
2648   sym->value = expr;
2649
2650   return MATCH_YES;
2651
2652 undo_error:
2653   gfc_pop_error (&old_error);
2654   return MATCH_NO;
2655 }
2656
2657
2658 /***************** SELECT CASE subroutines ******************/
2659
2660 /* Free a single case structure.  */
2661
2662 static void
2663 free_case (gfc_case * p)
2664 {
2665   if (p->low == p->high)
2666     p->high = NULL;
2667   gfc_free_expr (p->low);
2668   gfc_free_expr (p->high);
2669   gfc_free (p);
2670 }
2671
2672
2673 /* Free a list of case structures.  */
2674
2675 void
2676 gfc_free_case_list (gfc_case * p)
2677 {
2678   gfc_case *q;
2679
2680   for (; p; p = q)
2681     {
2682       q = p->next;
2683       free_case (p);
2684     }
2685 }
2686
2687
2688 /* Match a single case selector.  */
2689
2690 static match
2691 match_case_selector (gfc_case ** cp)
2692 {
2693   gfc_case *c;
2694   match m;
2695
2696   c = gfc_get_case ();
2697   c->where = gfc_current_locus;
2698
2699   if (gfc_match_char (':') == MATCH_YES)
2700     {
2701       m = gfc_match_init_expr (&c->high);
2702       if (m == MATCH_NO)
2703         goto need_expr;
2704       if (m == MATCH_ERROR)
2705         goto cleanup;
2706     }
2707
2708   else
2709     {
2710       m = gfc_match_init_expr (&c->low);
2711       if (m == MATCH_ERROR)
2712         goto cleanup;
2713       if (m == MATCH_NO)
2714         goto need_expr;
2715
2716       /* If we're not looking at a ':' now, make a range out of a single
2717          target.  Else get the upper bound for the case range.  */
2718       if (gfc_match_char (':') != MATCH_YES)
2719         c->high = c->low;
2720       else
2721         {
2722           m = gfc_match_init_expr (&c->high);
2723           if (m == MATCH_ERROR)
2724             goto cleanup;
2725           /* MATCH_NO is fine.  It's OK if nothing is there!  */
2726         }
2727     }
2728
2729   *cp = c;
2730   return MATCH_YES;
2731
2732 need_expr:
2733   gfc_error ("Expected initialization expression in CASE at %C");
2734
2735 cleanup:
2736   free_case (c);
2737   return MATCH_ERROR;
2738 }
2739
2740
2741 /* Match the end of a case statement.  */
2742
2743 static match
2744 match_case_eos (void)
2745 {
2746   char name[GFC_MAX_SYMBOL_LEN + 1];
2747   match m;
2748
2749   if (gfc_match_eos () == MATCH_YES)
2750     return MATCH_YES;
2751
2752   gfc_gobble_whitespace ();
2753
2754   m = gfc_match_name (name);
2755   if (m != MATCH_YES)
2756     return m;
2757
2758   if (strcmp (name, gfc_current_block ()->name) != 0)
2759     {
2760       gfc_error ("Expected case name of '%s' at %C",
2761                  gfc_current_block ()->name);
2762       return MATCH_ERROR;
2763     }
2764
2765   return gfc_match_eos ();
2766 }
2767
2768
2769 /* Match a SELECT statement.  */
2770
2771 match
2772 gfc_match_select (void)
2773 {
2774   gfc_expr *expr;
2775   match m;
2776
2777   m = gfc_match_label ();
2778   if (m == MATCH_ERROR)
2779     return m;
2780
2781   m = gfc_match (" select case ( %e )%t", &expr);
2782   if (m != MATCH_YES)
2783     return m;
2784
2785   new_st.op = EXEC_SELECT;
2786   new_st.expr = expr;
2787
2788   return MATCH_YES;
2789 }
2790
2791
2792 /* Match a CASE statement.  */
2793
2794 match
2795 gfc_match_case (void)
2796 {
2797   gfc_case *c, *head, *tail;
2798   match m;
2799
2800   head = tail = NULL;
2801
2802   if (gfc_current_state () != COMP_SELECT)
2803     {
2804       gfc_error ("Unexpected CASE statement at %C");
2805       return MATCH_ERROR;
2806     }
2807
2808   if (gfc_match ("% default") == MATCH_YES)
2809     {
2810       m = match_case_eos ();
2811       if (m == MATCH_NO)
2812         goto syntax;
2813       if (m == MATCH_ERROR)
2814         goto cleanup;
2815
2816       new_st.op = EXEC_SELECT;
2817       c = gfc_get_case ();
2818       c->where = gfc_current_locus;
2819       new_st.ext.case_list = c;
2820       return MATCH_YES;
2821     }
2822
2823   if (gfc_match_char ('(') != MATCH_YES)
2824     goto syntax;
2825
2826   for (;;)
2827     {
2828       if (match_case_selector (&c) == MATCH_ERROR)
2829         goto cleanup;
2830
2831       if (head == NULL)
2832         head = c;
2833       else
2834         tail->next = c;
2835
2836       tail = c;
2837
2838       if (gfc_match_char (')') == MATCH_YES)
2839         break;
2840       if (gfc_match_char (',') != MATCH_YES)
2841         goto syntax;
2842     }
2843
2844   m = match_case_eos ();
2845   if (m == MATCH_NO)
2846     goto syntax;
2847   if (m == MATCH_ERROR)
2848     goto cleanup;
2849
2850   new_st.op = EXEC_SELECT;
2851   new_st.ext.case_list = head;
2852
2853   return MATCH_YES;
2854
2855 syntax:
2856   gfc_error ("Syntax error in CASE-specification at %C");
2857
2858 cleanup:
2859   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
2860   return MATCH_ERROR;
2861 }
2862
2863 /********************* WHERE subroutines ********************/
2864
2865 /* Match the rest of a simple WHERE statement that follows an IF statement.
2866  */
2867
2868 static match
2869 match_simple_where (void)
2870 {
2871   gfc_expr *expr;
2872   gfc_code *c;
2873   match m;
2874
2875   m = gfc_match (" ( %e )", &expr);
2876   if (m != MATCH_YES)
2877     return m;
2878
2879   m = gfc_match_assignment ();
2880   if (m == MATCH_NO)
2881     goto syntax;
2882   if (m == MATCH_ERROR)
2883     goto cleanup;
2884
2885   if (gfc_match_eos () != MATCH_YES)
2886     goto syntax;
2887
2888   c = gfc_get_code ();
2889
2890   c->op = EXEC_WHERE;
2891   c->expr = expr;
2892   c->next = gfc_get_code ();
2893
2894   *c->next = new_st;
2895   gfc_clear_new_st ();
2896
2897   new_st.op = EXEC_WHERE;
2898   new_st.block = c;
2899
2900   return MATCH_YES;
2901
2902 syntax:
2903   gfc_syntax_error (ST_WHERE);
2904
2905 cleanup:
2906   gfc_free_expr (expr);
2907   return MATCH_ERROR;
2908 }
2909
2910 /* Match a WHERE statement.  */
2911
2912 match
2913 gfc_match_where (gfc_statement * st)
2914 {
2915   gfc_expr *expr;
2916   match m0, m;
2917   gfc_code *c;
2918
2919   m0 = gfc_match_label ();
2920   if (m0 == MATCH_ERROR)
2921     return m0;
2922
2923   m = gfc_match (" where ( %e )", &expr);
2924   if (m != MATCH_YES)
2925     return m;
2926
2927   if (gfc_match_eos () == MATCH_YES)
2928     {
2929       *st = ST_WHERE_BLOCK;
2930
2931       new_st.op = EXEC_WHERE;
2932       new_st.expr = expr;
2933       return MATCH_YES;
2934     }
2935
2936   m = gfc_match_assignment ();
2937   if (m == MATCH_NO)
2938     gfc_syntax_error (ST_WHERE);
2939
2940   if (m != MATCH_YES)
2941     {
2942       gfc_free_expr (expr);
2943       return MATCH_ERROR;
2944     }
2945
2946   /* We've got a simple WHERE statement.  */
2947   *st = ST_WHERE;
2948   c = gfc_get_code ();
2949
2950   c->op = EXEC_WHERE;
2951   c->expr = expr;
2952   c->next = gfc_get_code ();
2953
2954   *c->next = new_st;
2955   gfc_clear_new_st ();
2956
2957   new_st.op = EXEC_WHERE;
2958   new_st.block = c;
2959
2960   return MATCH_YES;
2961 }
2962
2963
2964 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
2965    new_st if successful.  */
2966
2967 match
2968 gfc_match_elsewhere (void)
2969 {
2970   char name[GFC_MAX_SYMBOL_LEN + 1];
2971   gfc_expr *expr;
2972   match m;
2973
2974   if (gfc_current_state () != COMP_WHERE)
2975     {
2976       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
2977       return MATCH_ERROR;
2978     }
2979
2980   expr = NULL;
2981
2982   if (gfc_match_char ('(') == MATCH_YES)
2983     {
2984       m = gfc_match_expr (&expr);
2985       if (m == MATCH_NO)
2986         goto syntax;
2987       if (m == MATCH_ERROR)
2988         return MATCH_ERROR;
2989
2990       if (gfc_match_char (')') != MATCH_YES)
2991         goto syntax;
2992     }
2993
2994   if (gfc_match_eos () != MATCH_YES)
2995     {                           /* Better be a name at this point */
2996       m = gfc_match_name (name);
2997       if (m == MATCH_NO)
2998         goto syntax;
2999       if (m == MATCH_ERROR)
3000         goto cleanup;
3001
3002       if (gfc_match_eos () != MATCH_YES)
3003         goto syntax;
3004
3005       if (strcmp (name, gfc_current_block ()->name) != 0)
3006         {
3007           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3008                      name, gfc_current_block ()->name);
3009           goto cleanup;
3010         }
3011     }
3012
3013   new_st.op = EXEC_WHERE;
3014   new_st.expr = expr;
3015   return MATCH_YES;
3016
3017 syntax:
3018   gfc_syntax_error (ST_ELSEWHERE);
3019
3020 cleanup:
3021   gfc_free_expr (expr);
3022   return MATCH_ERROR;
3023 }
3024
3025
3026 /******************** FORALL subroutines ********************/
3027
3028 /* Free a list of FORALL iterators.  */
3029
3030 void
3031 gfc_free_forall_iterator (gfc_forall_iterator * iter)
3032 {
3033   gfc_forall_iterator *next;
3034
3035   while (iter)
3036     {
3037       next = iter->next;
3038
3039       gfc_free_expr (iter->var);
3040       gfc_free_expr (iter->start);
3041       gfc_free_expr (iter->end);
3042       gfc_free_expr (iter->stride);
3043
3044       gfc_free (iter);
3045       iter = next;
3046     }
3047 }
3048
3049
3050 /* Match an iterator as part of a FORALL statement.  The format is:
3051
3052      <var> = <start>:<end>[:<stride>][, <scalar mask>]  */
3053
3054 static match
3055 match_forall_iterator (gfc_forall_iterator ** result)
3056 {
3057   gfc_forall_iterator *iter;
3058   locus where;
3059   match m;
3060
3061   where = gfc_current_locus;
3062   iter = gfc_getmem (sizeof (gfc_forall_iterator));
3063
3064   m = gfc_match_variable (&iter->var, 0);
3065   if (m != MATCH_YES)
3066     goto cleanup;
3067
3068   if (gfc_match_char ('=') != MATCH_YES)
3069     {
3070       m = MATCH_NO;
3071       goto cleanup;
3072     }
3073
3074   m = gfc_match_expr (&iter->start);
3075   if (m == MATCH_NO)
3076     goto syntax;
3077   if (m == MATCH_ERROR)
3078     goto cleanup;
3079
3080   if (gfc_match_char (':') != MATCH_YES)
3081     goto syntax;
3082
3083   m = gfc_match_expr (&iter->end);
3084   if (m == MATCH_NO)
3085     goto syntax;
3086   if (m == MATCH_ERROR)
3087     goto cleanup;
3088
3089   if (gfc_match_char (':') == MATCH_NO)
3090     iter->stride = gfc_int_expr (1);
3091   else
3092     {
3093       m = gfc_match_expr (&iter->stride);
3094       if (m == MATCH_NO)
3095         goto syntax;
3096       if (m == MATCH_ERROR)
3097         goto cleanup;
3098     }
3099
3100   *result = iter;
3101   return MATCH_YES;
3102
3103 syntax:
3104   gfc_error ("Syntax error in FORALL iterator at %C");
3105   m = MATCH_ERROR;
3106
3107 cleanup:
3108   gfc_current_locus = where;
3109   gfc_free_forall_iterator (iter);
3110   return m;
3111 }
3112
3113
3114 /* Match the header of a FORALL statement.  */
3115
3116 static match
3117 match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
3118 {
3119   gfc_forall_iterator *head, *tail, *new;
3120   match m;
3121
3122   gfc_gobble_whitespace ();
3123
3124   head = tail = NULL;
3125   *mask = NULL;
3126
3127   if (gfc_match_char ('(') != MATCH_YES)
3128     return MATCH_NO;
3129
3130   m = match_forall_iterator (&new);
3131   if (m == MATCH_ERROR)
3132     goto cleanup;
3133   if (m == MATCH_NO)
3134     goto syntax;
3135
3136   head = tail = new;
3137
3138   for (;;)
3139     {
3140       if (gfc_match_char (',') != MATCH_YES)
3141         break;
3142
3143       m = match_forall_iterator (&new);
3144       if (m == MATCH_ERROR)
3145         goto cleanup;
3146       if (m == MATCH_YES)
3147         {
3148           tail->next = new;
3149           tail = new;
3150           continue;
3151         }
3152
3153       /* Have to have a mask expression */
3154
3155       m = gfc_match_expr (mask);
3156       if (m == MATCH_NO)
3157         goto syntax;
3158       if (m == MATCH_ERROR)
3159         goto cleanup;
3160
3161       break;
3162     }
3163
3164   if (gfc_match_char (')') == MATCH_NO)
3165     goto syntax;
3166
3167   *phead = head;
3168   return MATCH_YES;
3169
3170 syntax:
3171   gfc_syntax_error (ST_FORALL);
3172
3173 cleanup:
3174   gfc_free_expr (*mask);
3175   gfc_free_forall_iterator (head);
3176
3177   return MATCH_ERROR;
3178 }
3179
3180 /* Match the rest of a simple FORALL statement that follows an IF statement.
3181  */
3182
3183 static match
3184 match_simple_forall (void)
3185 {
3186   gfc_forall_iterator *head;
3187   gfc_expr *mask;
3188   gfc_code *c;
3189   match m;
3190
3191   mask = NULL;
3192   head = NULL;
3193   c = NULL;
3194
3195   m = match_forall_header (&head, &mask);
3196
3197   if (m == MATCH_NO)
3198     goto syntax;
3199   if (m != MATCH_YES)
3200     goto cleanup;
3201
3202   m = gfc_match_assignment ();
3203
3204   if (m == MATCH_ERROR)
3205     goto cleanup;
3206   if (m == MATCH_NO)
3207     {
3208       m = gfc_match_pointer_assignment ();
3209       if (m == MATCH_ERROR)
3210         goto cleanup;
3211       if (m == MATCH_NO)
3212         goto syntax;
3213     }
3214
3215   c = gfc_get_code ();
3216   *c = new_st;
3217   c->loc = gfc_current_locus;
3218
3219   if (gfc_match_eos () != MATCH_YES)
3220     goto syntax;
3221
3222   gfc_clear_new_st ();
3223   new_st.op = EXEC_FORALL;
3224   new_st.expr = mask;
3225   new_st.ext.forall_iterator = head;
3226   new_st.block = gfc_get_code ();
3227
3228   new_st.block->op = EXEC_FORALL;
3229   new_st.block->next = c;
3230
3231   return MATCH_YES;
3232
3233 syntax:
3234   gfc_syntax_error (ST_FORALL);
3235
3236 cleanup:
3237   gfc_free_forall_iterator (head);
3238   gfc_free_expr (mask);
3239
3240   return MATCH_ERROR;
3241 }
3242
3243
3244 /* Match a FORALL statement.  */
3245
3246 match
3247 gfc_match_forall (gfc_statement * st)
3248 {
3249   gfc_forall_iterator *head;
3250   gfc_expr *mask;
3251   gfc_code *c;
3252   match m0, m;
3253
3254   head = NULL;
3255   mask = NULL;
3256   c = NULL;
3257
3258   m0 = gfc_match_label ();
3259   if (m0 == MATCH_ERROR)
3260     return MATCH_ERROR;
3261
3262   m = gfc_match (" forall");
3263   if (m != MATCH_YES)
3264     return m;
3265
3266   m = match_forall_header (&head, &mask);
3267   if (m == MATCH_ERROR)
3268     goto cleanup;
3269   if (m == MATCH_NO)
3270     goto syntax;
3271
3272   if (gfc_match_eos () == MATCH_YES)
3273     {
3274       *st = ST_FORALL_BLOCK;
3275
3276       new_st.op = EXEC_FORALL;
3277       new_st.expr = mask;
3278       new_st.ext.forall_iterator = head;
3279
3280       return MATCH_YES;
3281     }
3282
3283   m = gfc_match_assignment ();
3284   if (m == MATCH_ERROR)
3285     goto cleanup;
3286   if (m == MATCH_NO)
3287     {
3288       m = gfc_match_pointer_assignment ();
3289       if (m == MATCH_ERROR)
3290         goto cleanup;
3291       if (m == MATCH_NO)
3292         goto syntax;
3293     }
3294
3295   c = gfc_get_code ();
3296   *c = new_st;
3297
3298   if (gfc_match_eos () != MATCH_YES)
3299     goto syntax;
3300
3301   gfc_clear_new_st ();
3302   new_st.op = EXEC_FORALL;
3303   new_st.expr = mask;
3304   new_st.ext.forall_iterator = head;
3305   new_st.block = gfc_get_code ();
3306
3307   new_st.block->op = EXEC_FORALL;
3308   new_st.block->next = c;
3309
3310   *st = ST_FORALL;
3311   return MATCH_YES;
3312
3313 syntax:
3314   gfc_syntax_error (ST_FORALL);
3315
3316 cleanup:
3317   gfc_free_forall_iterator (head);
3318   gfc_free_expr (mask);
3319   gfc_free_statements (c);
3320   return MATCH_NO;
3321 }