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