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, 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);
  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: Interger 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, 0);
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
1916   m = gfc_match_name (name);
1917   if (m != MATCH_YES)
1918     return m;
1919
1920   if (gfc_find_state (COMP_INTERFACE) == SUCCESS)
1921     i = gfc_get_sym_tree (name, NULL, &symtree);
1922   else
1923     i = gfc_get_ha_sym_tree (name, &symtree);
1924
1925   if (i)
1926     return MATCH_ERROR;
1927
1928   sym = symtree->n.sym;
1929   e = NULL;
1930   where = gfc_current_locus;
1931
1932   gfc_set_sym_referenced (sym);
1933
1934   if (sym->attr.function && sym->result == sym)
1935     {
1936       if (gfc_current_ns->proc_name == sym
1937           || (gfc_current_ns->parent != NULL
1938               && gfc_current_ns->parent->proc_name == sym))
1939         goto variable;
1940
1941       if (sym->attr.entry
1942           && (sym->ns == gfc_current_ns
1943               || sym->ns == gfc_current_ns->parent))
1944         {
1945           gfc_entry_list *el = NULL;
1946
1947           for (el = sym->ns->entries; el; el = el->next)
1948             if (sym == el->sym)
1949               goto variable;
1950         }
1951     }
1952
1953   if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
1954     goto function0;
1955
1956   if (sym->attr.generic)
1957     goto generic_function;
1958
1959   switch (sym->attr.flavor)
1960     {
1961     case FL_VARIABLE:
1962     variable:
1963       if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
1964           && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
1965         gfc_set_default_type (sym, 0, sym->ns);
1966
1967       e = gfc_get_expr ();
1968
1969       e->expr_type = EXPR_VARIABLE;
1970       e->symtree = symtree;
1971
1972       m = match_varspec (e, 0);
1973       break;
1974
1975     case FL_PARAMETER:
1976       /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
1977          end up here.  Unfortunately, sym->value->expr_type is set to
1978          EXPR_CONSTANT, and so the if () branch would be followed without
1979          the !sym->as check.  */
1980       if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
1981         e = gfc_copy_expr (sym->value);
1982       else
1983         {
1984           e = gfc_get_expr ();
1985           e->expr_type = EXPR_VARIABLE;
1986         }
1987
1988       e->symtree = symtree;
1989       m = match_varspec (e, 0);
1990       break;
1991
1992     case FL_DERIVED:
1993       sym = gfc_use_derived (sym);
1994       if (sym == NULL)
1995         m = MATCH_ERROR;
1996       else
1997         m = gfc_match_structure_constructor (sym, &e);
1998       break;
1999
2000     /* If we're here, then the name is known to be the name of a
2001        procedure, yet it is not sure to be the name of a function.  */
2002     case FL_PROCEDURE:
2003       if (sym->attr.subroutine)
2004         {
2005           gfc_error ("Unexpected use of subroutine name '%s' at %C",
2006                      sym->name);
2007           m = MATCH_ERROR;
2008           break;
2009         }
2010
2011       /* At this point, the name has to be a non-statement function.
2012          If the name is the same as the current function being
2013          compiled, then we have a variable reference (to the function
2014          result) if the name is non-recursive.  */
2015
2016       st = gfc_enclosing_unit (NULL);
2017
2018       if (st != NULL && st->state == COMP_FUNCTION
2019           && st->sym == sym
2020           && !sym->attr.recursive)
2021         {
2022           e = gfc_get_expr ();
2023           e->symtree = symtree;
2024           e->expr_type = EXPR_VARIABLE;
2025
2026           m = match_varspec (e, 0);
2027           break;
2028         }
2029
2030     /* Match a function reference.  */
2031     function0:
2032       m = gfc_match_actual_arglist (0, &actual_arglist);
2033       if (m == MATCH_NO)
2034         {
2035           if (sym->attr.proc == PROC_ST_FUNCTION)
2036             gfc_error ("Statement function '%s' requires argument list at %C",
2037                        sym->name);
2038           else
2039             gfc_error ("Function '%s' requires an argument list at %C",
2040                        sym->name);
2041
2042           m = MATCH_ERROR;
2043           break;
2044         }
2045
2046       if (m != MATCH_YES)
2047         {
2048           m = MATCH_ERROR;
2049           break;
2050         }
2051
2052       gfc_get_ha_sym_tree (name, &symtree);     /* Can't fail */
2053       sym = symtree->n.sym;
2054
2055       e = gfc_get_expr ();
2056       e->symtree = symtree;
2057       e->expr_type = EXPR_FUNCTION;
2058       e->value.function.actual = actual_arglist;
2059       e->where = gfc_current_locus;
2060
2061       if (sym->as != NULL)
2062         e->rank = sym->as->rank;
2063
2064       if (!sym->attr.function
2065           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2066         {
2067           m = MATCH_ERROR;
2068           break;
2069         }
2070
2071       if (sym->result == NULL)
2072         sym->result = sym;
2073
2074       m = MATCH_YES;
2075       break;
2076
2077     case FL_UNKNOWN:
2078
2079       /* Special case for derived type variables that get their types
2080          via an IMPLICIT statement.  This can't wait for the
2081          resolution phase.  */
2082
2083       if (gfc_peek_char () == '%'
2084           && sym->ts.type == BT_UNKNOWN
2085           && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2086         gfc_set_default_type (sym, 0, sym->ns);
2087
2088       /* If the symbol has a dimension attribute, the expression is a
2089          variable.  */
2090
2091       if (sym->attr.dimension)
2092         {
2093           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2094                               sym->name, NULL) == FAILURE)
2095             {
2096               m = MATCH_ERROR;
2097               break;
2098             }
2099
2100           e = gfc_get_expr ();
2101           e->symtree = symtree;
2102           e->expr_type = EXPR_VARIABLE;
2103           m = match_varspec (e, 0);
2104           break;
2105         }
2106
2107       /* Name is not an array, so we peek to see if a '(' implies a
2108          function call or a substring reference.  Otherwise the
2109          variable is just a scalar.  */
2110
2111       gfc_gobble_whitespace ();
2112       if (gfc_peek_char () != '(')
2113         {
2114           /* Assume a scalar variable */
2115           e = gfc_get_expr ();
2116           e->symtree = symtree;
2117           e->expr_type = EXPR_VARIABLE;
2118
2119           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2120                               sym->name, NULL) == FAILURE)
2121             {
2122               m = MATCH_ERROR;
2123               break;
2124             }
2125
2126           e->ts = sym->ts;
2127           m = match_varspec (e, 0);
2128           break;
2129         }
2130
2131       /* See if this is a function reference with a keyword argument
2132          as first argument. We do this because otherwise a spurious
2133          symbol would end up in the symbol table.  */
2134
2135       old_loc = gfc_current_locus;
2136       m2 = gfc_match (" ( %n =", argname);
2137       gfc_current_locus = old_loc;
2138
2139       e = gfc_get_expr ();
2140       e->symtree = symtree;
2141
2142       if (m2 != MATCH_YES)
2143         {
2144           /* See if this could possibly be a substring reference of a name
2145              that we're not sure is a variable yet.  */
2146
2147           if ((sym->ts.type == BT_UNKNOWN || sym->ts.type == BT_CHARACTER)
2148               && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
2149             {
2150
2151               e->expr_type = EXPR_VARIABLE;
2152
2153               if (sym->attr.flavor != FL_VARIABLE
2154                   && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2155                                      sym->name, NULL) == FAILURE)
2156                 {
2157                   m = MATCH_ERROR;
2158                   break;
2159                 }
2160
2161               if (sym->ts.type == BT_UNKNOWN
2162                   && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2163                 {
2164                   m = MATCH_ERROR;
2165                   break;
2166                 }
2167
2168               e->ts = sym->ts;
2169               if (e->ref)
2170                 e->ts.cl = NULL;
2171               m = MATCH_YES;
2172               break;
2173             }
2174         }
2175
2176       /* Give up, assume we have a function.  */
2177
2178       gfc_get_sym_tree (name, NULL, &symtree);  /* Can't fail */
2179       sym = symtree->n.sym;
2180       e->expr_type = EXPR_FUNCTION;
2181
2182       if (!sym->attr.function
2183           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2184         {
2185           m = MATCH_ERROR;
2186           break;
2187         }
2188
2189       sym->result = sym;
2190
2191       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2192       if (m == MATCH_NO)
2193         gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2194
2195       if (m != MATCH_YES)
2196         {
2197           m = MATCH_ERROR;
2198           break;
2199         }
2200
2201       /* If our new function returns a character, array or structure
2202          type, it might have subsequent references.  */
2203
2204       m = match_varspec (e, 0);
2205       if (m == MATCH_NO)
2206         m = MATCH_YES;
2207
2208       break;
2209
2210     generic_function:
2211       gfc_get_sym_tree (name, NULL, &symtree);  /* Can't fail */
2212
2213       e = gfc_get_expr ();
2214       e->symtree = symtree;
2215       e->expr_type = EXPR_FUNCTION;
2216
2217       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2218       break;
2219
2220     default:
2221       gfc_error ("Symbol at %C is not appropriate for an expression");
2222       return MATCH_ERROR;
2223     }
2224
2225   if (m == MATCH_YES)
2226     {
2227       e->where = where;
2228       *result = e;
2229     }
2230   else
2231     gfc_free_expr (e);
2232
2233   return m;
2234 }
2235
2236
2237 /* Match a variable, ie something that can be assigned to.  This
2238    starts as a symbol, can be a structure component or an array
2239    reference.  It can be a function if the function doesn't have a
2240    separate RESULT variable.  If the symbol has not been previously
2241    seen, we assume it is a variable.
2242
2243    This function is called by two interface functions:
2244    gfc_match_variable, which has host_flag = 1, and
2245    gfc_match_equiv_variable, with host_flag = 0, to restrict the
2246    match of the symbol to the local scope.  */
2247
2248 static match
2249 match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
2250 {
2251   gfc_symbol *sym;
2252   gfc_symtree *st;
2253   gfc_expr *expr;
2254   locus where;
2255   match m;
2256
2257   m = gfc_match_sym_tree (&st, host_flag);
2258   if (m != MATCH_YES)
2259     return m;
2260   where = gfc_current_locus;
2261
2262   sym = st->n.sym;
2263   gfc_set_sym_referenced (sym);
2264   switch (sym->attr.flavor)
2265     {
2266     case FL_VARIABLE:
2267       break;
2268
2269     case FL_UNKNOWN:
2270       if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2271                           sym->name, NULL) == FAILURE)
2272         return MATCH_ERROR;
2273       break;
2274
2275     case FL_PROCEDURE:
2276       /* Check for a nonrecursive function result */
2277       if (sym->attr.function && (sym->result == sym || sym->attr.entry))
2278         {
2279           /* If a function result is a derived type, then the derived
2280              type may still have to be resolved.  */
2281
2282           if (sym->ts.type == BT_DERIVED
2283               && gfc_use_derived (sym->ts.derived) == NULL)
2284             return MATCH_ERROR;
2285           break;
2286         }
2287
2288       /* Fall through to error */
2289
2290     default:
2291       gfc_error ("Expected VARIABLE at %C");
2292       return MATCH_ERROR;
2293     }
2294
2295   /* Special case for derived type variables that get their types
2296      via an IMPLICIT statement.  This can't wait for the
2297      resolution phase.  */
2298
2299     {
2300       gfc_namespace * implicit_ns;
2301
2302       if (gfc_current_ns->proc_name == sym)
2303         implicit_ns = gfc_current_ns;
2304       else
2305         implicit_ns = sym->ns;
2306
2307       if (gfc_peek_char () == '%'
2308           && sym->ts.type == BT_UNKNOWN
2309           && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
2310         gfc_set_default_type (sym, 0, implicit_ns);
2311     }
2312
2313   expr = gfc_get_expr ();
2314
2315   expr->expr_type = EXPR_VARIABLE;
2316   expr->symtree = st;
2317   expr->ts = sym->ts;
2318   expr->where = where;
2319
2320   /* Now see if we have to do more.  */
2321   m = match_varspec (expr, equiv_flag);
2322   if (m != MATCH_YES)
2323     {
2324       gfc_free_expr (expr);
2325       return m;
2326     }
2327
2328   *result = expr;
2329   return MATCH_YES;
2330 }
2331
2332 match
2333 gfc_match_variable (gfc_expr ** result, int equiv_flag)
2334 {
2335   return match_variable (result, equiv_flag, 1);
2336 }
2337
2338 match
2339 gfc_match_equiv_variable (gfc_expr ** result)
2340 {
2341   return match_variable (result, 1, 0);
2342 }
2343