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           break;
1520
1521         case MATCH_NO:
1522           break;
1523
1524         case MATCH_ERROR:
1525           return MATCH_ERROR;
1526         }
1527     }
1528
1529   return MATCH_YES;
1530 }
1531
1532
1533 /* Given an expression that is a variable, figure out what the
1534    ultimate variable's type and attribute is, traversing the reference
1535    structures if necessary.
1536
1537    This subroutine is trickier than it looks.  We start at the base
1538    symbol and store the attribute.  Component references load a
1539    completely new attribute.
1540
1541    A couple of rules come into play.  Subobjects of targets are always
1542    targets themselves.  If we see a component that goes through a
1543    pointer, then the expression must also be a target, since the
1544    pointer is associated with something (if it isn't core will soon be
1545    dumped).  If we see a full part or section of an array, the
1546    expression is also an array.
1547
1548    We can have at most one full array reference.  */
1549
1550 symbol_attribute
1551 gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
1552 {
1553   int dimension, pointer, target;
1554   symbol_attribute attr;
1555   gfc_ref *ref;
1556
1557   if (expr->expr_type != EXPR_VARIABLE)
1558     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1559
1560   ref = expr->ref;
1561   attr = expr->symtree->n.sym->attr;
1562
1563   dimension = attr.dimension;
1564   pointer = attr.pointer;
1565
1566   target = attr.target;
1567   if (pointer)
1568     target = 1;
1569
1570   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1571     *ts = expr->symtree->n.sym->ts;
1572
1573   for (; ref; ref = ref->next)
1574     switch (ref->type)
1575       {
1576       case REF_ARRAY:
1577
1578         switch (ref->u.ar.type)
1579           {
1580           case AR_FULL:
1581             dimension = 1;
1582             break;
1583
1584           case AR_SECTION:
1585             pointer = 0;
1586             dimension = 1;
1587             break;
1588
1589           case AR_ELEMENT:
1590             pointer = 0;
1591             break;
1592
1593           case AR_UNKNOWN:
1594             gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1595           }
1596
1597         break;
1598
1599       case REF_COMPONENT:
1600         gfc_get_component_attr (&attr, ref->u.c.component);
1601         if (ts != NULL)
1602           *ts = ref->u.c.component->ts;
1603
1604         pointer = ref->u.c.component->pointer;
1605         if (pointer)
1606           target = 1;
1607
1608         break;
1609
1610       case REF_SUBSTRING:
1611         pointer = 0;
1612         break;
1613       }
1614
1615   attr.dimension = dimension;
1616   attr.pointer = pointer;
1617   attr.target = target;
1618
1619   return attr;
1620 }
1621
1622
1623 /* Return the attribute from a general expression.  */
1624
1625 symbol_attribute
1626 gfc_expr_attr (gfc_expr * e)
1627 {
1628   symbol_attribute attr;
1629
1630   switch (e->expr_type)
1631     {
1632     case EXPR_VARIABLE:
1633       attr = gfc_variable_attr (e, NULL);
1634       break;
1635
1636     case EXPR_FUNCTION:
1637       gfc_clear_attr (&attr);
1638
1639       if (e->value.function.esym != NULL)
1640         attr = e->value.function.esym->result->attr;
1641
1642       /* TODO: NULL() returns pointers.  May have to take care of this
1643          here.  */
1644
1645       break;
1646
1647     default:
1648       gfc_clear_attr (&attr);
1649       break;
1650     }
1651
1652   return attr;
1653 }
1654
1655
1656 /* Match a structure constructor.  The initial symbol has already been
1657    seen.  */
1658
1659 match
1660 gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
1661 {
1662   gfc_constructor *head, *tail;
1663   gfc_component *comp;
1664   gfc_expr *e;
1665   locus where;
1666   match m;
1667
1668   head = tail = NULL;
1669
1670   if (gfc_match_char ('(') != MATCH_YES)
1671     goto syntax;
1672
1673   where = gfc_current_locus;
1674
1675   gfc_find_component (sym, NULL);
1676
1677   for (comp = sym->components; comp; comp = comp->next)
1678     {
1679       if (head == NULL)
1680         tail = head = gfc_get_constructor ();
1681       else
1682         {
1683           tail->next = gfc_get_constructor ();
1684           tail = tail->next;
1685         }
1686
1687       m = gfc_match_expr (&tail->expr);
1688       if (m == MATCH_NO)
1689         goto syntax;
1690       if (m == MATCH_ERROR)
1691         goto cleanup;
1692
1693       if (gfc_match_char (',') == MATCH_YES)
1694         {
1695           if (comp->next == NULL)
1696             {
1697               gfc_error
1698                 ("Too many components in structure constructor at %C");
1699               goto cleanup;
1700             }
1701
1702           continue;
1703         }
1704
1705       break;
1706     }
1707
1708   if (gfc_match_char (')') != MATCH_YES)
1709     goto syntax;
1710
1711   if (comp->next != NULL)
1712     {
1713       gfc_error ("Too few components in structure constructor at %C");
1714       goto cleanup;
1715     }
1716
1717   e = gfc_get_expr ();
1718
1719   e->expr_type = EXPR_STRUCTURE;
1720
1721   e->ts.type = BT_DERIVED;
1722   e->ts.derived = sym;
1723   e->where = where;
1724
1725   e->value.constructor = head;
1726
1727   *result = e;
1728   return MATCH_YES;
1729
1730 syntax:
1731   gfc_error ("Syntax error in structure constructor at %C");
1732
1733 cleanup:
1734   gfc_free_constructor (head);
1735   return MATCH_ERROR;
1736 }
1737
1738
1739 /* Matches a variable name followed by anything that might follow it--
1740    array reference, argument list of a function, etc.  */
1741
1742 match
1743 gfc_match_rvalue (gfc_expr ** result)
1744 {
1745   gfc_actual_arglist *actual_arglist;
1746   char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
1747   gfc_state_data *st;
1748   gfc_symbol *sym;
1749   gfc_symtree *symtree;
1750   locus where, old_loc;
1751   gfc_expr *e;
1752   match m, m2;
1753   int i;
1754
1755   m = gfc_match_name (name);
1756   if (m != MATCH_YES)
1757     return m;
1758
1759   if (gfc_find_state (COMP_INTERFACE) == SUCCESS)
1760     i = gfc_get_sym_tree (name, NULL, &symtree);
1761   else
1762     i = gfc_get_ha_sym_tree (name, &symtree);
1763
1764   if (i)
1765     return MATCH_ERROR;
1766
1767   sym = symtree->n.sym;
1768   e = NULL;
1769   where = gfc_current_locus;
1770
1771   gfc_set_sym_referenced (sym);
1772
1773   if (sym->attr.function && sym->result == sym
1774       && (gfc_current_ns->proc_name == sym
1775           || (gfc_current_ns->parent != NULL
1776               && gfc_current_ns->parent->proc_name == sym)))
1777     goto variable;
1778
1779   if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
1780     goto function0;
1781
1782   if (sym->attr.generic)
1783     goto generic_function;
1784
1785   switch (sym->attr.flavor)
1786     {
1787     case FL_VARIABLE:
1788     variable:
1789       if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
1790           && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
1791         gfc_set_default_type (sym, 0, sym->ns);
1792
1793       e = gfc_get_expr ();
1794
1795       e->expr_type = EXPR_VARIABLE;
1796       e->symtree = symtree;
1797
1798       m = match_varspec (e, 0);
1799       break;
1800
1801     case FL_PARAMETER:
1802       if (sym->value
1803           && sym->value->expr_type != EXPR_ARRAY)
1804         e = gfc_copy_expr (sym->value);
1805       else
1806         {
1807           e = gfc_get_expr ();
1808           e->expr_type = EXPR_VARIABLE;
1809         }
1810
1811       e->symtree = symtree;
1812       m = match_varspec (e, 0);
1813       break;
1814
1815     case FL_DERIVED:
1816       sym = gfc_use_derived (sym);
1817       if (sym == NULL)
1818         m = MATCH_ERROR;
1819       else
1820         m = gfc_match_structure_constructor (sym, &e);
1821       break;
1822
1823     /* If we're here, then the name is known to be the name of a
1824        procedure, yet it is not sure to be the name of a function.  */
1825     case FL_PROCEDURE:
1826       if (sym->attr.subroutine)
1827         {
1828           gfc_error ("Unexpected use of subroutine name '%s' at %C",
1829                      sym->name);
1830           m = MATCH_ERROR;
1831           break;
1832         }
1833
1834       /* At this point, the name has to be a non-statement function.
1835          If the name is the same as the current function being
1836          compiled, then we have a variable reference (to the function
1837          result) if the name is non-recursive.  */
1838
1839       st = gfc_enclosing_unit (NULL);
1840
1841       if (st != NULL && st->state == COMP_FUNCTION
1842           && st->sym == sym
1843           && !sym->attr.recursive)
1844         {
1845           e = gfc_get_expr ();
1846           e->symtree = symtree;
1847           e->expr_type = EXPR_VARIABLE;
1848
1849           m = match_varspec (e, 0);
1850           break;
1851         }
1852
1853     /* Match a function reference.  */
1854     function0:
1855       m = gfc_match_actual_arglist (0, &actual_arglist);
1856       if (m == MATCH_NO)
1857         {
1858           if (sym->attr.proc == PROC_ST_FUNCTION)
1859             gfc_error ("Statement function '%s' requires argument list at %C",
1860                        sym->name);
1861           else
1862             gfc_error ("Function '%s' requires an argument list at %C",
1863                        sym->name);
1864
1865           m = MATCH_ERROR;
1866           break;
1867         }
1868
1869       if (m != MATCH_YES)
1870         {
1871           m = MATCH_ERROR;
1872           break;
1873         }
1874
1875       gfc_get_ha_sym_tree (name, &symtree);     /* Can't fail */
1876       sym = symtree->n.sym;
1877
1878       e = gfc_get_expr ();
1879       e->symtree = symtree;
1880       e->expr_type = EXPR_FUNCTION;
1881       e->value.function.actual = actual_arglist;
1882       e->where = gfc_current_locus;
1883
1884       if (sym->as != NULL)
1885         e->rank = sym->as->rank;
1886
1887       if (!sym->attr.function
1888           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
1889         {
1890           m = MATCH_ERROR;
1891           break;
1892         }
1893
1894       if (sym->result == NULL)
1895         sym->result = sym;
1896
1897       m = MATCH_YES;
1898       break;
1899
1900     case FL_UNKNOWN:
1901
1902       /* Special case for derived type variables that get their types
1903          via an IMPLICIT statement.  This can't wait for the
1904          resolution phase.  */
1905
1906       if (gfc_peek_char () == '%'
1907           && sym->ts.type == BT_UNKNOWN
1908           && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
1909         gfc_set_default_type (sym, 0, sym->ns);
1910
1911       /* If the symbol has a dimension attribute, the expression is a
1912          variable.  */
1913
1914       if (sym->attr.dimension)
1915         {
1916           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
1917                               sym->name, NULL) == FAILURE)
1918             {
1919               m = MATCH_ERROR;
1920               break;
1921             }
1922
1923           e = gfc_get_expr ();
1924           e->symtree = symtree;
1925           e->expr_type = EXPR_VARIABLE;
1926           m = match_varspec (e, 0);
1927           break;
1928         }
1929
1930       /* Name is not an array, so we peek to see if a '(' implies a
1931          function call or a substring reference.  Otherwise the
1932          variable is just a scalar.  */
1933
1934       gfc_gobble_whitespace ();
1935       if (gfc_peek_char () != '(')
1936         {
1937           /* Assume a scalar variable */
1938           e = gfc_get_expr ();
1939           e->symtree = symtree;
1940           e->expr_type = EXPR_VARIABLE;
1941
1942           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
1943                               sym->name, NULL) == FAILURE)
1944             {
1945               m = MATCH_ERROR;
1946               break;
1947             }
1948
1949           e->ts = sym->ts;
1950           m = match_varspec (e, 0);
1951           break;
1952         }
1953
1954       /* See if this is a function reference with a keyword argument
1955          as first argument. We do this because otherwise a spurious
1956          symbol would end up in the symbol table.  */
1957
1958       old_loc = gfc_current_locus;
1959       m2 = gfc_match (" ( %n =", argname);
1960       gfc_current_locus = old_loc;
1961
1962       e = gfc_get_expr ();
1963       e->symtree = symtree;
1964
1965       if (m2 != MATCH_YES)
1966         {
1967           /* See if this could possibly be a substring reference of a name
1968              that we're not sure is a variable yet.  */
1969
1970           if ((sym->ts.type == BT_UNKNOWN || sym->ts.type == BT_CHARACTER)
1971               && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
1972             {
1973
1974               e->expr_type = EXPR_VARIABLE;
1975
1976               if (sym->attr.flavor != FL_VARIABLE
1977                   && gfc_add_flavor (&sym->attr, FL_VARIABLE,
1978                                      sym->name, NULL) == FAILURE)
1979                 {
1980                   m = MATCH_ERROR;
1981                   break;
1982                 }
1983
1984               if (sym->ts.type == BT_UNKNOWN
1985                   && gfc_set_default_type (sym, 1, NULL) == FAILURE)
1986                 {
1987                   m = MATCH_ERROR;
1988                   break;
1989                 }
1990
1991               e->ts = sym->ts;
1992               m = MATCH_YES;
1993               break;
1994             }
1995         }
1996
1997       /* Give up, assume we have a function.  */
1998
1999       gfc_get_sym_tree (name, NULL, &symtree);  /* Can't fail */
2000       sym = symtree->n.sym;
2001       e->expr_type = EXPR_FUNCTION;
2002
2003       if (!sym->attr.function
2004           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2005         {
2006           m = MATCH_ERROR;
2007           break;
2008         }
2009
2010       sym->result = sym;
2011
2012       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2013       if (m == MATCH_NO)
2014         gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2015
2016       if (m != MATCH_YES)
2017         {
2018           m = MATCH_ERROR;
2019           break;
2020         }
2021
2022       /* If our new function returns a character, array or structure
2023          type, it might have subsequent references.  */
2024
2025       m = match_varspec (e, 0);
2026       if (m == MATCH_NO)
2027         m = MATCH_YES;
2028
2029       break;
2030
2031     generic_function:
2032       gfc_get_sym_tree (name, NULL, &symtree);  /* Can't fail */
2033
2034       e = gfc_get_expr ();
2035       e->symtree = symtree;
2036       e->expr_type = EXPR_FUNCTION;
2037
2038       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2039       break;
2040
2041     default:
2042       gfc_error ("Symbol at %C is not appropriate for an expression");
2043       return MATCH_ERROR;
2044     }
2045
2046   if (m == MATCH_YES)
2047     {
2048       e->where = where;
2049       *result = e;
2050     }
2051   else
2052     gfc_free_expr (e);
2053
2054   return m;
2055 }
2056
2057
2058 /* Match a variable, ie something that can be assigned to.  This
2059    starts as a symbol, can be a structure component or an array
2060    reference.  It can be a function if the function doesn't have a
2061    separate RESULT variable.  If the symbol has not been previously
2062    seen, we assume it is a variable.  */
2063
2064 match
2065 gfc_match_variable (gfc_expr ** result, int equiv_flag)
2066 {
2067   gfc_symbol *sym;
2068   gfc_symtree *st;
2069   gfc_expr *expr;
2070   locus where;
2071   match m;
2072
2073   m = gfc_match_sym_tree (&st, 1);
2074   if (m != MATCH_YES)
2075     return m;
2076   where = gfc_current_locus;
2077
2078   sym = st->n.sym;
2079   gfc_set_sym_referenced (sym);
2080   switch (sym->attr.flavor)
2081     {
2082     case FL_VARIABLE:
2083       break;
2084
2085     case FL_UNKNOWN:
2086       if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2087                           sym->name, NULL) == FAILURE)
2088         return MATCH_ERROR;
2089       break;
2090
2091     case FL_PROCEDURE:
2092       /* Check for a nonrecursive function result */
2093       if (sym->attr.function && (sym->result == sym || sym->attr.entry))
2094         {
2095           /* If a function result is a derived type, then the derived
2096              type may still have to be resolved.  */
2097
2098           if (sym->ts.type == BT_DERIVED
2099               && gfc_use_derived (sym->ts.derived) == NULL)
2100             return MATCH_ERROR;
2101           break;
2102         }
2103
2104       /* Fall through to error */
2105
2106     default:
2107       gfc_error ("Expected VARIABLE at %C");
2108       return MATCH_ERROR;
2109     }
2110
2111   /* Special case for derived type variables that get their types
2112      via an IMPLICIT statement.  This can't wait for the
2113      resolution phase.  */
2114
2115     {
2116       gfc_namespace * implicit_ns;
2117
2118       if (gfc_current_ns->proc_name == sym)
2119         implicit_ns = gfc_current_ns;
2120       else
2121         implicit_ns = sym->ns;
2122
2123       if (gfc_peek_char () == '%'
2124           && sym->ts.type == BT_UNKNOWN
2125           && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
2126         gfc_set_default_type (sym, 0, implicit_ns);
2127     }
2128
2129   expr = gfc_get_expr ();
2130
2131   expr->expr_type = EXPR_VARIABLE;
2132   expr->symtree = st;
2133   expr->ts = sym->ts;
2134   expr->where = where;
2135
2136   /* Now see if we have to do more.  */
2137   m = match_varspec (expr, equiv_flag);
2138   if (m != MATCH_YES)
2139     {
2140       gfc_free_expr (expr);
2141       return m;
2142     }
2143
2144   *result = expr;
2145   return MATCH_YES;
2146 }