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