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