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       new_st.op = EXEC_GOTO;
1530       new_st.expr = expr;
1531
1532       if (gfc_match_eos () == MATCH_YES)
1533         return MATCH_YES;
1534
1535       /* Match label list.  */
1536       gfc_match_char (',');
1537       if (gfc_match_char ('(') != MATCH_YES)
1538         {
1539           gfc_syntax_error (ST_GOTO);
1540           return MATCH_ERROR;
1541         }
1542       head = tail = NULL;
1543
1544       do
1545         {
1546           m = gfc_match_st_label (&label, 0);
1547           if (m != MATCH_YES)
1548             goto syntax;
1549
1550           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1551             goto cleanup;
1552
1553           if (head == NULL)
1554             head = tail = gfc_get_code ();
1555           else
1556             {
1557               tail->block = gfc_get_code ();
1558               tail = tail->block;
1559             }
1560
1561           tail->label = label;
1562           tail->op = EXEC_GOTO;
1563         }
1564       while (gfc_match_char (',') == MATCH_YES);
1565
1566       if (gfc_match (")%t") != MATCH_YES)
1567         goto syntax;
1568
1569       if (head == NULL)
1570         {
1571            gfc_error (
1572                "Statement label list in GOTO at %C cannot be empty");
1573            goto syntax;
1574         }
1575       new_st.block = head;
1576
1577       return MATCH_YES;
1578     }
1579
1580   /* Last chance is a computed GO TO statement.  */
1581   if (gfc_match_char ('(') != MATCH_YES)
1582     {
1583       gfc_syntax_error (ST_GOTO);
1584       return MATCH_ERROR;
1585     }
1586
1587   head = tail = NULL;
1588   i = 1;
1589
1590   do
1591     {
1592       m = gfc_match_st_label (&label, 0);
1593       if (m != MATCH_YES)
1594         goto syntax;
1595
1596       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1597         goto cleanup;
1598
1599       if (head == NULL)
1600         head = tail = gfc_get_code ();
1601       else
1602         {
1603           tail->block = gfc_get_code ();
1604           tail = tail->block;
1605         }
1606
1607       cp = gfc_get_case ();
1608       cp->low = cp->high = gfc_int_expr (i++);
1609
1610       tail->op = EXEC_SELECT;
1611       tail->ext.case_list = cp;
1612
1613       tail->next = gfc_get_code ();
1614       tail->next->op = EXEC_GOTO;
1615       tail->next->label = label;
1616     }
1617   while (gfc_match_char (',') == MATCH_YES);
1618
1619   if (gfc_match_char (')') != MATCH_YES)
1620     goto syntax;
1621
1622   if (head == NULL)
1623     {
1624       gfc_error ("Statement label list in GOTO at %C cannot be empty");
1625       goto syntax;
1626     }
1627
1628   /* Get the rest of the statement.  */
1629   gfc_match_char (',');
1630
1631   if (gfc_match (" %e%t", &expr) != MATCH_YES)
1632     goto syntax;
1633
1634   /* At this point, a computed GOTO has been fully matched and an
1635      equivalent SELECT statement constructed.  */
1636
1637   new_st.op = EXEC_SELECT;
1638   new_st.expr = NULL;
1639
1640   /* Hack: For a "real" SELECT, the expression is in expr. We put
1641      it in expr2 so we can distinguish then and produce the correct
1642      diagnostics.  */
1643   new_st.expr2 = expr;
1644   new_st.block = head;
1645   return MATCH_YES;
1646
1647 syntax:
1648   gfc_syntax_error (ST_GOTO);
1649 cleanup:
1650   gfc_free_statements (head);
1651   return MATCH_ERROR;
1652 }
1653
1654
1655 /* Frees a list of gfc_alloc structures.  */
1656
1657 void
1658 gfc_free_alloc_list (gfc_alloc * p)
1659 {
1660   gfc_alloc *q;
1661
1662   for (; p; p = q)
1663     {
1664       q = p->next;
1665       gfc_free_expr (p->expr);
1666       gfc_free (p);
1667     }
1668 }
1669
1670
1671 /* Match an ALLOCATE statement.  */
1672
1673 match
1674 gfc_match_allocate (void)
1675 {
1676   gfc_alloc *head, *tail;
1677   gfc_expr *stat;
1678   match m;
1679
1680   head = tail = NULL;
1681   stat = NULL;
1682
1683   if (gfc_match_char ('(') != MATCH_YES)
1684     goto syntax;
1685
1686   for (;;)
1687     {
1688       if (head == NULL)
1689         head = tail = gfc_get_alloc ();
1690       else
1691         {
1692           tail->next = gfc_get_alloc ();
1693           tail = tail->next;
1694         }
1695
1696       m = gfc_match_variable (&tail->expr, 0);
1697       if (m == MATCH_NO)
1698         goto syntax;
1699       if (m == MATCH_ERROR)
1700         goto cleanup;
1701
1702       if (gfc_check_do_variable (tail->expr->symtree))
1703         goto cleanup;
1704
1705       if (gfc_pure (NULL)
1706           && gfc_impure_variable (tail->expr->symtree->n.sym))
1707         {
1708           gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1709                      "PURE procedure");
1710           goto cleanup;
1711         }
1712
1713       if (gfc_match_char (',') != MATCH_YES)
1714         break;
1715
1716       m = gfc_match (" stat = %v", &stat);
1717       if (m == MATCH_ERROR)
1718         goto cleanup;
1719       if (m == MATCH_YES)
1720         break;
1721     }
1722
1723   if (stat != NULL)
1724     {
1725       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1726         {
1727           gfc_error
1728             ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1729              "INTENT(IN)", stat->symtree->n.sym->name);
1730           goto cleanup;
1731         }
1732
1733       if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
1734         {
1735           gfc_error
1736             ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1737              "procedure");
1738           goto cleanup;
1739         }
1740
1741       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1742         {
1743           gfc_error("STAT expression at %C must be a variable");
1744           goto cleanup;
1745         }
1746
1747       gfc_check_do_variable(stat->symtree);
1748     }
1749
1750   if (gfc_match (" )%t") != MATCH_YES)
1751     goto syntax;
1752
1753   new_st.op = EXEC_ALLOCATE;
1754   new_st.expr = stat;
1755   new_st.ext.alloc_list = head;
1756
1757   return MATCH_YES;
1758
1759 syntax:
1760   gfc_syntax_error (ST_ALLOCATE);
1761
1762 cleanup:
1763   gfc_free_expr (stat);
1764   gfc_free_alloc_list (head);
1765   return MATCH_ERROR;
1766 }
1767
1768
1769 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1770    a set of pointer assignments to intrinsic NULL().  */
1771
1772 match
1773 gfc_match_nullify (void)
1774 {
1775   gfc_code *tail;
1776   gfc_expr *e, *p;
1777   match m;
1778
1779   tail = NULL;
1780
1781   if (gfc_match_char ('(') != MATCH_YES)
1782     goto syntax;
1783
1784   for (;;)
1785     {
1786       m = gfc_match_variable (&p, 0);
1787       if (m == MATCH_ERROR)
1788         goto cleanup;
1789       if (m == MATCH_NO)
1790         goto syntax;
1791
1792       if (gfc_check_do_variable(p->symtree))
1793         goto cleanup;
1794
1795       if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
1796         {
1797           gfc_error
1798             ("Illegal variable in NULLIFY at %C for a PURE procedure");
1799           goto cleanup;
1800         }
1801
1802       /* build ' => NULL() ' */
1803       e = gfc_get_expr ();
1804       e->where = gfc_current_locus;
1805       e->expr_type = EXPR_NULL;
1806       e->ts.type = BT_UNKNOWN;
1807
1808       /* Chain to list */
1809       if (tail == NULL)
1810         tail = &new_st;
1811       else
1812         {
1813           tail->next = gfc_get_code ();
1814           tail = tail->next;
1815         }
1816
1817       tail->op = EXEC_POINTER_ASSIGN;
1818       tail->expr = p;
1819       tail->expr2 = e;
1820
1821       if (gfc_match (" )%t") == MATCH_YES)
1822         break;
1823       if (gfc_match_char (',') != MATCH_YES)
1824         goto syntax;
1825     }
1826
1827   return MATCH_YES;
1828
1829 syntax:
1830   gfc_syntax_error (ST_NULLIFY);
1831
1832 cleanup:
1833   gfc_free_statements (tail);
1834   return MATCH_ERROR;
1835 }
1836
1837
1838 /* Match a DEALLOCATE statement.  */
1839
1840 match
1841 gfc_match_deallocate (void)
1842 {
1843   gfc_alloc *head, *tail;
1844   gfc_expr *stat;
1845   match m;
1846
1847   head = tail = NULL;
1848   stat = NULL;
1849
1850   if (gfc_match_char ('(') != MATCH_YES)
1851     goto syntax;
1852
1853   for (;;)
1854     {
1855       if (head == NULL)
1856         head = tail = gfc_get_alloc ();
1857       else
1858         {
1859           tail->next = gfc_get_alloc ();
1860           tail = tail->next;
1861         }
1862
1863       m = gfc_match_variable (&tail->expr, 0);
1864       if (m == MATCH_ERROR)
1865         goto cleanup;
1866       if (m == MATCH_NO)
1867         goto syntax;
1868
1869       if (gfc_check_do_variable (tail->expr->symtree))
1870         goto cleanup;
1871
1872       if (gfc_pure (NULL)
1873           && gfc_impure_variable (tail->expr->symtree->n.sym))
1874         {
1875           gfc_error
1876             ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
1877              "procedure");
1878           goto cleanup;
1879         }
1880
1881       if (gfc_match_char (',') != MATCH_YES)
1882         break;
1883
1884       m = gfc_match (" stat = %v", &stat);
1885       if (m == MATCH_ERROR)
1886         goto cleanup;
1887       if (m == MATCH_YES)
1888         break;
1889     }
1890
1891   if (stat != NULL)
1892     {
1893       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1894         {
1895           gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
1896                      "cannot be INTENT(IN)", stat->symtree->n.sym->name);
1897           goto cleanup;
1898         }
1899
1900       if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
1901         {
1902           gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
1903                      "for a PURE procedure");
1904           goto cleanup;
1905         }
1906
1907       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1908         {
1909           gfc_error("STAT expression at %C must be a variable");
1910           goto cleanup;
1911         }
1912
1913       gfc_check_do_variable(stat->symtree);
1914     }
1915
1916   if (gfc_match (" )%t") != MATCH_YES)
1917     goto syntax;
1918
1919   new_st.op = EXEC_DEALLOCATE;
1920   new_st.expr = stat;
1921   new_st.ext.alloc_list = head;
1922
1923   return MATCH_YES;
1924
1925 syntax:
1926   gfc_syntax_error (ST_DEALLOCATE);
1927
1928 cleanup:
1929   gfc_free_expr (stat);
1930   gfc_free_alloc_list (head);
1931   return MATCH_ERROR;
1932 }
1933
1934
1935 /* Match a RETURN statement.  */
1936
1937 match
1938 gfc_match_return (void)
1939 {
1940   gfc_expr *e;
1941   match m;
1942   gfc_compile_state s;
1943
1944   gfc_enclosing_unit (&s);
1945   if (s == COMP_PROGRAM
1946       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
1947                          "main program at %C") == FAILURE)
1948       return MATCH_ERROR;
1949
1950   e = NULL;
1951   if (gfc_match_eos () == MATCH_YES)
1952     goto done;
1953
1954   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
1955     {
1956       gfc_error ("Alternate RETURN statement at %C is only allowed within "
1957                  "a SUBROUTINE");
1958       goto cleanup;
1959     }
1960
1961   m = gfc_match ("% %e%t", &e);
1962   if (m == MATCH_YES)
1963     goto done;
1964   if (m == MATCH_ERROR)
1965     goto cleanup;
1966
1967   gfc_syntax_error (ST_RETURN);
1968
1969 cleanup:
1970   gfc_free_expr (e);
1971   return MATCH_ERROR;
1972
1973 done:
1974   new_st.op = EXEC_RETURN;
1975   new_st.expr = e;
1976
1977   return MATCH_YES;
1978 }
1979
1980
1981 /* Match a CALL statement.  The tricky part here are possible
1982    alternate return specifiers.  We handle these by having all
1983    "subroutines" actually return an integer via a register that gives
1984    the return number.  If the call specifies alternate returns, we
1985    generate code for a SELECT statement whose case clauses contain
1986    GOTOs to the various labels.  */
1987
1988 match
1989 gfc_match_call (void)
1990 {
1991   char name[GFC_MAX_SYMBOL_LEN + 1];
1992   gfc_actual_arglist *a, *arglist;
1993   gfc_case *new_case;
1994   gfc_symbol *sym;
1995   gfc_symtree *st;
1996   gfc_code *c;
1997   match m;
1998   int i;
1999
2000   arglist = NULL;
2001
2002   m = gfc_match ("% %n", name);
2003   if (m == MATCH_NO)
2004     goto syntax;
2005   if (m != MATCH_YES)
2006     return m;
2007
2008   if (gfc_get_ha_sym_tree (name, &st))
2009     return MATCH_ERROR;
2010
2011   sym = st->n.sym;
2012   gfc_set_sym_referenced (sym);
2013
2014   if (!sym->attr.generic
2015       && !sym->attr.subroutine
2016       && gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2017     return MATCH_ERROR;
2018
2019   if (gfc_match_eos () != MATCH_YES)
2020     {
2021       m = gfc_match_actual_arglist (1, &arglist);
2022       if (m == MATCH_NO)
2023         goto syntax;
2024       if (m == MATCH_ERROR)
2025         goto cleanup;
2026
2027       if (gfc_match_eos () != MATCH_YES)
2028         goto syntax;
2029     }
2030
2031   /* If any alternate return labels were found, construct a SELECT
2032      statement that will jump to the right place.  */
2033
2034   i = 0;
2035   for (a = arglist; a; a = a->next)
2036     if (a->expr == NULL)
2037         i = 1;
2038
2039   if (i)
2040     {
2041       gfc_symtree *select_st;
2042       gfc_symbol *select_sym;
2043       char name[GFC_MAX_SYMBOL_LEN + 1];
2044
2045       new_st.next = c = gfc_get_code ();
2046       c->op = EXEC_SELECT;
2047       sprintf (name, "_result_%s",sym->name);
2048       gfc_get_ha_sym_tree (name, &select_st);  /* Can't fail */
2049
2050       select_sym = select_st->n.sym;
2051       select_sym->ts.type = BT_INTEGER;
2052       select_sym->ts.kind = gfc_default_integer_kind;
2053       gfc_set_sym_referenced (select_sym);
2054       c->expr = gfc_get_expr ();
2055       c->expr->expr_type = EXPR_VARIABLE;
2056       c->expr->symtree = select_st;
2057       c->expr->ts = select_sym->ts;
2058       c->expr->where = gfc_current_locus;
2059
2060       i = 0;
2061       for (a = arglist; a; a = a->next)
2062         {
2063           if (a->expr != NULL)
2064             continue;
2065
2066           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2067             continue;
2068
2069           i++;
2070
2071           c->block = gfc_get_code ();
2072           c = c->block;
2073           c->op = EXEC_SELECT;
2074
2075           new_case = gfc_get_case ();
2076           new_case->high = new_case->low = gfc_int_expr (i);
2077           c->ext.case_list = new_case;
2078
2079           c->next = gfc_get_code ();
2080           c->next->op = EXEC_GOTO;
2081           c->next->label = a->label;
2082         }
2083     }
2084
2085   new_st.op = EXEC_CALL;
2086   new_st.symtree = st;
2087   new_st.ext.actual = arglist;
2088
2089   return MATCH_YES;
2090
2091 syntax:
2092   gfc_syntax_error (ST_CALL);
2093
2094 cleanup:
2095   gfc_free_actual_arglist (arglist);
2096   return MATCH_ERROR;
2097 }
2098
2099
2100 /* Given a name, return a pointer to the common head structure,
2101    creating it if it does not exist. If FROM_MODULE is nonzero, we
2102    mangle the name so that it doesn't interfere with commons defined
2103    in the using namespace.
2104    TODO: Add to global symbol tree.  */
2105
2106 gfc_common_head *
2107 gfc_get_common (const char *name, int from_module)
2108 {
2109   gfc_symtree *st;
2110   static int serial = 0;
2111   char mangled_name[GFC_MAX_SYMBOL_LEN+1];
2112
2113   if (from_module)
2114     {
2115       /* A use associated common block is only needed to correctly layout
2116          the variables it contains.  */
2117       snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2118       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2119     }
2120   else
2121     {
2122       st = gfc_find_symtree (gfc_current_ns->common_root, name);
2123
2124       if (st == NULL)
2125         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2126     }
2127
2128   if (st->n.common == NULL)
2129     {
2130       st->n.common = gfc_get_common_head ();
2131       st->n.common->where = gfc_current_locus;
2132       strcpy (st->n.common->name, name);
2133     }
2134
2135   return st->n.common;
2136 }
2137
2138
2139 /* Match a common block name.  */
2140
2141 static match
2142 match_common_name (char *name)
2143 {
2144   match m;
2145
2146   if (gfc_match_char ('/') == MATCH_NO)
2147     {
2148       name[0] = '\0';
2149       return MATCH_YES;
2150     }
2151
2152   if (gfc_match_char ('/') == MATCH_YES)
2153     {
2154       name[0] = '\0';
2155       return MATCH_YES;
2156     }
2157
2158   m = gfc_match_name (name);
2159
2160   if (m == MATCH_ERROR)
2161     return MATCH_ERROR;
2162   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2163     return MATCH_YES;
2164
2165   gfc_error ("Syntax error in common block name at %C");
2166   return MATCH_ERROR;
2167 }
2168
2169
2170 /* Match a COMMON statement.  */
2171
2172 match
2173 gfc_match_common (void)
2174 {
2175   gfc_symbol *sym, **head, *tail, *old_blank_common;
2176   char name[GFC_MAX_SYMBOL_LEN+1];
2177   gfc_common_head *t;
2178   gfc_array_spec *as;
2179   match m;
2180
2181   old_blank_common = gfc_current_ns->blank_common.head;
2182   if (old_blank_common)
2183     {
2184       while (old_blank_common->common_next)
2185         old_blank_common = old_blank_common->common_next;
2186     }
2187
2188   as = NULL;
2189
2190   if (gfc_match_eos () == MATCH_YES)
2191     goto syntax;
2192
2193   for (;;)
2194     {
2195       m = match_common_name (name);
2196       if (m == MATCH_ERROR)
2197         goto cleanup;
2198
2199       if (name[0] == '\0')
2200         {
2201           t = &gfc_current_ns->blank_common;
2202           if (t->head == NULL)
2203             t->where = gfc_current_locus;
2204           head = &t->head;
2205         }
2206       else
2207         {
2208           t = gfc_get_common (name, 0);
2209           head = &t->head;
2210         }
2211
2212       if (*head == NULL)
2213         tail = NULL;
2214       else
2215         {
2216           tail = *head;
2217           while (tail->common_next)
2218             tail = tail->common_next;
2219         }
2220
2221       /* Grab the list of symbols.  */
2222       if (gfc_match_eos () == MATCH_YES)
2223         goto done;
2224
2225       for (;;)
2226         {
2227           m = gfc_match_symbol (&sym, 0);
2228           if (m == MATCH_ERROR)
2229             goto cleanup;
2230           if (m == MATCH_NO)
2231             goto syntax;
2232
2233           if (sym->attr.in_common)
2234             {
2235               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2236                          sym->name);
2237               goto cleanup;
2238             }
2239
2240           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2241             goto cleanup;
2242
2243           if (sym->value != NULL
2244               && (name[0] == '\0' || !sym->attr.data))
2245             {
2246               if (name[0] == '\0')
2247                 gfc_error ("Previously initialized symbol '%s' in "
2248                            "blank COMMON block at %C", sym->name);
2249               else
2250                 gfc_error ("Previously initialized symbol '%s' in "
2251                            "COMMON block '%s' at %C", sym->name, name);
2252               goto cleanup;
2253             }
2254
2255           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2256             goto cleanup;
2257
2258           /* Derived type names must have the SEQUENCE attribute.  */
2259           if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2260             {
2261               gfc_error
2262                 ("Derived type variable in COMMON at %C does not have the "
2263                  "SEQUENCE attribute");
2264               goto cleanup;
2265             }
2266
2267           if (tail != NULL)
2268             tail->common_next = sym;
2269           else
2270             *head = sym;
2271
2272           tail = sym;
2273
2274           /* Deal with an optional array specification after the
2275              symbol name.  */
2276           m = gfc_match_array_spec (&as);
2277           if (m == MATCH_ERROR)
2278             goto cleanup;
2279
2280           if (m == MATCH_YES)
2281             {
2282               if (as->type != AS_EXPLICIT)
2283                 {
2284                   gfc_error
2285                     ("Array specification for symbol '%s' in COMMON at %C "
2286                      "must be explicit", sym->name);
2287                   goto cleanup;
2288                 }
2289
2290               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2291                 goto cleanup;
2292
2293               if (sym->attr.pointer)
2294                 {
2295                   gfc_error
2296                     ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2297                      sym->name);
2298                   goto cleanup;
2299                 }
2300
2301               sym->as = as;
2302               as = NULL;
2303             }
2304
2305           gfc_gobble_whitespace ();
2306           if (gfc_match_eos () == MATCH_YES)
2307             goto done;
2308           if (gfc_peek_char () == '/')
2309             break;
2310           if (gfc_match_char (',') != MATCH_YES)
2311             goto syntax;
2312           gfc_gobble_whitespace ();
2313           if (gfc_peek_char () == '/')
2314             break;
2315         }
2316     }
2317
2318 done:
2319   return MATCH_YES;
2320
2321 syntax:
2322   gfc_syntax_error (ST_COMMON);
2323
2324 cleanup:
2325   if (old_blank_common)
2326     old_blank_common->common_next = NULL;
2327   else
2328     gfc_current_ns->blank_common.head = NULL;
2329   gfc_free_array_spec (as);
2330   return MATCH_ERROR;
2331 }
2332
2333
2334 /* Match a BLOCK DATA program unit.  */
2335
2336 match
2337 gfc_match_block_data (void)
2338 {
2339   char name[GFC_MAX_SYMBOL_LEN + 1];
2340   gfc_symbol *sym;
2341   match m;
2342
2343   if (gfc_match_eos () == MATCH_YES)
2344     {
2345       gfc_new_block = NULL;
2346       return MATCH_YES;
2347     }
2348
2349   m = gfc_match ("% %n%t", name);
2350   if (m != MATCH_YES)
2351     return MATCH_ERROR;
2352
2353   if (gfc_get_symbol (name, NULL, &sym))
2354     return MATCH_ERROR;
2355
2356   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2357     return MATCH_ERROR;
2358
2359   gfc_new_block = sym;
2360
2361   return MATCH_YES;
2362 }
2363
2364
2365 /* Free a namelist structure.  */
2366
2367 void
2368 gfc_free_namelist (gfc_namelist * name)
2369 {
2370   gfc_namelist *n;
2371
2372   for (; name; name = n)
2373     {
2374       n = name->next;
2375       gfc_free (name);
2376     }
2377 }
2378
2379
2380 /* Match a NAMELIST statement.  */
2381
2382 match
2383 gfc_match_namelist (void)
2384 {
2385   gfc_symbol *group_name, *sym;
2386   gfc_namelist *nl;
2387   match m, m2;
2388
2389   m = gfc_match (" / %s /", &group_name);
2390   if (m == MATCH_NO)
2391     goto syntax;
2392   if (m == MATCH_ERROR)
2393     goto error;
2394
2395   for (;;)
2396     {
2397       if (group_name->ts.type != BT_UNKNOWN)
2398         {
2399           gfc_error
2400             ("Namelist group name '%s' at %C already has a basic type "
2401              "of %s", group_name->name, gfc_typename (&group_name->ts));
2402           return MATCH_ERROR;
2403         }
2404
2405       if (group_name->attr.flavor != FL_NAMELIST
2406           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2407                              group_name->name, NULL) == FAILURE)
2408         return MATCH_ERROR;
2409
2410       for (;;)
2411         {
2412           m = gfc_match_symbol (&sym, 1);
2413           if (m == MATCH_NO)
2414             goto syntax;
2415           if (m == MATCH_ERROR)
2416             goto error;
2417
2418           if (sym->attr.in_namelist == 0
2419               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
2420             goto error;
2421
2422           nl = gfc_get_namelist ();
2423           nl->sym = sym;
2424
2425           if (group_name->namelist == NULL)
2426             group_name->namelist = group_name->namelist_tail = nl;
2427           else
2428             {
2429               group_name->namelist_tail->next = nl;
2430               group_name->namelist_tail = nl;
2431             }
2432
2433           if (gfc_match_eos () == MATCH_YES)
2434             goto done;
2435
2436           m = gfc_match_char (',');
2437
2438           if (gfc_match_char ('/') == MATCH_YES)
2439             {
2440               m2 = gfc_match (" %s /", &group_name);
2441               if (m2 == MATCH_YES)
2442                 break;
2443               if (m2 == MATCH_ERROR)
2444                 goto error;
2445               goto syntax;
2446             }
2447
2448           if (m != MATCH_YES)
2449             goto syntax;
2450         }
2451     }
2452
2453 done:
2454   return MATCH_YES;
2455
2456 syntax:
2457   gfc_syntax_error (ST_NAMELIST);
2458
2459 error:
2460   return MATCH_ERROR;
2461 }
2462
2463
2464 /* Match a MODULE statement.  */
2465
2466 match
2467 gfc_match_module (void)
2468 {
2469   match m;
2470
2471   m = gfc_match (" %s%t", &gfc_new_block);
2472   if (m != MATCH_YES)
2473     return m;
2474
2475   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2476                       gfc_new_block->name, NULL) == FAILURE)
2477     return MATCH_ERROR;
2478
2479   return MATCH_YES;
2480 }
2481
2482
2483 /* Free equivalence sets and lists.  Recursively is the easiest way to
2484    do this.  */
2485
2486 void
2487 gfc_free_equiv (gfc_equiv * eq)
2488 {
2489
2490   if (eq == NULL)
2491     return;
2492
2493   gfc_free_equiv (eq->eq);
2494   gfc_free_equiv (eq->next);
2495
2496   gfc_free_expr (eq->expr);
2497   gfc_free (eq);
2498 }
2499
2500
2501 /* Match an EQUIVALENCE statement.  */
2502
2503 match
2504 gfc_match_equivalence (void)
2505 {
2506   gfc_equiv *eq, *set, *tail;
2507   gfc_ref *ref;
2508   match m;
2509
2510   tail = NULL;
2511
2512   for (;;)
2513     {
2514       eq = gfc_get_equiv ();
2515       if (tail == NULL)
2516         tail = eq;
2517
2518       eq->next = gfc_current_ns->equiv;
2519       gfc_current_ns->equiv = eq;
2520
2521       if (gfc_match_char ('(') != MATCH_YES)
2522         goto syntax;
2523
2524       set = eq;
2525
2526       for (;;)
2527         {
2528           m = gfc_match_variable (&set->expr, 1);
2529           if (m == MATCH_ERROR)
2530             goto cleanup;
2531           if (m == MATCH_NO)
2532             goto syntax;
2533
2534           for (ref = set->expr->ref; ref; ref = ref->next)
2535             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2536               {
2537                 gfc_error
2538                   ("Array reference in EQUIVALENCE at %C cannot be an "
2539                    "array section");
2540                 goto cleanup;
2541               }
2542
2543           if (gfc_match_char (')') == MATCH_YES)
2544             break;
2545           if (gfc_match_char (',') != MATCH_YES)
2546             goto syntax;
2547
2548           set->eq = gfc_get_equiv ();
2549           set = set->eq;
2550         }
2551
2552       if (gfc_match_eos () == MATCH_YES)
2553         break;
2554       if (gfc_match_char (',') != MATCH_YES)
2555         goto syntax;
2556     }
2557
2558   return MATCH_YES;
2559
2560 syntax:
2561   gfc_syntax_error (ST_EQUIVALENCE);
2562
2563 cleanup:
2564   eq = tail->next;
2565   tail->next = NULL;
2566
2567   gfc_free_equiv (gfc_current_ns->equiv);
2568   gfc_current_ns->equiv = eq;
2569
2570   return MATCH_ERROR;
2571 }
2572
2573
2574 /* Match a statement function declaration.  It is so easy to match
2575    non-statement function statements with a MATCH_ERROR as opposed to
2576    MATCH_NO that we suppress error message in most cases.  */
2577
2578 match
2579 gfc_match_st_function (void)
2580 {
2581   gfc_error_buf old_error;
2582   gfc_symbol *sym;
2583   gfc_expr *expr;
2584   match m;
2585
2586   m = gfc_match_symbol (&sym, 0);
2587   if (m != MATCH_YES)
2588     return m;
2589
2590   gfc_push_error (&old_error);
2591
2592   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
2593                          sym->name, NULL) == FAILURE)
2594     goto undo_error;
2595
2596   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2597     goto undo_error;
2598
2599   m = gfc_match (" = %e%t", &expr);
2600   if (m == MATCH_NO)
2601     goto undo_error;
2602   if (m == MATCH_ERROR)
2603     return m;
2604
2605   sym->value = expr;
2606
2607   return MATCH_YES;
2608
2609 undo_error:
2610   gfc_pop_error (&old_error);
2611   return MATCH_NO;
2612 }
2613
2614
2615 /***************** SELECT CASE subroutines ******************/
2616
2617 /* Free a single case structure.  */
2618
2619 static void
2620 free_case (gfc_case * p)
2621 {
2622   if (p->low == p->high)
2623     p->high = NULL;
2624   gfc_free_expr (p->low);
2625   gfc_free_expr (p->high);
2626   gfc_free (p);
2627 }
2628
2629
2630 /* Free a list of case structures.  */
2631
2632 void
2633 gfc_free_case_list (gfc_case * p)
2634 {
2635   gfc_case *q;
2636
2637   for (; p; p = q)
2638     {
2639       q = p->next;
2640       free_case (p);
2641     }
2642 }
2643
2644
2645 /* Match a single case selector.  */
2646
2647 static match
2648 match_case_selector (gfc_case ** cp)
2649 {
2650   gfc_case *c;
2651   match m;
2652
2653   c = gfc_get_case ();
2654   c->where = gfc_current_locus;
2655
2656   if (gfc_match_char (':') == MATCH_YES)
2657     {
2658       m = gfc_match_init_expr (&c->high);
2659       if (m == MATCH_NO)
2660         goto need_expr;
2661       if (m == MATCH_ERROR)
2662         goto cleanup;
2663     }
2664
2665   else
2666     {
2667       m = gfc_match_init_expr (&c->low);
2668       if (m == MATCH_ERROR)
2669         goto cleanup;
2670       if (m == MATCH_NO)
2671         goto need_expr;
2672
2673       /* If we're not looking at a ':' now, make a range out of a single
2674          target.  Else get the upper bound for the case range.  */
2675       if (gfc_match_char (':') != MATCH_YES)
2676         c->high = c->low;
2677       else
2678         {
2679           m = gfc_match_init_expr (&c->high);
2680           if (m == MATCH_ERROR)
2681             goto cleanup;
2682           /* MATCH_NO is fine.  It's OK if nothing is there!  */
2683         }
2684     }
2685
2686   *cp = c;
2687   return MATCH_YES;
2688
2689 need_expr:
2690   gfc_error ("Expected initialization expression in CASE at %C");
2691
2692 cleanup:
2693   free_case (c);
2694   return MATCH_ERROR;
2695 }
2696
2697
2698 /* Match the end of a case statement.  */
2699
2700 static match
2701 match_case_eos (void)
2702 {
2703   char name[GFC_MAX_SYMBOL_LEN + 1];
2704   match m;
2705
2706   if (gfc_match_eos () == MATCH_YES)
2707     return MATCH_YES;
2708
2709   gfc_gobble_whitespace ();
2710
2711   m = gfc_match_name (name);
2712   if (m != MATCH_YES)
2713     return m;
2714
2715   if (strcmp (name, gfc_current_block ()->name) != 0)
2716     {
2717       gfc_error ("Expected case name of '%s' at %C",
2718                  gfc_current_block ()->name);
2719       return MATCH_ERROR;
2720     }
2721
2722   return gfc_match_eos ();
2723 }
2724
2725
2726 /* Match a SELECT statement.  */
2727
2728 match
2729 gfc_match_select (void)
2730 {
2731   gfc_expr *expr;
2732   match m;
2733
2734   m = gfc_match_label ();
2735   if (m == MATCH_ERROR)
2736     return m;
2737
2738   m = gfc_match (" select case ( %e )%t", &expr);
2739   if (m != MATCH_YES)
2740     return m;
2741
2742   new_st.op = EXEC_SELECT;
2743   new_st.expr = expr;
2744
2745   return MATCH_YES;
2746 }
2747
2748
2749 /* Match a CASE statement.  */
2750
2751 match
2752 gfc_match_case (void)
2753 {
2754   gfc_case *c, *head, *tail;
2755   match m;
2756
2757   head = tail = NULL;
2758
2759   if (gfc_current_state () != COMP_SELECT)
2760     {
2761       gfc_error ("Unexpected CASE statement at %C");
2762       return MATCH_ERROR;
2763     }
2764
2765   if (gfc_match ("% default") == MATCH_YES)
2766     {
2767       m = match_case_eos ();
2768       if (m == MATCH_NO)
2769         goto syntax;
2770       if (m == MATCH_ERROR)
2771         goto cleanup;
2772
2773       new_st.op = EXEC_SELECT;
2774       c = gfc_get_case ();
2775       c->where = gfc_current_locus;
2776       new_st.ext.case_list = c;
2777       return MATCH_YES;
2778     }
2779
2780   if (gfc_match_char ('(') != MATCH_YES)
2781     goto syntax;
2782
2783   for (;;)
2784     {
2785       if (match_case_selector (&c) == MATCH_ERROR)
2786         goto cleanup;
2787
2788       if (head == NULL)
2789         head = c;
2790       else
2791         tail->next = c;
2792
2793       tail = c;
2794
2795       if (gfc_match_char (')') == MATCH_YES)
2796         break;
2797       if (gfc_match_char (',') != MATCH_YES)
2798         goto syntax;
2799     }
2800
2801   m = match_case_eos ();
2802   if (m == MATCH_NO)
2803     goto syntax;
2804   if (m == MATCH_ERROR)
2805     goto cleanup;
2806
2807   new_st.op = EXEC_SELECT;
2808   new_st.ext.case_list = head;
2809
2810   return MATCH_YES;
2811
2812 syntax:
2813   gfc_error ("Syntax error in CASE-specification at %C");
2814
2815 cleanup:
2816   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
2817   return MATCH_ERROR;
2818 }
2819
2820 /********************* WHERE subroutines ********************/
2821
2822 /* Match the rest of a simple WHERE statement that follows an IF statement.
2823  */
2824
2825 static match
2826 match_simple_where (void)
2827 {
2828   gfc_expr *expr;
2829   gfc_code *c;
2830   match m;
2831
2832   m = gfc_match (" ( %e )", &expr);
2833   if (m != MATCH_YES)
2834     return m;
2835
2836   m = gfc_match_assignment ();
2837   if (m == MATCH_NO)
2838     goto syntax;
2839   if (m == MATCH_ERROR)
2840     goto cleanup;
2841
2842   if (gfc_match_eos () != MATCH_YES)
2843     goto syntax;
2844
2845   c = gfc_get_code ();
2846
2847   c->op = EXEC_WHERE;
2848   c->expr = expr;
2849   c->next = gfc_get_code ();
2850
2851   *c->next = new_st;
2852   gfc_clear_new_st ();
2853
2854   new_st.op = EXEC_WHERE;
2855   new_st.block = c;
2856
2857   return MATCH_YES;
2858
2859 syntax:
2860   gfc_syntax_error (ST_WHERE);
2861
2862 cleanup:
2863   gfc_free_expr (expr);
2864   return MATCH_ERROR;
2865 }
2866
2867 /* Match a WHERE statement.  */
2868
2869 match
2870 gfc_match_where (gfc_statement * st)
2871 {
2872   gfc_expr *expr;
2873   match m0, m;
2874   gfc_code *c;
2875
2876   m0 = gfc_match_label ();
2877   if (m0 == MATCH_ERROR)
2878     return m0;
2879
2880   m = gfc_match (" where ( %e )", &expr);
2881   if (m != MATCH_YES)
2882     return m;
2883
2884   if (gfc_match_eos () == MATCH_YES)
2885     {
2886       *st = ST_WHERE_BLOCK;
2887
2888       new_st.op = EXEC_WHERE;
2889       new_st.expr = expr;
2890       return MATCH_YES;
2891     }
2892
2893   m = gfc_match_assignment ();
2894   if (m == MATCH_NO)
2895     gfc_syntax_error (ST_WHERE);
2896
2897   if (m != MATCH_YES)
2898     {
2899       gfc_free_expr (expr);
2900       return MATCH_ERROR;
2901     }
2902
2903   /* We've got a simple WHERE statement.  */
2904   *st = ST_WHERE;
2905   c = gfc_get_code ();
2906
2907   c->op = EXEC_WHERE;
2908   c->expr = expr;
2909   c->next = gfc_get_code ();
2910
2911   *c->next = new_st;
2912   gfc_clear_new_st ();
2913
2914   new_st.op = EXEC_WHERE;
2915   new_st.block = c;
2916
2917   return MATCH_YES;
2918 }
2919
2920
2921 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
2922    new_st if successful.  */
2923
2924 match
2925 gfc_match_elsewhere (void)
2926 {
2927   char name[GFC_MAX_SYMBOL_LEN + 1];
2928   gfc_expr *expr;
2929   match m;
2930
2931   if (gfc_current_state () != COMP_WHERE)
2932     {
2933       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
2934       return MATCH_ERROR;
2935     }
2936
2937   expr = NULL;
2938
2939   if (gfc_match_char ('(') == MATCH_YES)
2940     {
2941       m = gfc_match_expr (&expr);
2942       if (m == MATCH_NO)
2943         goto syntax;
2944       if (m == MATCH_ERROR)
2945         return MATCH_ERROR;
2946
2947       if (gfc_match_char (')') != MATCH_YES)
2948         goto syntax;
2949     }
2950
2951   if (gfc_match_eos () != MATCH_YES)
2952     {                           /* Better be a name at this point */
2953       m = gfc_match_name (name);
2954       if (m == MATCH_NO)
2955         goto syntax;
2956       if (m == MATCH_ERROR)
2957         goto cleanup;
2958
2959       if (gfc_match_eos () != MATCH_YES)
2960         goto syntax;
2961
2962       if (strcmp (name, gfc_current_block ()->name) != 0)
2963         {
2964           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
2965                      name, gfc_current_block ()->name);
2966           goto cleanup;
2967         }
2968     }
2969
2970   new_st.op = EXEC_WHERE;
2971   new_st.expr = expr;
2972   return MATCH_YES;
2973
2974 syntax:
2975   gfc_syntax_error (ST_ELSEWHERE);
2976
2977 cleanup:
2978   gfc_free_expr (expr);
2979   return MATCH_ERROR;
2980 }
2981
2982
2983 /******************** FORALL subroutines ********************/
2984
2985 /* Free a list of FORALL iterators.  */
2986
2987 void
2988 gfc_free_forall_iterator (gfc_forall_iterator * iter)
2989 {
2990   gfc_forall_iterator *next;
2991
2992   while (iter)
2993     {
2994       next = iter->next;
2995
2996       gfc_free_expr (iter->var);
2997       gfc_free_expr (iter->start);
2998       gfc_free_expr (iter->end);
2999       gfc_free_expr (iter->stride);
3000
3001       gfc_free (iter);
3002       iter = next;
3003     }
3004 }
3005
3006
3007 /* Match an iterator as part of a FORALL statement.  The format is:
3008
3009      <var> = <start>:<end>[:<stride>][, <scalar mask>]  */
3010
3011 static match
3012 match_forall_iterator (gfc_forall_iterator ** result)
3013 {
3014   gfc_forall_iterator *iter;
3015   locus where;
3016   match m;
3017
3018   where = gfc_current_locus;
3019   iter = gfc_getmem (sizeof (gfc_forall_iterator));
3020
3021   m = gfc_match_variable (&iter->var, 0);
3022   if (m != MATCH_YES)
3023     goto cleanup;
3024
3025   if (gfc_match_char ('=') != MATCH_YES)
3026     {
3027       m = MATCH_NO;
3028       goto cleanup;
3029     }
3030
3031   m = gfc_match_expr (&iter->start);
3032   if (m == MATCH_NO)
3033     goto syntax;
3034   if (m == MATCH_ERROR)
3035     goto cleanup;
3036
3037   if (gfc_match_char (':') != MATCH_YES)
3038     goto syntax;
3039
3040   m = gfc_match_expr (&iter->end);
3041   if (m == MATCH_NO)
3042     goto syntax;
3043   if (m == MATCH_ERROR)
3044     goto cleanup;
3045
3046   if (gfc_match_char (':') == MATCH_NO)
3047     iter->stride = gfc_int_expr (1);
3048   else
3049     {
3050       m = gfc_match_expr (&iter->stride);
3051       if (m == MATCH_NO)
3052         goto syntax;
3053       if (m == MATCH_ERROR)
3054         goto cleanup;
3055     }
3056
3057   *result = iter;
3058   return MATCH_YES;
3059
3060 syntax:
3061   gfc_error ("Syntax error in FORALL iterator at %C");
3062   m = MATCH_ERROR;
3063
3064 cleanup:
3065   gfc_current_locus = where;
3066   gfc_free_forall_iterator (iter);
3067   return m;
3068 }
3069
3070
3071 /* Match the header of a FORALL statement.  */
3072
3073 static match
3074 match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
3075 {
3076   gfc_forall_iterator *head, *tail, *new;
3077   match m;
3078
3079   gfc_gobble_whitespace ();
3080
3081   head = tail = NULL;
3082   *mask = NULL;
3083
3084   if (gfc_match_char ('(') != MATCH_YES)
3085     return MATCH_NO;
3086
3087   m = match_forall_iterator (&new);
3088   if (m == MATCH_ERROR)
3089     goto cleanup;
3090   if (m == MATCH_NO)
3091     goto syntax;
3092
3093   head = tail = new;
3094
3095   for (;;)
3096     {
3097       if (gfc_match_char (',') != MATCH_YES)
3098         break;
3099
3100       m = match_forall_iterator (&new);
3101       if (m == MATCH_ERROR)
3102         goto cleanup;
3103       if (m == MATCH_YES)
3104         {
3105           tail->next = new;
3106           tail = new;
3107           continue;
3108         }
3109
3110       /* Have to have a mask expression */
3111
3112       m = gfc_match_expr (mask);
3113       if (m == MATCH_NO)
3114         goto syntax;
3115       if (m == MATCH_ERROR)
3116         goto cleanup;
3117
3118       break;
3119     }
3120
3121   if (gfc_match_char (')') == MATCH_NO)
3122     goto syntax;
3123
3124   *phead = head;
3125   return MATCH_YES;
3126
3127 syntax:
3128   gfc_syntax_error (ST_FORALL);
3129
3130 cleanup:
3131   gfc_free_expr (*mask);
3132   gfc_free_forall_iterator (head);
3133
3134   return MATCH_ERROR;
3135 }
3136
3137 /* Match the rest of a simple FORALL statement that follows an IF statement.
3138  */
3139
3140 static match
3141 match_simple_forall (void)
3142 {
3143   gfc_forall_iterator *head;
3144   gfc_expr *mask;
3145   gfc_code *c;
3146   match m;
3147
3148   mask = NULL;
3149   head = NULL;
3150   c = NULL;
3151
3152   m = match_forall_header (&head, &mask);
3153
3154   if (m == MATCH_NO)
3155     goto syntax;
3156   if (m != MATCH_YES)
3157     goto cleanup;
3158
3159   m = gfc_match_assignment ();
3160
3161   if (m == MATCH_ERROR)
3162     goto cleanup;
3163   if (m == MATCH_NO)
3164     {
3165       m = gfc_match_pointer_assignment ();
3166       if (m == MATCH_ERROR)
3167         goto cleanup;
3168       if (m == MATCH_NO)
3169         goto syntax;
3170     }
3171
3172   c = gfc_get_code ();
3173   *c = new_st;
3174   c->loc = gfc_current_locus;
3175
3176   if (gfc_match_eos () != MATCH_YES)
3177     goto syntax;
3178
3179   gfc_clear_new_st ();
3180   new_st.op = EXEC_FORALL;
3181   new_st.expr = mask;
3182   new_st.ext.forall_iterator = head;
3183   new_st.block = gfc_get_code ();
3184
3185   new_st.block->op = EXEC_FORALL;
3186   new_st.block->next = c;
3187
3188   return MATCH_YES;
3189
3190 syntax:
3191   gfc_syntax_error (ST_FORALL);
3192
3193 cleanup:
3194   gfc_free_forall_iterator (head);
3195   gfc_free_expr (mask);
3196
3197   return MATCH_ERROR;
3198 }
3199
3200
3201 /* Match a FORALL statement.  */
3202
3203 match
3204 gfc_match_forall (gfc_statement * st)
3205 {
3206   gfc_forall_iterator *head;
3207   gfc_expr *mask;
3208   gfc_code *c;
3209   match m0, m;
3210
3211   head = NULL;
3212   mask = NULL;
3213   c = NULL;
3214
3215   m0 = gfc_match_label ();
3216   if (m0 == MATCH_ERROR)
3217     return MATCH_ERROR;
3218
3219   m = gfc_match (" forall");
3220   if (m != MATCH_YES)
3221     return m;
3222
3223   m = match_forall_header (&head, &mask);
3224   if (m == MATCH_ERROR)
3225     goto cleanup;
3226   if (m == MATCH_NO)
3227     goto syntax;
3228
3229   if (gfc_match_eos () == MATCH_YES)
3230     {
3231       *st = ST_FORALL_BLOCK;
3232
3233       new_st.op = EXEC_FORALL;
3234       new_st.expr = mask;
3235       new_st.ext.forall_iterator = head;
3236
3237       return MATCH_YES;
3238     }
3239
3240   m = gfc_match_assignment ();
3241   if (m == MATCH_ERROR)
3242     goto cleanup;
3243   if (m == MATCH_NO)
3244     {
3245       m = gfc_match_pointer_assignment ();
3246       if (m == MATCH_ERROR)
3247         goto cleanup;
3248       if (m == MATCH_NO)
3249         goto syntax;
3250     }
3251
3252   c = gfc_get_code ();
3253   *c = new_st;
3254
3255   if (gfc_match_eos () != MATCH_YES)
3256     goto syntax;
3257
3258   gfc_clear_new_st ();
3259   new_st.op = EXEC_FORALL;
3260   new_st.expr = mask;
3261   new_st.ext.forall_iterator = head;
3262   new_st.block = gfc_get_code ();
3263
3264   new_st.block->op = EXEC_FORALL;
3265   new_st.block->next = c;
3266
3267   *st = ST_FORALL;
3268   return MATCH_YES;
3269
3270 syntax:
3271   gfc_syntax_error (ST_FORALL);
3272
3273 cleanup:
3274   gfc_free_forall_iterator (head);
3275   gfc_free_expr (mask);
3276   gfc_free_statements (c);
3277   return MATCH_NO;
3278 }