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     goto cleanup;
1121
1122   if (gfc_match_char (',') == MATCH_NO)
1123     {
1124       gfc_pop_error (&old_error);
1125       m = MATCH_NO;
1126       goto cleanup;
1127     }
1128
1129   /* If m is error, then something was wrong with the real part and we
1130      assume we have a complex constant because we've seen the ','.  An
1131      ambiguous case here is the start of an iterator list of some
1132      sort. These sort of lists are matched prior to coming here.  */
1133
1134   if (m == MATCH_ERROR)
1135     goto cleanup;
1136   gfc_pop_error (&old_error);
1137
1138   m = match_complex_part (&imag);
1139   if (m == MATCH_NO)
1140     goto syntax;
1141   if (m == MATCH_ERROR)
1142     goto cleanup;
1143
1144   m = gfc_match_char (')');
1145   if (m == MATCH_NO)
1146     {
1147       /* Give the matcher for implied do-loops a chance to run.  This
1148          yields a much saner error message for (/ (i, 4=i, 6) /).  */
1149       if (gfc_peek_char () == '=')
1150         {
1151           m = MATCH_ERROR;
1152           goto cleanup;
1153         }
1154       else
1155     goto syntax;
1156     }
1157
1158   if (m == MATCH_ERROR)
1159     goto cleanup;
1160
1161   /* Decide on the kind of this complex number.  */
1162   if (real->ts.type == BT_REAL)
1163     {
1164       if (imag->ts.type == BT_REAL)
1165         kind = gfc_kind_max (real, imag);
1166       else
1167         kind = real->ts.kind;
1168     }
1169   else
1170     {
1171       if (imag->ts.type == BT_REAL)
1172         kind = imag->ts.kind;
1173       else
1174         kind = gfc_default_real_kind;
1175     }
1176   target.type = BT_REAL;
1177   target.kind = kind;
1178
1179   if (real->ts.type != BT_REAL || kind != real->ts.kind)
1180     gfc_convert_type (real, &target, 2);
1181   if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1182     gfc_convert_type (imag, &target, 2);
1183
1184   e = gfc_convert_complex (real, imag, kind);
1185   e->where = gfc_current_locus;
1186
1187   gfc_free_expr (real);
1188   gfc_free_expr (imag);
1189
1190   *result = e;
1191   return MATCH_YES;
1192
1193 syntax:
1194   gfc_error ("Syntax error in COMPLEX constant at %C");
1195   m = MATCH_ERROR;
1196
1197 cleanup:
1198   gfc_free_expr (e);
1199   gfc_free_expr (real);
1200   gfc_free_expr (imag);
1201   gfc_current_locus = old_loc;
1202
1203   return m;
1204 }
1205
1206
1207 /* Match constants in any of several forms.  Returns nonzero for a
1208    match, zero for no match.  */
1209
1210 match
1211 gfc_match_literal_constant (gfc_expr ** result, int signflag)
1212 {
1213   match m;
1214
1215   m = match_complex_constant (result);
1216   if (m != MATCH_NO)
1217     return m;
1218
1219   m = match_string_constant (result);
1220   if (m != MATCH_NO)
1221     return m;
1222
1223   m = match_boz_constant (result);
1224   if (m != MATCH_NO)
1225     return m;
1226
1227   m = match_real_constant (result, signflag);
1228   if (m != MATCH_NO)
1229     return m;
1230
1231   m = match_hollerith_constant (result);
1232   if (m != MATCH_NO)
1233     return m;
1234
1235   m = match_integer_constant (result, signflag);
1236   if (m != MATCH_NO)
1237     return m;
1238
1239   m = match_logical_constant (result);
1240   if (m != MATCH_NO)
1241     return m;
1242
1243   return MATCH_NO;
1244 }
1245
1246
1247 /* Match a single actual argument value.  An actual argument is
1248    usually an expression, but can also be a procedure name.  If the
1249    argument is a single name, it is not always possible to tell
1250    whether the name is a dummy procedure or not.  We treat these cases
1251    by creating an argument that looks like a dummy procedure and
1252    fixing things later during resolution.  */
1253
1254 static match
1255 match_actual_arg (gfc_expr ** result)
1256 {
1257   char name[GFC_MAX_SYMBOL_LEN + 1];
1258   gfc_symtree *symtree;
1259   locus where, w;
1260   gfc_expr *e;
1261   int c;
1262
1263   where = gfc_current_locus;
1264
1265   switch (gfc_match_name (name))
1266     {
1267     case MATCH_ERROR:
1268       return MATCH_ERROR;
1269
1270     case MATCH_NO:
1271       break;
1272
1273     case MATCH_YES:
1274       w = gfc_current_locus;
1275       gfc_gobble_whitespace ();
1276       c = gfc_next_char ();
1277       gfc_current_locus = w;
1278
1279       if (c != ',' && c != ')')
1280         break;
1281
1282       if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1283         break;
1284       /* Handle error elsewhere.  */
1285
1286       /* Eliminate a couple of common cases where we know we don't
1287          have a function argument.  */
1288       if (symtree == NULL)
1289         {
1290           gfc_get_sym_tree (name, NULL, &symtree);
1291           gfc_set_sym_referenced (symtree->n.sym);
1292         }
1293       else
1294         {
1295           gfc_symbol *sym;
1296
1297           sym = symtree->n.sym;
1298           gfc_set_sym_referenced (sym);
1299           if (sym->attr.flavor != FL_PROCEDURE
1300               && sym->attr.flavor != FL_UNKNOWN)
1301             break;
1302
1303           /* If the symbol is a function with itself as the result and
1304              is being defined, then we have a variable.  */
1305           if (sym->result == sym
1306               && (gfc_current_ns->proc_name == sym
1307                   || (gfc_current_ns->parent != NULL
1308                       && gfc_current_ns->parent->proc_name == sym)))
1309             break;
1310         }
1311
1312       e = gfc_get_expr ();      /* Leave it unknown for now */
1313       e->symtree = symtree;
1314       e->expr_type = EXPR_VARIABLE;
1315       e->ts.type = BT_PROCEDURE;
1316       e->where = where;
1317
1318       *result = e;
1319       return MATCH_YES;
1320     }
1321
1322   gfc_current_locus = where;
1323   return gfc_match_expr (result);
1324 }
1325
1326
1327 /* Match a keyword argument.  */
1328
1329 static match
1330 match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base)
1331 {
1332   char name[GFC_MAX_SYMBOL_LEN + 1];
1333   gfc_actual_arglist *a;
1334   locus name_locus;
1335   match m;
1336
1337   name_locus = gfc_current_locus;
1338   m = gfc_match_name (name);
1339
1340   if (m != MATCH_YES)
1341     goto cleanup;
1342   if (gfc_match_char ('=') != MATCH_YES)
1343     {
1344       m = MATCH_NO;
1345       goto cleanup;
1346     }
1347
1348   m = match_actual_arg (&actual->expr);
1349   if (m != MATCH_YES)
1350     goto cleanup;
1351
1352   /* Make sure this name has not appeared yet.  */
1353
1354   if (name[0] != '\0')
1355     {
1356       for (a = base; a; a = a->next)
1357         if (a->name != NULL && strcmp (a->name, name) == 0)
1358           {
1359             gfc_error
1360               ("Keyword '%s' at %C has already appeared in the current "
1361                "argument list", name);
1362             return MATCH_ERROR;
1363           }
1364     }
1365
1366   actual->name = gfc_get_string (name);
1367   return MATCH_YES;
1368
1369 cleanup:
1370   gfc_current_locus = name_locus;
1371   return m;
1372 }
1373
1374
1375 /* Matches an actual argument list of a function or subroutine, from
1376    the opening parenthesis to the closing parenthesis.  The argument
1377    list is assumed to allow keyword arguments because we don't know if
1378    the symbol associated with the procedure has an implicit interface
1379    or not.  We make sure keywords are unique. If SUB_FLAG is set,
1380    we're matching the argument list of a subroutine.  */
1381
1382 match
1383 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
1384 {
1385   gfc_actual_arglist *head, *tail;
1386   int seen_keyword;
1387   gfc_st_label *label;
1388   locus old_loc;
1389   match m;
1390
1391   *argp = tail = NULL;
1392   old_loc = gfc_current_locus;
1393
1394   seen_keyword = 0;
1395
1396   if (gfc_match_char ('(') == MATCH_NO)
1397     return (sub_flag) ? MATCH_YES : MATCH_NO;
1398
1399   if (gfc_match_char (')') == MATCH_YES)
1400     return MATCH_YES;
1401   head = NULL;
1402
1403   for (;;)
1404     {
1405       if (head == NULL)
1406         head = tail = gfc_get_actual_arglist ();
1407       else
1408         {
1409           tail->next = gfc_get_actual_arglist ();
1410           tail = tail->next;
1411         }
1412
1413       if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1414         {
1415           m = gfc_match_st_label (&label, 0);
1416           if (m == MATCH_NO)
1417             gfc_error ("Expected alternate return label at %C");
1418           if (m != MATCH_YES)
1419             goto cleanup;
1420
1421           tail->label = label;
1422           goto next;
1423         }
1424
1425       /* After the first keyword argument is seen, the following
1426          arguments must also have keywords.  */
1427       if (seen_keyword)
1428         {
1429           m = match_keyword_arg (tail, head);
1430
1431           if (m == MATCH_ERROR)
1432             goto cleanup;
1433           if (m == MATCH_NO)
1434             {
1435               gfc_error
1436                 ("Missing keyword name in actual argument list at %C");
1437               goto cleanup;
1438             }
1439
1440         }
1441       else
1442         {
1443           /* See if we have the first keyword argument.  */
1444           m = match_keyword_arg (tail, head);
1445           if (m == MATCH_YES)
1446             seen_keyword = 1;
1447           if (m == MATCH_ERROR)
1448             goto cleanup;
1449
1450           if (m == MATCH_NO)
1451             {
1452               /* Try for a non-keyword argument.  */
1453               m = match_actual_arg (&tail->expr);
1454               if (m == MATCH_ERROR)
1455                 goto cleanup;
1456               if (m == MATCH_NO)
1457                 goto syntax;
1458             }
1459         }
1460
1461     next:
1462       if (gfc_match_char (')') == MATCH_YES)
1463         break;
1464       if (gfc_match_char (',') != MATCH_YES)
1465         goto syntax;
1466     }
1467
1468   *argp = head;
1469   return MATCH_YES;
1470
1471 syntax:
1472   gfc_error ("Syntax error in argument list at %C");
1473
1474 cleanup:
1475   gfc_free_actual_arglist (head);
1476   gfc_current_locus = old_loc;
1477
1478   return MATCH_ERROR;
1479 }
1480
1481
1482 /* Used by match_varspec() to extend the reference list by one
1483    element.  */
1484
1485 static gfc_ref *
1486 extend_ref (gfc_expr * primary, gfc_ref * tail)
1487 {
1488
1489   if (primary->ref == NULL)
1490     primary->ref = tail = gfc_get_ref ();
1491   else
1492     {
1493       if (tail == NULL)
1494         gfc_internal_error ("extend_ref(): Bad tail");
1495       tail->next = gfc_get_ref ();
1496       tail = tail->next;
1497     }
1498
1499   return tail;
1500 }
1501
1502
1503 /* Match any additional specifications associated with the current
1504    variable like member references or substrings.  If equiv_flag is
1505    set we only match stuff that is allowed inside an EQUIVALENCE
1506    statement.  */
1507
1508 static match
1509 match_varspec (gfc_expr * primary, int equiv_flag)
1510 {
1511   char name[GFC_MAX_SYMBOL_LEN + 1];
1512   gfc_ref *substring, *tail;
1513   gfc_component *component;
1514   gfc_symbol *sym;
1515   match m;
1516
1517   tail = NULL;
1518
1519   if (primary->symtree->n.sym->attr.dimension
1520       || (equiv_flag
1521           && gfc_peek_char () == '('))
1522     {
1523
1524       tail = extend_ref (primary, tail);
1525       tail->type = REF_ARRAY;
1526
1527       m = gfc_match_array_ref (&tail->u.ar, primary->symtree->n.sym->as,
1528                                equiv_flag);
1529       if (m != MATCH_YES)
1530         return m;
1531     }
1532
1533   sym = primary->symtree->n.sym;
1534   primary->ts = sym->ts;
1535
1536   if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
1537     goto check_substring;
1538
1539   sym = sym->ts.derived;
1540
1541   for (;;)
1542     {
1543       m = gfc_match_name (name);
1544       if (m == MATCH_NO)
1545         gfc_error ("Expected structure component name at %C");
1546       if (m != MATCH_YES)
1547         return MATCH_ERROR;
1548
1549       component = gfc_find_component (sym, name);
1550       if (component == NULL)
1551         return MATCH_ERROR;
1552
1553       tail = extend_ref (primary, tail);
1554       tail->type = REF_COMPONENT;
1555
1556       tail->u.c.component = component;
1557       tail->u.c.sym = sym;
1558
1559       primary->ts = component->ts;
1560
1561       if (component->as != NULL)
1562         {
1563           tail = extend_ref (primary, tail);
1564           tail->type = REF_ARRAY;
1565
1566           m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1567           if (m != MATCH_YES)
1568             return m;
1569         }
1570
1571       if (component->ts.type != BT_DERIVED
1572           || gfc_match_char ('%') != MATCH_YES)
1573         break;
1574
1575       sym = component->ts.derived;
1576     }
1577
1578 check_substring:
1579   if (primary->ts.type == BT_CHARACTER)
1580     {
1581       switch (match_substring (primary->ts.cl, equiv_flag, &substring))
1582         {
1583         case MATCH_YES:
1584           if (tail == NULL)
1585             primary->ref = substring;
1586           else
1587             tail->next = substring;
1588
1589           if (primary->expr_type == EXPR_CONSTANT)
1590             primary->expr_type = EXPR_SUBSTRING;
1591
1592           if (substring)
1593             primary->ts.cl = NULL;
1594
1595           break;
1596
1597         case MATCH_NO:
1598           break;
1599
1600         case MATCH_ERROR:
1601           return MATCH_ERROR;
1602         }
1603     }
1604
1605   return MATCH_YES;
1606 }
1607
1608
1609 /* Given an expression that is a variable, figure out what the
1610    ultimate variable's type and attribute is, traversing the reference
1611    structures if necessary.
1612
1613    This subroutine is trickier than it looks.  We start at the base
1614    symbol and store the attribute.  Component references load a
1615    completely new attribute.
1616
1617    A couple of rules come into play.  Subobjects of targets are always
1618    targets themselves.  If we see a component that goes through a
1619    pointer, then the expression must also be a target, since the
1620    pointer is associated with something (if it isn't core will soon be
1621    dumped).  If we see a full part or section of an array, the
1622    expression is also an array.
1623
1624    We can have at most one full array reference.  */
1625
1626 symbol_attribute
1627 gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
1628 {
1629   int dimension, pointer, target;
1630   symbol_attribute attr;
1631   gfc_ref *ref;
1632
1633   if (expr->expr_type != EXPR_VARIABLE)
1634     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1635
1636   ref = expr->ref;
1637   attr = expr->symtree->n.sym->attr;
1638
1639   dimension = attr.dimension;
1640   pointer = attr.pointer;
1641
1642   target = attr.target;
1643   if (pointer)
1644     target = 1;
1645
1646   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1647     *ts = expr->symtree->n.sym->ts;
1648
1649   for (; ref; ref = ref->next)
1650     switch (ref->type)
1651       {
1652       case REF_ARRAY:
1653
1654         switch (ref->u.ar.type)
1655           {
1656           case AR_FULL:
1657             dimension = 1;
1658             break;
1659
1660           case AR_SECTION:
1661             pointer = 0;
1662             dimension = 1;
1663             break;
1664
1665           case AR_ELEMENT:
1666             pointer = 0;
1667             break;
1668
1669           case AR_UNKNOWN:
1670             gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1671           }
1672
1673         break;
1674
1675       case REF_COMPONENT:
1676         gfc_get_component_attr (&attr, ref->u.c.component);
1677         if (ts != NULL)
1678           *ts = ref->u.c.component->ts;
1679
1680         pointer = ref->u.c.component->pointer;
1681         if (pointer)
1682           target = 1;
1683
1684         break;
1685
1686       case REF_SUBSTRING:
1687         pointer = 0;
1688         break;
1689       }
1690
1691   attr.dimension = dimension;
1692   attr.pointer = pointer;
1693   attr.target = target;
1694
1695   return attr;
1696 }
1697
1698
1699 /* Return the attribute from a general expression.  */
1700
1701 symbol_attribute
1702 gfc_expr_attr (gfc_expr * e)
1703 {
1704   symbol_attribute attr;
1705
1706   switch (e->expr_type)
1707     {
1708     case EXPR_VARIABLE:
1709       attr = gfc_variable_attr (e, NULL);
1710       break;
1711
1712     case EXPR_FUNCTION:
1713       gfc_clear_attr (&attr);
1714
1715       if (e->value.function.esym != NULL)
1716         attr = e->value.function.esym->result->attr;
1717
1718       /* TODO: NULL() returns pointers.  May have to take care of this
1719          here.  */
1720
1721       break;
1722
1723     default:
1724       gfc_clear_attr (&attr);
1725       break;
1726     }
1727
1728   return attr;
1729 }
1730
1731
1732 /* Match a structure constructor.  The initial symbol has already been
1733    seen.  */
1734
1735 match
1736 gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
1737 {
1738   gfc_constructor *head, *tail;
1739   gfc_component *comp;
1740   gfc_expr *e;
1741   locus where;
1742   match m;
1743
1744   head = tail = NULL;
1745
1746   if (gfc_match_char ('(') != MATCH_YES)
1747     goto syntax;
1748
1749   where = gfc_current_locus;
1750
1751   gfc_find_component (sym, NULL);
1752
1753   for (comp = sym->components; comp; comp = comp->next)
1754     {
1755       if (head == NULL)
1756         tail = head = gfc_get_constructor ();
1757       else
1758         {
1759           tail->next = gfc_get_constructor ();
1760           tail = tail->next;
1761         }
1762
1763       m = gfc_match_expr (&tail->expr);
1764       if (m == MATCH_NO)
1765         goto syntax;
1766       if (m == MATCH_ERROR)
1767         goto cleanup;
1768
1769       if (gfc_match_char (',') == MATCH_YES)
1770         {
1771           if (comp->next == NULL)
1772             {
1773               gfc_error
1774                 ("Too many components in structure constructor at %C");
1775               goto cleanup;
1776             }
1777
1778           continue;
1779         }
1780
1781       break;
1782     }
1783
1784   if (gfc_match_char (')') != MATCH_YES)
1785     goto syntax;
1786
1787   if (comp->next != NULL)
1788     {
1789       gfc_error ("Too few components in structure constructor at %C");
1790       goto cleanup;
1791     }
1792
1793   e = gfc_get_expr ();
1794
1795   e->expr_type = EXPR_STRUCTURE;
1796
1797   e->ts.type = BT_DERIVED;
1798   e->ts.derived = sym;
1799   e->where = where;
1800
1801   e->value.constructor = head;
1802
1803   *result = e;
1804   return MATCH_YES;
1805
1806 syntax:
1807   gfc_error ("Syntax error in structure constructor at %C");
1808
1809 cleanup:
1810   gfc_free_constructor (head);
1811   return MATCH_ERROR;
1812 }
1813
1814
1815 /* Matches a variable name followed by anything that might follow it--
1816    array reference, argument list of a function, etc.  */
1817
1818 match
1819 gfc_match_rvalue (gfc_expr ** result)
1820 {
1821   gfc_actual_arglist *actual_arglist;
1822   char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
1823   gfc_state_data *st;
1824   gfc_symbol *sym;
1825   gfc_symtree *symtree;
1826   locus where, old_loc;
1827   gfc_expr *e;
1828   match m, m2;
1829   int i;
1830
1831   m = gfc_match_name (name);
1832   if (m != MATCH_YES)
1833     return m;
1834
1835   if (gfc_find_state (COMP_INTERFACE) == SUCCESS)
1836     i = gfc_get_sym_tree (name, NULL, &symtree);
1837   else
1838     i = gfc_get_ha_sym_tree (name, &symtree);
1839
1840   if (i)
1841     return MATCH_ERROR;
1842
1843   sym = symtree->n.sym;
1844   e = NULL;
1845   where = gfc_current_locus;
1846
1847   gfc_set_sym_referenced (sym);
1848
1849   if (sym->attr.function && sym->result == sym
1850       && (gfc_current_ns->proc_name == sym
1851           || (gfc_current_ns->parent != NULL
1852               && gfc_current_ns->parent->proc_name == sym)))
1853     goto variable;
1854
1855   if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
1856     goto function0;
1857
1858   if (sym->attr.generic)
1859     goto generic_function;
1860
1861   switch (sym->attr.flavor)
1862     {
1863     case FL_VARIABLE:
1864     variable:
1865       if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
1866           && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
1867         gfc_set_default_type (sym, 0, sym->ns);
1868
1869       e = gfc_get_expr ();
1870
1871       e->expr_type = EXPR_VARIABLE;
1872       e->symtree = symtree;
1873
1874       m = match_varspec (e, 0);
1875       break;
1876
1877     case FL_PARAMETER:
1878       /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
1879          end up here.  Unfortunately, sym->value->expr_type is set to
1880          EXPR_CONSTANT, and so the if () branch would be followed without
1881          the !sym->as check.  */
1882       if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
1883         e = gfc_copy_expr (sym->value);
1884       else
1885         {
1886           e = gfc_get_expr ();
1887           e->expr_type = EXPR_VARIABLE;
1888         }
1889
1890       e->symtree = symtree;
1891       m = match_varspec (e, 0);
1892       break;
1893
1894     case FL_DERIVED:
1895       sym = gfc_use_derived (sym);
1896       if (sym == NULL)
1897         m = MATCH_ERROR;
1898       else
1899         m = gfc_match_structure_constructor (sym, &e);
1900       break;
1901
1902     /* If we're here, then the name is known to be the name of a
1903        procedure, yet it is not sure to be the name of a function.  */
1904     case FL_PROCEDURE:
1905       if (sym->attr.subroutine)
1906         {
1907           gfc_error ("Unexpected use of subroutine name '%s' at %C",
1908                      sym->name);
1909           m = MATCH_ERROR;
1910           break;
1911         }
1912
1913       /* At this point, the name has to be a non-statement function.
1914          If the name is the same as the current function being
1915          compiled, then we have a variable reference (to the function
1916          result) if the name is non-recursive.  */
1917
1918       st = gfc_enclosing_unit (NULL);
1919
1920       if (st != NULL && st->state == COMP_FUNCTION
1921           && st->sym == sym
1922           && !sym->attr.recursive)
1923         {
1924           e = gfc_get_expr ();
1925           e->symtree = symtree;
1926           e->expr_type = EXPR_VARIABLE;
1927
1928           m = match_varspec (e, 0);
1929           break;
1930         }
1931
1932     /* Match a function reference.  */
1933     function0:
1934       m = gfc_match_actual_arglist (0, &actual_arglist);
1935       if (m == MATCH_NO)
1936         {
1937           if (sym->attr.proc == PROC_ST_FUNCTION)
1938             gfc_error ("Statement function '%s' requires argument list at %C",
1939                        sym->name);
1940           else
1941             gfc_error ("Function '%s' requires an argument list at %C",
1942                        sym->name);
1943
1944           m = MATCH_ERROR;
1945           break;
1946         }
1947
1948       if (m != MATCH_YES)
1949         {
1950           m = MATCH_ERROR;
1951           break;
1952         }
1953
1954       gfc_get_ha_sym_tree (name, &symtree);     /* Can't fail */
1955       sym = symtree->n.sym;
1956
1957       e = gfc_get_expr ();
1958       e->symtree = symtree;
1959       e->expr_type = EXPR_FUNCTION;
1960       e->value.function.actual = actual_arglist;
1961       e->where = gfc_current_locus;
1962
1963       if (sym->as != NULL)
1964         e->rank = sym->as->rank;
1965
1966       if (!sym->attr.function
1967           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
1968         {
1969           m = MATCH_ERROR;
1970           break;
1971         }
1972
1973       if (sym->result == NULL)
1974         sym->result = sym;
1975
1976       m = MATCH_YES;
1977       break;
1978
1979     case FL_UNKNOWN:
1980
1981       /* Special case for derived type variables that get their types
1982          via an IMPLICIT statement.  This can't wait for the
1983          resolution phase.  */
1984
1985       if (gfc_peek_char () == '%'
1986           && sym->ts.type == BT_UNKNOWN
1987           && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
1988         gfc_set_default_type (sym, 0, sym->ns);
1989
1990       /* If the symbol has a dimension attribute, the expression is a
1991          variable.  */
1992
1993       if (sym->attr.dimension)
1994         {
1995           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
1996                               sym->name, NULL) == FAILURE)
1997             {
1998               m = MATCH_ERROR;
1999               break;
2000             }
2001
2002           e = gfc_get_expr ();
2003           e->symtree = symtree;
2004           e->expr_type = EXPR_VARIABLE;
2005           m = match_varspec (e, 0);
2006           break;
2007         }
2008
2009       /* Name is not an array, so we peek to see if a '(' implies a
2010          function call or a substring reference.  Otherwise the
2011          variable is just a scalar.  */
2012
2013       gfc_gobble_whitespace ();
2014       if (gfc_peek_char () != '(')
2015         {
2016           /* Assume a scalar variable */
2017           e = gfc_get_expr ();
2018           e->symtree = symtree;
2019           e->expr_type = EXPR_VARIABLE;
2020
2021           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2022                               sym->name, NULL) == FAILURE)
2023             {
2024               m = MATCH_ERROR;
2025               break;
2026             }
2027
2028           e->ts = sym->ts;
2029           m = match_varspec (e, 0);
2030           break;
2031         }
2032
2033       /* See if this is a function reference with a keyword argument
2034          as first argument. We do this because otherwise a spurious
2035          symbol would end up in the symbol table.  */
2036
2037       old_loc = gfc_current_locus;
2038       m2 = gfc_match (" ( %n =", argname);
2039       gfc_current_locus = old_loc;
2040
2041       e = gfc_get_expr ();
2042       e->symtree = symtree;
2043
2044       if (m2 != MATCH_YES)
2045         {
2046           /* See if this could possibly be a substring reference of a name
2047              that we're not sure is a variable yet.  */
2048
2049           if ((sym->ts.type == BT_UNKNOWN || sym->ts.type == BT_CHARACTER)
2050               && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
2051             {
2052
2053               e->expr_type = EXPR_VARIABLE;
2054
2055               if (sym->attr.flavor != FL_VARIABLE
2056                   && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2057                                      sym->name, NULL) == FAILURE)
2058                 {
2059                   m = MATCH_ERROR;
2060                   break;
2061                 }
2062
2063               if (sym->ts.type == BT_UNKNOWN
2064                   && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2065                 {
2066                   m = MATCH_ERROR;
2067                   break;
2068                 }
2069
2070               e->ts = sym->ts;
2071               if (e->ref)
2072                 e->ts.cl = NULL;
2073               m = MATCH_YES;
2074               break;
2075             }
2076         }
2077
2078       /* Give up, assume we have a function.  */
2079
2080       gfc_get_sym_tree (name, NULL, &symtree);  /* Can't fail */
2081       sym = symtree->n.sym;
2082       e->expr_type = EXPR_FUNCTION;
2083
2084       if (!sym->attr.function
2085           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2086         {
2087           m = MATCH_ERROR;
2088           break;
2089         }
2090
2091       sym->result = sym;
2092
2093       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2094       if (m == MATCH_NO)
2095         gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2096
2097       if (m != MATCH_YES)
2098         {
2099           m = MATCH_ERROR;
2100           break;
2101         }
2102
2103       /* If our new function returns a character, array or structure
2104          type, it might have subsequent references.  */
2105
2106       m = match_varspec (e, 0);
2107       if (m == MATCH_NO)
2108         m = MATCH_YES;
2109
2110       break;
2111
2112     generic_function:
2113       gfc_get_sym_tree (name, NULL, &symtree);  /* Can't fail */
2114
2115       e = gfc_get_expr ();
2116       e->symtree = symtree;
2117       e->expr_type = EXPR_FUNCTION;
2118
2119       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2120       break;
2121
2122     default:
2123       gfc_error ("Symbol at %C is not appropriate for an expression");
2124       return MATCH_ERROR;
2125     }
2126
2127   if (m == MATCH_YES)
2128     {
2129       e->where = where;
2130       *result = e;
2131     }
2132   else
2133     gfc_free_expr (e);
2134
2135   return m;
2136 }
2137
2138
2139 /* Match a variable, ie something that can be assigned to.  This
2140    starts as a symbol, can be a structure component or an array
2141    reference.  It can be a function if the function doesn't have a
2142    separate RESULT variable.  If the symbol has not been previously
2143    seen, we assume it is a variable.  */
2144
2145 match
2146 gfc_match_variable (gfc_expr ** result, int equiv_flag)
2147 {
2148   gfc_symbol *sym;
2149   gfc_symtree *st;
2150   gfc_expr *expr;
2151   locus where;
2152   match m;
2153
2154   m = gfc_match_sym_tree (&st, 1);
2155   if (m != MATCH_YES)
2156     return m;
2157   where = gfc_current_locus;
2158
2159   sym = st->n.sym;
2160   gfc_set_sym_referenced (sym);
2161   switch (sym->attr.flavor)
2162     {
2163     case FL_VARIABLE:
2164       break;
2165
2166     case FL_UNKNOWN:
2167       if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2168                           sym->name, NULL) == FAILURE)
2169         return MATCH_ERROR;
2170       break;
2171
2172     case FL_PROCEDURE:
2173       /* Check for a nonrecursive function result */
2174       if (sym->attr.function && (sym->result == sym || sym->attr.entry))
2175         {
2176           /* If a function result is a derived type, then the derived
2177              type may still have to be resolved.  */
2178
2179           if (sym->ts.type == BT_DERIVED
2180               && gfc_use_derived (sym->ts.derived) == NULL)
2181             return MATCH_ERROR;
2182           break;
2183         }
2184
2185       /* Fall through to error */
2186
2187     default:
2188       gfc_error ("Expected VARIABLE at %C");
2189       return MATCH_ERROR;
2190     }
2191
2192   /* Special case for derived type variables that get their types
2193      via an IMPLICIT statement.  This can't wait for the
2194      resolution phase.  */
2195
2196     {
2197       gfc_namespace * implicit_ns;
2198
2199       if (gfc_current_ns->proc_name == sym)
2200         implicit_ns = gfc_current_ns;
2201       else
2202         implicit_ns = sym->ns;
2203
2204       if (gfc_peek_char () == '%'
2205           && sym->ts.type == BT_UNKNOWN
2206           && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
2207         gfc_set_default_type (sym, 0, implicit_ns);
2208     }
2209
2210   expr = gfc_get_expr ();
2211
2212   expr->expr_type = EXPR_VARIABLE;
2213   expr->symtree = st;
2214   expr->ts = sym->ts;
2215   expr->where = where;
2216
2217   /* Now see if we have to do more.  */
2218   m = match_varspec (expr, equiv_flag);
2219   if (m != MATCH_YES)
2220     {
2221       gfc_free_expr (expr);
2222       return m;
2223     }
2224
2225   *result = expr;
2226   return MATCH_YES;
2227 }