gcc/fortran/primary.c

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