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