gcc/fortran/primary.c

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