gcc/fortran/primary.c

   1 /* Primary expression subroutines
   2    Copyright (C) 2000, 2001, 2002, 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 "arith.h"
  29 #include "match.h"
  30 #include "parse.h"
  31
  32 /* Matches a kind-parameter expression, which is either a named
  33    symbolic constant or a nonnegative integer constant.  If
  34    successful, sets the kind value to the correct integer.  */
  35
  36 static match
  37 match_kind_param (int *kind)
  38 {
  39   char name[GFC_MAX_SYMBOL_LEN + 1];
  40   gfc_symbol *sym;
  41   const char *p;
  42   match m;
  43
  44   m = gfc_match_small_literal_int (kind);
  45   if (m != MATCH_NO)
  46     return m;
  47
  48   m = gfc_match_name (name);
  49   if (m != MATCH_YES)
  50     return m;
  51
  52   if (gfc_find_symbol (name, NULL, 1, &sym))
  53     return MATCH_ERROR;
  54
  55   if (sym == NULL)
  56     return MATCH_NO;
  57
  58   if (sym->attr.flavor != FL_PARAMETER)
  59     return MATCH_NO;
  60
  61   p = gfc_extract_int (sym->value, kind);
  62   if (p != NULL)
  63     return MATCH_NO;
  64
  65   if (*kind < 0)
  66     return MATCH_NO;
  67
  68   return MATCH_YES;
  69 }
  70
  71
  72 /* Get a trailing kind-specification for non-character variables.
  73    Returns:
  74       the integer kind value or:
  75       -1 if an error was generated
  76       -2 if no kind was found */
  77
  78 static int
  79 get_kind (void)
  80 {
  81   int kind;
  82   match m;
  83
  84   if (gfc_match_char ('_') != MATCH_YES)
  85     return -2;
  86
  87   m = match_kind_param (&kind);
  88   if (m == MATCH_NO)
  89     gfc_error ("Missing kind-parameter at %C");
  90
  91   return (m == MATCH_YES) ? kind : -1;
  92 }
  93
  94
  95 /* Given a character and a radix, see if the character is a valid
  96    digit in that radix.  */
  97
  98 static int
  99 check_digit (int c, int radix)
 100 {
 101   int r;
 102
 103   switch (radix)
 104     {
 105     case 2:
 106       r = ('0' <= c && c <= '1');
 107       break;
 108
 109     case 8:
 110       r = ('0' <= c && c <= '7');
 111       break;
 112
 113     case 10:
 114       r = ('0' <= c && c <= '9');
 115       break;
 116
 117     case 16:
 118       r = ISXDIGIT (c);
 119       break;
 120
 121     default:
 122       gfc_internal_error ("check_digit(): bad radix");
 123     }
 124
 125   return r;
 126 }
 127
 128
 129 /* Match the digit string part of an integer if signflag is not set,
 130    the signed digit string part if signflag is set.  If the buffer
 131    is NULL, we just count characters for the resolution pass.  Returns
 132    the number of characters matched, -1 for no match.  */
 133
 134 static int
 135 match_digits (int signflag, int radix, char *buffer)
 136 {
 137   locus old_loc;
 138   int length, c;
 139
 140   length = 0;
 141   c = gfc_next_char ();
 142
 143   if (signflag && (c == '+' || c == '-'))
 144     {
 145       if (buffer != NULL)
 146         *buffer++ = c;
 147       gfc_gobble_whitespace ();
 148       c = gfc_next_char ();
 149       length++;
 150     }
 151
 152   if (!check_digit (c, radix))
 153     return -1;
 154
 155   length++;
 156   if (buffer != NULL)
 157     *buffer++ = c;
 158
 159   for (;;)
 160     {
 161       old_loc = gfc_current_locus;
 162       c = gfc_next_char ();
 163
 164       if (!check_digit (c, radix))
 165         break;
 166
 167       if (buffer != NULL)
 168         *buffer++ = c;
 169       length++;
 170     }
 171
 172   gfc_current_locus = old_loc;
 173
 174   return length;
 175 }
 176
 177
 178 /* Match an integer (digit string and optional kind).
 179    A sign will be accepted if signflag is set.  */
 180
 181 static match
 182 match_integer_constant (gfc_expr ** result, int signflag)
 183 {
 184   int length, kind;
 185   locus old_loc;
 186   char *buffer;
 187   gfc_expr *e;
 188
 189   old_loc = gfc_current_locus;
 190   gfc_gobble_whitespace ();
 191
 192   length = match_digits (signflag, 10, NULL);
 193   gfc_current_locus = old_loc;
 194   if (length == -1)
 195     return MATCH_NO;
 196
 197   buffer = alloca (length + 1);
 198   memset (buffer, '\0', length + 1);
 199
 200   gfc_gobble_whitespace ();
 201
 202   match_digits (signflag, 10, buffer);
 203
 204   kind = get_kind ();
 205   if (kind == -2)
 206     kind = gfc_default_integer_kind;
 207   if (kind == -1)
 208     return MATCH_ERROR;
 209
 210   if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
 211     {
 212       gfc_error ("Integer kind %d at %C not available", kind);
 213       return MATCH_ERROR;
 214     }
 215
 216   e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
 217
 218   if (gfc_range_check (e) != ARITH_OK)
 219     {
 220       gfc_error ("Integer too big for its kind at %C");
 221
 222       gfc_free_expr (e);
 223       return MATCH_ERROR;
 224     }
 225
 226   *result = e;
 227   return MATCH_YES;
 228 }
 229
 230
 231 /* Match a binary, octal or hexadecimal constant that can be found in
 232    a DATA statement.  */
 233
 234 static match
 235 match_boz_constant (gfc_expr ** result)
 236 {
 237   int radix, delim, length, x_hex, kind;
 238   locus old_loc;
 239   char *buffer;
 240   gfc_expr *e;
 241   const char *rname;
 242
 243   old_loc = gfc_current_locus;
 244   gfc_gobble_whitespace ();
 245
 246   x_hex = 0;
 247   switch (gfc_next_char ())
 248     {
 249     case 'b':
 250       radix = 2;
 251       rname = "binary";
 252       break;
 253     case 'o':
 254       radix = 8;
 255       rname = "octal";
 256       break;
 257     case 'x':
 258       x_hex = 1;
 259       /* Fall through.  */
 260     case 'z':
 261       radix = 16;
 262       rname = "hexadecimal";
 263       break;
 264     default:
 265       goto backup;
 266     }
 267
 268   /* No whitespace allowed here.  */
 269
 270   delim = gfc_next_char ();
 271   if (delim != '\'' && delim != '\"')
 272     goto backup;
 273
 274   if (x_hex && pedantic
 275       && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
 276                           "constant at %C uses non-standard syntax.")
 277           == FAILURE))
 278       return MATCH_ERROR;
 279
 280   old_loc = gfc_current_locus;
 281
 282   length = match_digits (0, radix, NULL);
 283   if (length == -1)
 284     {
 285       gfc_error ("Empty set of digits in %s constants at %C", rname);
 286       return MATCH_ERROR;
 287     }
 288
 289   if (gfc_next_char () != delim)
 290     {
 291       gfc_error ("Illegal character in %s constant at %C.", rname);
 292       return MATCH_ERROR;
 293     }
 294
 295   gfc_current_locus = old_loc;
 296
 297   buffer = alloca (length + 1);
 298   memset (buffer, '\0', length + 1);
 299
 300   match_digits (0, radix, buffer);
 301   gfc_next_char ();  /* Eat delimiter.  */
 302
 303   kind = get_kind ();
 304   if (kind == -1)
 305     return MATCH_ERROR;
 306   if (kind == -2)
 307     kind = gfc_default_integer_kind;
 308   else if (pedantic
 309            && (gfc_notify_std (GFC_STD_GNU, "Extension: Kind parameter "
 310                                "suffix to boz literal constant at %C.")
 311                == FAILURE))
 312     return MATCH_ERROR;
 313
 314   e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
 315
 316   if (gfc_range_check (e) != ARITH_OK)
 317     {
 318       gfc_error ("Integer too big for integer kind %i at %C", kind);
 319
 320       gfc_free_expr (e);
 321       return MATCH_ERROR;
 322     }
 323
 324   *result = e;
 325   return MATCH_YES;
 326
 327 backup:
 328   gfc_current_locus = old_loc;
 329   return MATCH_NO;
 330 }
 331
 332
 333 /* Match a real constant of some sort.  Allow a signed constant if signflag
 334    is nonzero.  Allow integer constants if allow_int is true.  */
 335
 336 static match
 337 match_real_constant (gfc_expr ** result, int signflag)
 338 {
 339   int kind, c, count, seen_dp, seen_digits, exp_char;
 340   locus old_loc, temp_loc;
 341   char *p, *buffer;
 342   gfc_expr *e;
 343   bool negate;
 344
 345   old_loc = gfc_current_locus;
 346   gfc_gobble_whitespace ();
 347
 348   e = NULL;
 349
 350   count = 0;
 351   seen_dp = 0;
 352   seen_digits = 0;
 353   exp_char = ' ';
 354   negate = FALSE;
 355
 356   c = gfc_next_char ();
 357   if (signflag && (c == '+' || c == '-'))
 358     {
 359       if (c == '-')
 360         negate = TRUE;
 361
 362       gfc_gobble_whitespace ();
 363       c = gfc_next_char ();
 364     }
 365
 366   /* Scan significand.  */
 367   for (;; c = gfc_next_char (), count++)
 368     {
 369       if (c == '.')
 370         {
 371           if (seen_dp)
 372             goto done;
 373
 374           /* Check to see if "." goes with a following operator like ".eq.".  */
 375           temp_loc = gfc_current_locus;
 376           c = gfc_next_char ();
 377
 378           if (c == 'e' || c == 'd' || c == 'q')
 379             {
 380               c = gfc_next_char ();
 381               if (c == '.')
 382                 goto done;      /* Operator named .e. or .d.  */
 383             }
 384
 385           if (ISALPHA (c))
 386             goto done;          /* Distinguish 1.e9 from 1.eq.2 */
 387
 388           gfc_current_locus = temp_loc;
 389           seen_dp = 1;
 390           continue;
 391         }
 392
 393       if (ISDIGIT (c))
 394         {
 395           seen_digits = 1;
 396           continue;
 397         }
 398
 399       break;
 400     }
 401
 402   if (!seen_digits
 403       || (c != 'e' && c != 'd' && c != 'q'))
 404     goto done;
 405   exp_char = c;
 406
 407   /* Scan exponent.  */
 408   c = gfc_next_char ();
 409   count++;
 410
 411   if (c == '+' || c == '-')
 412     {                           /* optional sign */
 413       c = gfc_next_char ();
 414       count++;
 415     }
 416
 417   if (!ISDIGIT (c))
 418     {
 419       gfc_error ("Missing exponent in real number at %C");
 420       return MATCH_ERROR;
 421     }
 422
 423   while (ISDIGIT (c))
 424     {
 425       c = gfc_next_char ();
 426       count++;
 427     }
 428
 429 done:
 430   /* Check that we have a numeric constant.  */
 431   if (!seen_digits || (!seen_dp && exp_char == ' '))
 432     {
 433       gfc_current_locus = old_loc;
 434       return MATCH_NO;
 435     }
 436
 437   /* Convert the number.  */
 438   gfc_current_locus = old_loc;
 439   gfc_gobble_whitespace ();
 440
 441   buffer = alloca (count + 1);
 442   memset (buffer, '\0', count + 1);
 443
 444   p = buffer;
 445   c = gfc_next_char ();
 446   if (c == '+' || c == '-')
 447     {
 448       gfc_gobble_whitespace ();
 449       c = gfc_next_char ();
 450     }
 451
 452   /* Hack for mpfr_set_str().  */
 453   for (;;)
 454     {
 455       if (c == 'd' || c == 'q')
 456         *p = 'e';
 457       else
 458         *p = c;
 459       p++;
 460       if (--count == 0)
 461         break;
 462
 463       c = gfc_next_char ();
 464     }
 465
 466   kind = get_kind ();
 467   if (kind == -1)
 468     goto cleanup;
 469
 470   switch (exp_char)
 471     {
 472     case 'd':
 473       if (kind != -2)
 474         {
 475           gfc_error
 476             ("Real number at %C has a 'd' exponent and an explicit kind");
 477           goto cleanup;
 478         }
 479       kind = gfc_default_double_kind;
 480       break;
 481
 482     case 'q':
 483       if (kind != -2)
 484         {
 485           gfc_error
 486             ("Real number at %C has a 'q' exponent and an explicit kind");
 487           goto cleanup;
 488         }
 489       kind = gfc_option.q_kind;
 490       break;
 491
 492     default:
 493       if (kind == -2)
 494         kind = gfc_default_real_kind;
 495
 496       if (gfc_validate_kind (BT_REAL, kind, true) < 0)
 497         {
 498           gfc_error ("Invalid real kind %d at %C", kind);
 499           goto cleanup;
 500         }
 501     }
 502
 503   e = gfc_convert_real (buffer, kind, &gfc_current_locus);
 504   if (negate)
 505     mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
 506
 507   switch (gfc_range_check (e))
 508     {
 509     case ARITH_OK:
 510       break;
 511     case ARITH_OVERFLOW:
 512       gfc_error ("Real constant overflows its kind at %C");
 513       goto cleanup;
 514
 515     case ARITH_UNDERFLOW:
 516       if (gfc_option.warn_underflow)
 517         gfc_warning ("Real constant underflows its kind at %C");
 518       mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
 519       break;
 520
 521     default:
 522       gfc_internal_error ("gfc_range_check() returned bad value");
 523     }
 524
 525   *result = e;
 526   return MATCH_YES;
 527
 528 cleanup:
 529   gfc_free_expr (e);
 530   return MATCH_ERROR;
 531 }
 532
 533
 534 /* Match a substring reference.  */
 535
 536 static match
 537 match_substring (gfc_charlen * cl, int init, gfc_ref ** result)
 538 {
 539   gfc_expr *start, *end;
 540   locus old_loc;
 541   gfc_ref *ref;
 542   match m;
 543
 544   start = NULL;
 545   end = NULL;
 546
 547   old_loc = gfc_current_locus;
 548
 549   m = gfc_match_char ('(');
 550   if (m != MATCH_YES)
 551     return MATCH_NO;
 552
 553   if (gfc_match_char (':') != MATCH_YES)
 554     {
 555       if (init)
 556         m = gfc_match_init_expr (&start);
 557       else
 558         m = gfc_match_expr (&start);
 559
 560       if (m != MATCH_YES)
 561         {
 562           m = MATCH_NO;
 563           goto cleanup;
 564         }
 565
 566       m = gfc_match_char (':');
 567       if (m != MATCH_YES)
 568         goto cleanup;
 569     }
 570
 571   if (gfc_match_char (')') != MATCH_YES)
 572     {
 573       if (init)
 574         m = gfc_match_init_expr (&end);
 575       else
 576         m = gfc_match_expr (&end);
 577
 578       if (m == MATCH_NO)
 579         goto syntax;
 580       if (m == MATCH_ERROR)
 581         goto cleanup;
 582
 583       m = gfc_match_char (')');
 584       if (m == MATCH_NO)
 585         goto syntax;
 586     }
 587
 588   /* Optimize away the (:) reference.  */
 589   if (start == NULL && end == NULL)
 590     ref = NULL;
 591   else
 592     {
 593       ref = gfc_get_ref ();
 594
 595       ref->type = REF_SUBSTRING;
 596       if (start == NULL)
 597         start = gfc_int_expr (1);
 598       ref->u.ss.start = start;
 599       if (end == NULL && cl)
 600         end = gfc_copy_expr (cl->length);
 601       ref->u.ss.end = end;
 602       ref->u.ss.length = cl;
 603     }
 604
 605   *result = ref;
 606   return MATCH_YES;
 607
 608 syntax:
 609   gfc_error ("Syntax error in SUBSTRING specification at %C");
 610   m = MATCH_ERROR;
 611
 612 cleanup:
 613   gfc_free_expr (start);
 614   gfc_free_expr (end);
 615
 616   gfc_current_locus = old_loc;
 617   return m;
 618 }
 619
 620
 621 /* Reads the next character of a string constant, taking care to
 622    return doubled delimiters on the input as a single instance of
 623    the delimiter.
 624
 625    Special return values are:
 626      -1   End of the string, as determined by the delimiter
 627      -2   Unterminated string detected
 628
 629    Backslash codes are also expanded at this time.  */
 630
 631 static int
 632 next_string_char (char delimiter)
 633 {
 634   locus old_locus;
 635   int c;
 636
 637   c = gfc_next_char_literal (1);
 638
 639   if (c == '\n')
 640     return -2;
 641
 642   if (c == '\\')
 643     {
 644       old_locus = gfc_current_locus;
 645
 646       switch (gfc_next_char_literal (1))
 647         {
 648         case 'a':
 649           c = '\a';
 650           break;
 651         case 'b':
 652           c = '\b';
 653           break;
 654         case 't':
 655           c = '\t';
 656           break;
 657         case 'f':
 658           c = '\f';
 659           break;
 660         case 'n':
 661           c = '\n';
 662           break;
 663         case 'r':
 664           c = '\r';
 665           break;
 666         case 'v':
 667           c = '\v';
 668           break;
 669         case '\\':
 670           c = '\\';
 671           break;
 672
 673         default:
 674           /* Unknown backslash codes are simply not expanded */
 675           gfc_current_locus = old_locus;
 676           break;
 677         }
 678     }
 679
 680   if (c != delimiter)
 681     return c;
 682
 683   old_locus = gfc_current_locus;
 684   c = gfc_next_char_literal (1);
 685
 686   if (c == delimiter)
 687     return c;
 688   gfc_current_locus = old_locus;
 689
 690   return -1;
 691 }
 692
 693
 694 /* Special case of gfc_match_name() that matches a parameter kind name
 695    before a string constant.  This takes case of the weird but legal
 696    case of: weird case of:
 697
 698      kind_____'string'
 699
 700    where kind____ is a parameter. gfc_match_name() will happily slurp
 701    up all the underscores, which leads to problems.  If we return
 702    MATCH_YES, the parse pointer points to the final underscore, which
 703    is not part of the name.  We never return MATCH_ERROR-- errors in
 704    the name will be detected later.  */
 705
 706 static match
 707 match_charkind_name (char *name)
 708 {
 709   locus old_loc;
 710   char c, peek;
 711   int len;
 712
 713   gfc_gobble_whitespace ();
 714   c = gfc_next_char ();
 715   if (!ISALPHA (c))
 716     return MATCH_NO;
 717
 718   *name++ = c;
 719   len = 1;
 720
 721   for (;;)
 722     {
 723       old_loc = gfc_current_locus;
 724       c = gfc_next_char ();
 725
 726       if (c == '_')
 727         {
 728           peek = gfc_peek_char ();
 729
 730           if (peek == '\'' || peek == '\"')
 731             {
 732               gfc_current_locus = old_loc;
 733               *name = '\0';
 734               return MATCH_YES;
 735             }
 736         }
 737
 738       if (!ISALNUM (c)
 739           && c != '_'
 740           && (gfc_option.flag_dollar_ok && c != '$'))
 741         break;
 742
 743       *name++ = c;
 744       if (++len > GFC_MAX_SYMBOL_LEN)
 745         break;
 746     }
 747
 748   return MATCH_NO;
 749 }
 750
 751
 752 /* See if the current input matches a character constant.  Lots of
 753    contortions have to be done to match the kind parameter which comes
 754    before the actual string.  The main consideration is that we don't
 755    want to error out too quickly.  For example, we don't actually do
 756    any validation of the kinds until we have actually seen a legal
 757    delimiter.  Using match_kind_param() generates errors too quickly.  */
 758
 759 static match
 760 match_string_constant (gfc_expr ** result)
 761 {
 762   char *p, name[GFC_MAX_SYMBOL_LEN + 1];
 763   int i, c, kind, length, delimiter;
 764   locus old_locus, start_locus;
 765   gfc_symbol *sym;
 766   gfc_expr *e;
 767   const char *q;
 768   match m;
 769
 770   old_locus = gfc_current_locus;
 771
 772   gfc_gobble_whitespace ();
 773
 774   start_locus = gfc_current_locus;
 775
 776   c = gfc_next_char ();
 777   if (c == '\'' || c == '"')
 778     {
 779       kind = gfc_default_character_kind;
 780       goto got_delim;
 781     }
 782
 783   if (ISDIGIT (c))
 784     {
 785       kind = 0;
 786
 787       while (ISDIGIT (c))
 788         {
 789           kind = kind * 10 + c - '0';
 790           if (kind > 9999999)
 791             goto no_match;
 792           c = gfc_next_char ();
 793         }
 794
 795     }
 796   else
 797     {
 798       gfc_current_locus = old_locus;
 799
 800       m = match_charkind_name (name);
 801       if (m != MATCH_YES)
 802         goto no_match;
 803
 804       if (gfc_find_symbol (name, NULL, 1, &sym)
 805           || sym == NULL
 806           || sym->attr.flavor != FL_PARAMETER)
 807         goto no_match;
 808
 809       kind = -1;
 810       c = gfc_next_char ();
 811     }
 812
 813   if (c == ' ')
 814     {
 815       gfc_gobble_whitespace ();
 816       c = gfc_next_char ();
 817     }
 818
 819   if (c != '_')
 820     goto no_match;
 821
 822   gfc_gobble_whitespace ();
 823   start_locus = gfc_current_locus;
 824
 825   c = gfc_next_char ();
 826   if (c != '\'' && c != '"')
 827     goto no_match;
 828
 829   if (kind == -1)
 830     {
 831       q = gfc_extract_int (sym->value, &kind);
 832       if (q != NULL)
 833         {
 834           gfc_error (q);
 835           return MATCH_ERROR;
 836         }
 837     }
 838
 839   if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
 840     {
 841       gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
 842       return MATCH_ERROR;
 843     }
 844
 845 got_delim:
 846   /* Scan the string into a block of memory by first figuring out how
 847      long it is, allocating the structure, then re-reading it.  This
 848      isn't particularly efficient, but string constants aren't that
 849      common in most code.  TODO: Use obstacks?  */
 850
 851   delimiter = c;
 852   length = 0;
 853
 854   for (;;)
 855     {
 856       c = next_string_char (delimiter);
 857       if (c == -1)
 858         break;
 859       if (c == -2)
 860         {
 861           gfc_current_locus = start_locus;
 862           gfc_error ("Unterminated character constant beginning at %C");
 863           return MATCH_ERROR;
 864         }
 865
 866       length++;
 867     }
 868
 869   e = gfc_get_expr ();
 870
 871   e->expr_type = EXPR_CONSTANT;
 872   e->ref = NULL;
 873   e->ts.type = BT_CHARACTER;
 874   e->ts.kind = kind;
 875   e->where = start_locus;
 876
 877   e->value.character.string = p = gfc_getmem (length + 1);
 878   e->value.character.length = length;
 879
 880   gfc_current_locus = start_locus;
 881   gfc_next_char ();             /* Skip delimiter */
 882
 883   for (i = 0; i < length; i++)
 884     *p++ = next_string_char (delimiter);
 885
 886   *p = '\0';    /* TODO: C-style string is for development/debug purposes.  */
 887
 888   if (next_string_char (delimiter) != -1)
 889     gfc_internal_error ("match_string_constant(): Delimiter not found");
 890
 891   if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
 892     e->expr_type = EXPR_SUBSTRING;
 893
 894   *result = e;
 895
 896   return MATCH_YES;
 897
 898 no_match:
 899   gfc_current_locus = old_locus;
 900   return MATCH_NO;
 901 }
 902
 903
 904 /* Match a .true. or .false.  */
 905
 906 static match
 907 match_logical_constant (gfc_expr ** result)
 908 {
 909   static mstring logical_ops[] = {
 910     minit (".false.", 0),
 911     minit (".true.", 1),
 912     minit (NULL, -1)
 913   };
 914
 915   gfc_expr *e;
 916   int i, kind;
 917
 918   i = gfc_match_strings (logical_ops);
 919   if (i == -1)
 920     return MATCH_NO;
 921
 922   kind = get_kind ();
 923   if (kind == -1)
 924     return MATCH_ERROR;
 925   if (kind == -2)
 926     kind = gfc_default_logical_kind;
 927
 928   if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
 929     gfc_error ("Bad kind for logical constant at %C");
 930
 931   e = gfc_get_expr ();
 932
 933   e->expr_type = EXPR_CONSTANT;
 934   e->value.logical = i;
 935   e->ts.type = BT_LOGICAL;
 936   e->ts.kind = kind;
 937   e->where = gfc_current_locus;
 938
 939   *result = e;
 940   return MATCH_YES;
 941 }
 942
 943
 944 /* Match a real or imaginary part of a complex constant that is a
 945    symbolic constant.  */
 946
 947 static match
 948 match_sym_complex_part (gfc_expr ** result)
 949 {
 950   char name[GFC_MAX_SYMBOL_LEN + 1];
 951   gfc_symbol *sym;
 952   gfc_expr *e;
 953   match m;
 954
 955   m = gfc_match_name (name);
 956   if (m != MATCH_YES)
 957     return m;
 958
 959   if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
 960     return MATCH_NO;
 961
 962   if (sym->attr.flavor != FL_PARAMETER)
 963     {
 964       gfc_error ("Expected PARAMETER symbol in complex constant at %C");
 965       return MATCH_ERROR;
 966     }
 967
 968   if (!gfc_numeric_ts (&sym->value->ts))
 969     {
 970       gfc_error ("Numeric PARAMETER required in complex constant at %C");
 971       return MATCH_ERROR;
 972     }
 973
 974   if (sym->value->rank != 0)
 975     {
 976       gfc_error ("Scalar PARAMETER required in complex constant at %C");
 977       return MATCH_ERROR;
 978     }
 979
 980   switch (sym->value->ts.type)
 981     {
 982     case BT_REAL:
 983       e = gfc_copy_expr (sym->value);
 984       break;
 985
 986     case BT_COMPLEX:
 987       e = gfc_complex2real (sym->value, sym->value->ts.kind);
 988       if (e == NULL)
 989         goto error;
 990       break;
 991
 992     case BT_INTEGER:
 993       e = gfc_int2real (sym->value, gfc_default_real_kind);
 994       if (e == NULL)
 995         goto error;
 996       break;
 997
 998     default:
 999       gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1000     }
1001
1002   *result = e;                  /* e is a scalar, real, constant expression */
1003   return MATCH_YES;
1004
1005 error:
1006   gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1007   return MATCH_ERROR;
1008 }
1009
1010
1011 /* Match a real or imaginary part of a complex number.  */
1012
1013 static match
1014 match_complex_part (gfc_expr ** result)
1015 {
1016   match m;
1017
1018   m = match_sym_complex_part (result);
1019   if (m != MATCH_NO)
1020     return m;
1021
1022   m = match_real_constant (result, 1);
1023   if (m != MATCH_NO)
1024     return m;
1025
1026   return match_integer_constant (result, 1);
1027 }
1028
1029
1030 /* Try to match a complex constant.  */
1031
1032 static match
1033 match_complex_constant (gfc_expr ** result)
1034 {
1035   gfc_expr *e, *real, *imag;
1036   gfc_error_buf old_error;
1037   gfc_typespec target;
1038   locus old_loc;
1039   int kind;
1040   match m;
1041
1042   old_loc = gfc_current_locus;
1043   real = imag = e = NULL;
1044
1045   m = gfc_match_char ('(');
1046   if (m != MATCH_YES)
1047     return m;
1048
1049   gfc_push_error (&old_error);
1050
1051   m = match_complex_part (&real);
1052   if (m == MATCH_NO)
1053     goto cleanup;
1054
1055   if (gfc_match_char (',') == MATCH_NO)
1056     {
1057       gfc_pop_error (&old_error);
1058       m = MATCH_NO;
1059       goto cleanup;
1060     }
1061
1062   /* If m is error, then something was wrong with the real part and we
1063      assume we have a complex constant because we've seen the ','.  An
1064      ambiguous case here is the start of an iterator list of some
1065      sort. These sort of lists are matched prior to coming here.  */
1066
1067   if (m == MATCH_ERROR)
1068     goto cleanup;
1069   gfc_pop_error (&old_error);
1070
1071   m = match_complex_part (&imag);
1072   if (m == MATCH_NO)
1073     goto syntax;
1074   if (m == MATCH_ERROR)
1075     goto cleanup;
1076
1077   m = gfc_match_char (')');
1078   if (m == MATCH_NO)
1079     goto syntax;
1080
1081   if (m == MATCH_ERROR)
1082     goto cleanup;
1083
1084   /* Decide on the kind of this complex number.  */
1085   if (real->ts.type == BT_REAL)
1086     {
1087       if (imag->ts.type == BT_REAL)
1088         kind = gfc_kind_max (real, imag);
1089       else
1090         kind = real->ts.kind;
1091     }
1092   else
1093     {
1094       if (imag->ts.type == BT_REAL)
1095         kind = imag->ts.kind;
1096       else
1097         kind = gfc_default_real_kind;
1098     }
1099   target.type = BT_REAL;
1100   target.kind = kind;
1101
1102   if (real->ts.type != BT_REAL || kind != real->ts.kind)
1103     gfc_convert_type (real, &target, 2);
1104   if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1105     gfc_convert_type (imag, &target, 2);
1106
1107   e = gfc_convert_complex (real, imag, kind);
1108   e->where = gfc_current_locus;
1109
1110   gfc_free_expr (real);
1111   gfc_free_expr (imag);
1112
1113   *result = e;
1114   return MATCH_YES;
1115
1116 syntax:
1117   gfc_error ("Syntax error in COMPLEX constant at %C");
1118   m = MATCH_ERROR;
1119
1120 cleanup:
1121   gfc_free_expr (e);
1122   gfc_free_expr (real);
1123   gfc_free_expr (imag);
1124   gfc_current_locus = old_loc;
1125
1126   return m;
1127 }
1128
1129
1130 /* Match constants in any of several forms.  Returns nonzero for a
1131    match, zero for no match.  */
1132
1133 match
1134 gfc_match_literal_constant (gfc_expr ** result, int signflag)
1135 {
1136   match m;
1137
1138   m = match_complex_constant (result);
1139   if (m != MATCH_NO)
1140     return m;
1141
1142   m = match_string_constant (result);
1143   if (m != MATCH_NO)
1144     return m;
1145
1146   m = match_boz_constant (result);
1147   if (m != MATCH_NO)
1148     return m;
1149
1150   m = match_real_constant (result, signflag);
1151   if (m != MATCH_NO)
1152     return m;
1153
1154   m = match_integer_constant (result, signflag);
1155   if (m != MATCH_NO)
1156     return m;
1157
1158   m = match_logical_constant (result);
1159   if (m != MATCH_NO)
1160     return m;
1161
1162   return MATCH_NO;
1163 }
1164
1165
1166 /* Match a single actual argument value.  An actual argument is
1167    usually an expression, but can also be a procedure name.  If the
1168    argument is a single name, it is not always possible to tell
1169    whether the name is a dummy procedure or not.  We treat these cases
1170    by creating an argument that looks like a dummy procedure and
1171    fixing things later during resolution.  */
1172
1173 static match
1174 match_actual_arg (gfc_expr ** result)
1175 {
1176   char name[GFC_MAX_SYMBOL_LEN + 1];
1177   gfc_symtree *symtree;
1178   locus where, w;
1179   gfc_expr *e;
1180   int c;
1181
1182   where = gfc_current_locus;
1183
1184   switch (gfc_match_name (name))
1185     {
1186     case MATCH_ERROR:
1187       return MATCH_ERROR;
1188
1189     case MATCH_NO:
1190       break;
1191
1192     case MATCH_YES:
1193       w = gfc_current_locus;
1194       gfc_gobble_whitespace ();
1195       c = gfc_next_char ();
1196       gfc_current_locus = w;
1197
1198       if (c != ',' && c != ')')
1199         break;
1200
1201       if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1202         break;
1203       /* Handle error elsewhere.  */
1204
1205       /* Eliminate a couple of common cases where we know we don't
1206          have a function argument.  */
1207       if (symtree == NULL)
1208         {
1209           gfc_get_sym_tree (name, NULL, &symtree);
1210           gfc_set_sym_referenced (symtree->n.sym);
1211         }
1212       else
1213         {
1214           gfc_symbol *sym;
1215
1216           sym = symtree->n.sym;
1217           gfc_set_sym_referenced (sym);
1218           if (sym->attr.flavor != FL_PROCEDURE
1219               && sym->attr.flavor != FL_UNKNOWN)
1220             break;
1221
1222           /* If the symbol is a function with itself as the result and
1223              is being defined, then we have a variable.  */
1224           if (sym->result == sym
1225               && (gfc_current_ns->proc_name == sym
1226                   || (gfc_current_ns->parent != NULL
1227                       && gfc_current_ns->parent->proc_name == sym)))
1228             break;
1229         }
1230
1231       e = gfc_get_expr ();      /* Leave it unknown for now */
1232       e->symtree = symtree;
1233       e->expr_type = EXPR_VARIABLE;
1234       e->ts.type = BT_PROCEDURE;
1235       e->where = where;
1236
1237       *result = e;
1238       return MATCH_YES;
1239     }
1240
1241   gfc_current_locus = where;
1242   return gfc_match_expr (result);
1243 }
1244
1245
1246 /* Match a keyword argument.  */
1247
1248 static match
1249 match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base)
1250 {
1251   char name[GFC_MAX_SYMBOL_LEN + 1];
1252   gfc_actual_arglist *a;
1253   locus name_locus;
1254   match m;
1255
1256   name_locus = gfc_current_locus;
1257   m = gfc_match_name (name);
1258
1259   if (m != MATCH_YES)
1260     goto cleanup;
1261   if (gfc_match_char ('=') != MATCH_YES)
1262     {
1263       m = MATCH_NO;
1264       goto cleanup;
1265     }
1266
1267   m = match_actual_arg (&actual->expr);
1268   if (m != MATCH_YES)
1269     goto cleanup;
1270
1271   /* Make sure this name has not appeared yet.  */
1272
1273   if (name[0] != '\0')
1274     {
1275       for (a = base; a; a = a->next)
1276         if (strcmp (a->name, name) == 0)
1277           {
1278             gfc_error
1279               ("Keyword '%s' at %C has already appeared in the current "
1280                "argument list", name);
1281             return MATCH_ERROR;
1282           }
1283     }
1284
1285   strcpy (actual->name, name);
1286   return MATCH_YES;
1287
1288 cleanup:
1289   gfc_current_locus = name_locus;
1290   return m;
1291 }
1292
1293
1294 /* Matches an actual argument list of a function or subroutine, from
1295    the opening parenthesis to the closing parenthesis.  The argument
1296    list is assumed to allow keyword arguments because we don't know if
1297    the symbol associated with the procedure has an implicit interface
1298    or not.  We make sure keywords are unique. If SUB_FLAG is set,
1299    we're matching the argument list of a subroutine.  */
1300
1301 match
1302 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
1303 {
1304   gfc_actual_arglist *head, *tail;
1305   int seen_keyword;
1306   gfc_st_label *label;
1307   locus old_loc;
1308   match m;
1309
1310   *argp = tail = NULL;
1311   old_loc = gfc_current_locus;
1312
1313   seen_keyword = 0;
1314
1315   if (gfc_match_char ('(') == MATCH_NO)
1316     return (sub_flag) ? MATCH_YES : MATCH_NO;
1317
1318   if (gfc_match_char (')') == MATCH_YES)
1319     return MATCH_YES;
1320   head = NULL;
1321
1322   for (;;)
1323     {
1324       if (head == NULL)
1325         head = tail = gfc_get_actual_arglist ();
1326       else
1327         {
1328           tail->next = gfc_get_actual_arglist ();
1329           tail = tail->next;
1330         }
1331
1332       if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1333         {
1334           m = gfc_match_st_label (&label, 0);
1335           if (m == MATCH_NO)
1336             gfc_error ("Expected alternate return label at %C");
1337           if (m != MATCH_YES)
1338             goto cleanup;
1339
1340           tail->label = label;
1341           goto next;
1342         }
1343
1344       /* After the first keyword argument is seen, the following
1345          arguments must also have keywords.  */
1346       if (seen_keyword)
1347         {
1348           m = match_keyword_arg (tail, head);
1349
1350           if (m == MATCH_ERROR)
1351             goto cleanup;
1352           if (m == MATCH_NO)
1353             {
1354               gfc_error
1355                 ("Missing keyword name in actual argument list at %C");
1356               goto cleanup;
1357             }
1358
1359         }
1360       else
1361         {
1362           /* See if we have the first keyword argument.  */
1363           m = match_keyword_arg (tail, head);
1364           if (m == MATCH_YES)
1365             seen_keyword = 1;
1366           if (m == MATCH_ERROR)
1367             goto cleanup;
1368
1369           if (m == MATCH_NO)
1370             {
1371               /* Try for a non-keyword argument.  */
1372               m = match_actual_arg (&tail->expr);
1373               if (m == MATCH_ERROR)
1374                 goto cleanup;
1375               if (m == MATCH_NO)
1376                 goto syntax;
1377             }
1378         }
1379
1380     next:
1381       if (gfc_match_char (')') == MATCH_YES)
1382         break;
1383       if (gfc_match_char (',') != MATCH_YES)
1384         goto syntax;
1385     }
1386
1387   *argp = head;
1388   return MATCH_YES;
1389
1390 syntax:
1391   gfc_error ("Syntax error in argument list at %C");
1392
1393 cleanup:
1394   gfc_free_actual_arglist (head);
1395   gfc_current_locus = old_loc;
1396
1397   return MATCH_ERROR;
1398 }
1399
1400
1401 /* Used by match_varspec() to extend the reference list by one
1402    element.  */
1403
1404 static gfc_ref *
1405 extend_ref (gfc_expr * primary, gfc_ref * tail)
1406 {
1407
1408   if (primary->ref == NULL)
1409     primary->ref = tail = gfc_get_ref ();
1410   else
1411     {
1412       if (tail == NULL)
1413         gfc_internal_error ("extend_ref(): Bad tail");
1414       tail->next = gfc_get_ref ();
1415       tail = tail->next;
1416     }
1417
1418   return tail;
1419 }
1420
1421
1422 /* Match any additional specifications associated with the current
1423    variable like member references or substrings.  If equiv_flag is
1424    set we only match stuff that is allowed inside an EQUIVALENCE
1425    statement.  */
1426
1427 static match
1428 match_varspec (gfc_expr * primary, int equiv_flag)
1429 {
1430   char name[GFC_MAX_SYMBOL_LEN + 1];
1431   gfc_ref *substring, *tail;
1432   gfc_component *component;
1433   gfc_symbol *sym;
1434   match m;
1435
1436   tail = NULL;
1437
1438   if (primary->symtree->n.sym->attr.dimension
1439       || (equiv_flag
1440           && gfc_peek_char () == '('))
1441     {
1442
1443       tail = extend_ref (primary, tail);
1444       tail->type = REF_ARRAY;
1445
1446       m = gfc_match_array_ref (&tail->u.ar, primary->symtree->n.sym->as,
1447                                equiv_flag);
1448       if (m != MATCH_YES)
1449         return m;
1450     }
1451
1452   sym = primary->symtree->n.sym;
1453   primary->ts = sym->ts;
1454
1455   if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
1456     goto check_substring;
1457
1458   sym = sym->ts.derived;
1459
1460   for (;;)
1461     {
1462       m = gfc_match_name (name);
1463       if (m == MATCH_NO)
1464         gfc_error ("Expected structure component name at %C");
1465       if (m != MATCH_YES)
1466         return MATCH_ERROR;
1467
1468       component = gfc_find_component (sym, name);
1469       if (component == NULL)
1470         return MATCH_ERROR;
1471
1472       tail = extend_ref (primary, tail);
1473       tail->type = REF_COMPONENT;
1474
1475       tail->u.c.component = component;
1476       tail->u.c.sym = sym;
1477
1478       primary->ts = component->ts;
1479
1480       if (component->as != NULL)
1481         {
1482           tail = extend_ref (primary, tail);
1483           tail->type = REF_ARRAY;
1484
1485           m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1486           if (m != MATCH_YES)
1487             return m;
1488         }
1489
1490       if (component->ts.type != BT_DERIVED
1491           || gfc_match_char ('%') != MATCH_YES)
1492         break;
1493
1494       sym = component->ts.derived;
1495     }
1496
1497 check_substring:
1498   if (primary->ts.type == BT_CHARACTER)
1499     {
1500       switch (match_substring (primary->ts.cl, equiv_flag, &substring))
1501         {
1502         case MATCH_YES:
1503           if (tail == NULL)
1504             primary->ref = substring;
1505           else
1506             tail->next = substring;
1507
1508           if (primary->expr_type == EXPR_CONSTANT)
1509             primary->expr_type = EXPR_SUBSTRING;
1510
1511           break;
1512
1513         case MATCH_NO:
1514           break;
1515
1516         case MATCH_ERROR:
1517           return MATCH_ERROR;
1518         }
1519     }
1520
1521   return MATCH_YES;
1522 }
1523
1524
1525 /* Given an expression that is a variable, figure out what the
1526    ultimate variable's type and attribute is, traversing the reference
1527    structures if necessary.
1528
1529    This subroutine is trickier than it looks.  We start at the base
1530    symbol and store the attribute.  Component references load a
1531    completely new attribute.
1532
1533    A couple of rules come into play.  Subobjects of targets are always
1534    targets themselves.  If we see a component that goes through a
1535    pointer, then the expression must also be a target, since the
1536    pointer is associated with something (if it isn't core will soon be
1537    dumped).  If we see a full part or section of an array, the
1538    expression is also an array.
1539
1540    We can have at most one full array reference.  */
1541
1542 symbol_attribute
1543 gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
1544 {
1545   int dimension, pointer, target;
1546   symbol_attribute attr;
1547   gfc_ref *ref;
1548
1549   if (expr->expr_type != EXPR_VARIABLE)
1550     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1551
1552   ref = expr->ref;
1553   attr = expr->symtree->n.sym->attr;
1554
1555   dimension = attr.dimension;
1556   pointer = attr.pointer;
1557
1558   target = attr.target;
1559   if (pointer)
1560     target = 1;
1561
1562   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1563     *ts = expr->symtree->n.sym->ts;
1564
1565   for (; ref; ref = ref->next)
1566     switch (ref->type)
1567       {
1568       case REF_ARRAY:
1569
1570         switch (ref->u.ar.type)
1571           {
1572           case AR_FULL:
1573             dimension = 1;
1574             break;
1575
1576           case AR_SECTION:
1577             pointer = 0;
1578             dimension = 1;
1579             break;
1580
1581           case AR_ELEMENT:
1582             pointer = 0;
1583             break;
1584
1585           case AR_UNKNOWN:
1586             gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1587           }
1588
1589         break;
1590
1591       case REF_COMPONENT:
1592         gfc_get_component_attr (&attr, ref->u.c.component);
1593         if (ts != NULL)
1594           *ts = ref->u.c.component->ts;
1595
1596         pointer = ref->u.c.component->pointer;
1597         if (pointer)
1598           target = 1;
1599
1600         break;
1601
1602       case REF_SUBSTRING:
1603         pointer = 0;
1604         break;
1605       }
1606
1607   attr.dimension = dimension;
1608   attr.pointer = pointer;
1609   attr.target = target;
1610
1611   return attr;
1612 }
1613
1614
1615 /* Return the attribute from a general expression.  */
1616
1617 symbol_attribute
1618 gfc_expr_attr (gfc_expr * e)
1619 {
1620   symbol_attribute attr;
1621
1622   switch (e->expr_type)
1623     {
1624     case EXPR_VARIABLE:
1625       attr = gfc_variable_attr (e, NULL);
1626       break;
1627
1628     case EXPR_FUNCTION:
1629       gfc_clear_attr (&attr);
1630
1631       if (e->value.function.esym != NULL)
1632         attr = e->value.function.esym->result->attr;
1633
1634       /* TODO: NULL() returns pointers.  May have to take care of this
1635          here.  */
1636
1637       break;
1638
1639     default:
1640       gfc_clear_attr (&attr);
1641       break;
1642     }
1643
1644   return attr;
1645 }
1646
1647
1648 /* Match a structure constructor.  The initial symbol has already been
1649    seen.  */
1650
1651 match
1652 gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
1653 {
1654   gfc_constructor *head, *tail;
1655   gfc_component *comp;
1656   gfc_expr *e;
1657   locus where;
1658   match m;
1659
1660   head = tail = NULL;
1661
1662   if (gfc_match_char ('(') != MATCH_YES)
1663     goto syntax;
1664
1665   where = gfc_current_locus;
1666
1667   gfc_find_component (sym, NULL);
1668
1669   for (comp = sym->components; comp; comp = comp->next)
1670     {
1671       if (head == NULL)
1672         tail = head = gfc_get_constructor ();
1673       else
1674         {
1675           tail->next = gfc_get_constructor ();
1676           tail = tail->next;
1677         }
1678
1679       m = gfc_match_expr (&tail->expr);
1680       if (m == MATCH_NO)
1681         goto syntax;
1682       if (m == MATCH_ERROR)
1683         goto cleanup;
1684
1685       if (gfc_match_char (',') == MATCH_YES)
1686         {
1687           if (comp->next == NULL)
1688             {
1689               gfc_error
1690                 ("Too many components in structure constructor at %C");
1691               goto cleanup;
1692             }
1693
1694           continue;
1695         }
1696
1697       break;
1698     }
1699
1700   if (gfc_match_char (')') != MATCH_YES)
1701     goto syntax;
1702
1703   if (comp->next != NULL)
1704     {
1705       gfc_error ("Too few components in structure constructor at %C");
1706       goto cleanup;
1707     }
1708
1709   e = gfc_get_expr ();
1710
1711   e->expr_type = EXPR_STRUCTURE;
1712
1713   e->ts.type = BT_DERIVED;
1714   e->ts.derived = sym;
1715   e->where = where;
1716
1717   e->value.constructor = head;
1718
1719   *result = e;
1720   return MATCH_YES;
1721
1722 syntax:
1723   gfc_error ("Syntax error in structure constructor at %C");
1724
1725 cleanup:
1726   gfc_free_constructor (head);
1727   return MATCH_ERROR;
1728 }
1729
1730
1731 /* Matches a variable name followed by anything that might follow it--
1732    array reference, argument list of a function, etc.  */
1733
1734 match
1735 gfc_match_rvalue (gfc_expr ** result)
1736 {
1737   gfc_actual_arglist *actual_arglist;
1738   char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
1739   gfc_state_data *st;
1740   gfc_symbol *sym;
1741   gfc_symtree *symtree;
1742   locus where, old_loc;
1743   gfc_expr *e;
1744   match m, m2;
1745   int i;
1746
1747   m = gfc_match_name (name);
1748   if (m != MATCH_YES)
1749     return m;
1750
1751   if (gfc_find_state (COMP_INTERFACE) == SUCCESS)
1752     i = gfc_get_sym_tree (name, NULL, &symtree);
1753   else
1754     i = gfc_get_ha_sym_tree (name, &symtree);
1755
1756   if (i)
1757     return MATCH_ERROR;
1758
1759   sym = symtree->n.sym;
1760   e = NULL;
1761   where = gfc_current_locus;
1762
1763   gfc_set_sym_referenced (sym);
1764
1765   if (sym->attr.function && sym->result == sym
1766       && (gfc_current_ns->proc_name == sym
1767           || (gfc_current_ns->parent != NULL
1768               && gfc_current_ns->parent->proc_name == sym)))
1769     goto variable;
1770
1771   if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
1772     goto function0;
1773
1774   if (sym->attr.generic)
1775     goto generic_function;
1776
1777   switch (sym->attr.flavor)
1778     {
1779     case FL_VARIABLE:
1780     variable:
1781       if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
1782           && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
1783         gfc_set_default_type (sym, 0, sym->ns);
1784
1785       e = gfc_get_expr ();
1786
1787       e->expr_type = EXPR_VARIABLE;
1788       e->symtree = symtree;
1789
1790       m = match_varspec (e, 0);
1791       break;
1792
1793     case FL_PARAMETER:
1794       if (sym->value
1795           && sym->value->expr_type != EXPR_ARRAY)
1796         e = gfc_copy_expr (sym->value);
1797       else
1798         {
1799           e = gfc_get_expr ();
1800           e->expr_type = EXPR_VARIABLE;
1801         }
1802
1803       e->symtree = symtree;
1804       m = match_varspec (e, 0);
1805       break;
1806
1807     case FL_DERIVED:
1808       sym = gfc_use_derived (sym);
1809       if (sym == NULL)
1810         m = MATCH_ERROR;
1811       else
1812         m = gfc_match_structure_constructor (sym, &e);
1813       break;
1814
1815     /* If we're here, then the name is known to be the name of a
1816        procedure, yet it is not sure to be the name of a function.  */
1817     case FL_PROCEDURE:
1818       if (sym->attr.subroutine)
1819         {
1820           gfc_error ("Unexpected use of subroutine name '%s' at %C",
1821                      sym->name);
1822           m = MATCH_ERROR;
1823           break;
1824         }
1825
1826       /* At this point, the name has to be a non-statement function.
1827          If the name is the same as the current function being
1828          compiled, then we have a variable reference (to the function
1829          result) if the name is non-recursive.  */
1830
1831       st = gfc_enclosing_unit (NULL);
1832
1833       if (st != NULL && st->state == COMP_FUNCTION
1834           && st->sym == sym
1835           && !sym->attr.recursive)
1836         {
1837           e = gfc_get_expr ();
1838           e->symtree = symtree;
1839           e->expr_type = EXPR_VARIABLE;
1840
1841           m = match_varspec (e, 0);
1842           break;
1843         }
1844
1845     /* Match a function reference.  */
1846     function0:
1847       m = gfc_match_actual_arglist (0, &actual_arglist);
1848       if (m == MATCH_NO)
1849         {
1850           if (sym->attr.proc == PROC_ST_FUNCTION)
1851             gfc_error ("Statement function '%s' requires argument list at %C",
1852                        sym->name);
1853           else
1854             gfc_error ("Function '%s' requires an argument list at %C",
1855                        sym->name);
1856
1857           m = MATCH_ERROR;
1858           break;
1859         }
1860
1861       if (m != MATCH_YES)
1862         {
1863           m = MATCH_ERROR;
1864           break;
1865         }
1866
1867       gfc_get_ha_sym_tree (name, &symtree);     /* Can't fail */
1868       sym = symtree->n.sym;
1869
1870       e = gfc_get_expr ();
1871       e->symtree = symtree;
1872       e->expr_type = EXPR_FUNCTION;
1873       e->value.function.actual = actual_arglist;
1874       e->where = gfc_current_locus;
1875
1876       if (sym->as != NULL)
1877         e->rank = sym->as->rank;
1878
1879       if (!sym->attr.function
1880           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
1881         {
1882           m = MATCH_ERROR;
1883           break;
1884         }
1885
1886       if (sym->result == NULL)
1887         sym->result = sym;
1888
1889       m = MATCH_YES;
1890       break;
1891
1892     case FL_UNKNOWN:
1893
1894       /* Special case for derived type variables that get their types
1895          via an IMPLICIT statement.  This can't wait for the
1896          resolution phase.  */
1897
1898       if (gfc_peek_char () == '%'
1899           && sym->ts.type == BT_UNKNOWN
1900           && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
1901         gfc_set_default_type (sym, 0, sym->ns);
1902
1903       /* If the symbol has a dimension attribute, the expression is a
1904          variable.  */
1905
1906       if (sym->attr.dimension)
1907         {
1908           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
1909                               sym->name, NULL) == FAILURE)
1910             {
1911               m = MATCH_ERROR;
1912               break;
1913             }
1914
1915           e = gfc_get_expr ();
1916           e->symtree = symtree;
1917           e->expr_type = EXPR_VARIABLE;
1918           m = match_varspec (e, 0);
1919           break;
1920         }
1921
1922       /* Name is not an array, so we peek to see if a '(' implies a
1923          function call or a substring reference.  Otherwise the
1924          variable is just a scalar.  */
1925
1926       gfc_gobble_whitespace ();
1927       if (gfc_peek_char () != '(')
1928         {
1929           /* Assume a scalar variable */
1930           e = gfc_get_expr ();
1931           e->symtree = symtree;
1932           e->expr_type = EXPR_VARIABLE;
1933
1934           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
1935                               sym->name, NULL) == FAILURE)
1936             {
1937               m = MATCH_ERROR;
1938               break;
1939             }
1940
1941           e->ts = sym->ts;
1942           m = match_varspec (e, 0);
1943           break;
1944         }
1945
1946       /* See if this is a function reference with a keyword argument
1947          as first argument. We do this because otherwise a spurious
1948          symbol would end up in the symbol table.  */
1949
1950       old_loc = gfc_current_locus;
1951       m2 = gfc_match (" ( %n =", argname);
1952       gfc_current_locus = old_loc;
1953
1954       e = gfc_get_expr ();
1955       e->symtree = symtree;
1956
1957       if (m2 != MATCH_YES)
1958         {
1959           /* See if this could possibly be a substring reference of a name
1960              that we're not sure is a variable yet.  */
1961
1962           if ((sym->ts.type == BT_UNKNOWN || sym->ts.type == BT_CHARACTER)
1963               && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
1964             {
1965
1966               e->expr_type = EXPR_VARIABLE;
1967
1968               if (sym->attr.flavor != FL_VARIABLE
1969                   && gfc_add_flavor (&sym->attr, FL_VARIABLE,
1970                                      sym->name, NULL) == FAILURE)
1971                 {
1972                   m = MATCH_ERROR;
1973                   break;
1974                 }
1975
1976               if (sym->ts.type == BT_UNKNOWN
1977                   && gfc_set_default_type (sym, 1, NULL) == FAILURE)
1978                 {
1979                   m = MATCH_ERROR;
1980                   break;
1981                 }
1982
1983               e->ts = sym->ts;
1984               m = MATCH_YES;
1985               break;
1986             }
1987         }
1988
1989       /* Give up, assume we have a function.  */
1990
1991       gfc_get_sym_tree (name, NULL, &symtree);  /* Can't fail */
1992       sym = symtree->n.sym;
1993       e->expr_type = EXPR_FUNCTION;
1994
1995       if (!sym->attr.function
1996           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
1997         {
1998           m = MATCH_ERROR;
1999           break;
2000         }
2001
2002       sym->result = sym;
2003
2004       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2005       if (m == MATCH_NO)
2006         gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2007
2008       if (m != MATCH_YES)
2009         {
2010           m = MATCH_ERROR;
2011           break;
2012         }
2013
2014       /* If our new function returns a character, array or structure
2015          type, it might have subsequent references.  */
2016
2017       m = match_varspec (e, 0);
2018       if (m == MATCH_NO)
2019         m = MATCH_YES;
2020
2021       break;
2022
2023     generic_function:
2024       gfc_get_sym_tree (name, NULL, &symtree);  /* Can't fail */
2025
2026       e = gfc_get_expr ();
2027       e->symtree = symtree;
2028       e->expr_type = EXPR_FUNCTION;
2029
2030       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2031       break;
2032
2033     default:
2034       gfc_error ("Symbol at %C is not appropriate for an expression");
2035       return MATCH_ERROR;
2036     }
2037
2038   if (m == MATCH_YES)
2039     {
2040       e->where = where;
2041       *result = e;
2042     }
2043   else
2044     gfc_free_expr (e);
2045
2046   return m;
2047 }
2048
2049
2050 /* Match a variable, ie something that can be assigned to.  This
2051    starts as a symbol, can be a structure component or an array
2052    reference.  It can be a function if the function doesn't have a
2053    separate RESULT variable.  If the symbol has not been previously
2054    seen, we assume it is a variable.  */
2055
2056 match
2057 gfc_match_variable (gfc_expr ** result, int equiv_flag)
2058 {
2059   gfc_symbol *sym;
2060   gfc_symtree *st;
2061   gfc_expr *expr;
2062   locus where;
2063   match m;
2064
2065   m = gfc_match_sym_tree (&st, 1);
2066   if (m != MATCH_YES)
2067     return m;
2068   where = gfc_current_locus;
2069
2070   sym = st->n.sym;
2071   gfc_set_sym_referenced (sym);
2072   switch (sym->attr.flavor)
2073     {
2074     case FL_VARIABLE:
2075       break;
2076
2077     case FL_UNKNOWN:
2078       if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2079                           sym->name, NULL) == FAILURE)
2080         return MATCH_ERROR;
2081       break;
2082
2083     case FL_PROCEDURE:
2084       /* Check for a nonrecursive function result */
2085       if (sym->attr.function && (sym->result == sym || sym->attr.entry))
2086         {
2087           /* If a function result is a derived type, then the derived
2088              type may still have to be resolved.  */
2089
2090           if (sym->ts.type == BT_DERIVED
2091               && gfc_use_derived (sym->ts.derived) == NULL)
2092             return MATCH_ERROR;
2093           break;
2094         }
2095
2096       /* Fall through to error */
2097
2098     default:
2099       gfc_error ("Expected VARIABLE at %C");
2100       return MATCH_ERROR;
2101     }
2102
2103   /* Special case for derived type variables that get their types
2104      via an IMPLICIT statement.  This can't wait for the
2105      resolution phase.  */
2106
2107     {
2108       gfc_namespace * implicit_ns;
2109
2110       if (gfc_current_ns->proc_name == sym)
2111         implicit_ns = gfc_current_ns;
2112       else
2113         implicit_ns = sym->ns;
2114
2115       if (gfc_peek_char () == '%'
2116           && sym->ts.type == BT_UNKNOWN
2117           && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
2118         gfc_set_default_type (sym, 0, implicit_ns);
2119     }
2120
2121   expr = gfc_get_expr ();
2122
2123   expr->expr_type = EXPR_VARIABLE;
2124   expr->symtree = st;
2125   expr->ts = sym->ts;
2126   expr->where = where;
2127
2128   /* Now see if we have to do more.  */
2129   m = match_varspec (expr, equiv_flag);
2130   if (m != MATCH_YES)
2131     {
2132       gfc_free_expr (expr);
2133       return m;
2134     }
2135
2136   *result = expr;
2137   return MATCH_YES;
2138 }