gcc/fortran/primary.c

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