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