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_current_locus = old_loc;
 174
 175   return length;
 176 }
 177
 178
 179 /* Match an integer (digit string and optional kind).
 180    A sign will be accepted if signflag is set.  */
 181
 182 static match
 183 match_integer_constant (gfc_expr ** result, int signflag)
 184 {
 185   int length, kind;
 186   locus old_loc;
 187   char *buffer;
 188   gfc_expr *e;
 189
 190   old_loc = gfc_current_locus;
 191   gfc_gobble_whitespace ();
 192
 193   length = match_digits (signflag, 10, NULL);
 194   gfc_current_locus = old_loc;
 195   if (length == -1)
 196     return MATCH_NO;
 197
 198   buffer = alloca (length + 1);
 199   memset (buffer, '\0', length + 1);
 200
 201   gfc_gobble_whitespace ();
 202
 203   match_digits (signflag, 10, buffer);
 204
 205   kind = get_kind ();
 206   if (kind == -2)
 207     kind = gfc_default_integer_kind ();
 208   if (kind == -1)
 209     return MATCH_ERROR;
 210
 211   if (gfc_validate_kind (BT_INTEGER, kind) == -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_current_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_current_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_current_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_current_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_current_locus = old_loc;
 423       return MATCH_NO;
 424     }
 425
 426   /* Convert the number.  */
 427   gfc_current_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_current_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_current_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_current_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_current_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_current_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_current_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_current_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_current_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_current_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_current_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_current_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_current_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_current_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_current_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. If SUB_FLAG is set,
1404    we're matching the argument list of a subroutine.  */
1405
1406 match
1407 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
1408 {
1409   gfc_actual_arglist *head, *tail;
1410   int seen_keyword;
1411   gfc_st_label *label;
1412   locus old_loc;
1413   match m;
1414
1415   *argp = tail = NULL;
1416   old_loc = gfc_current_locus;
1417
1418   seen_keyword = 0;
1419
1420   if (gfc_match_char ('(') == MATCH_NO)
1421     return (sub_flag) ? MATCH_YES : MATCH_NO;
1422
1423   if (gfc_match_char (')') == MATCH_YES)
1424     return MATCH_YES;
1425   head = NULL;
1426
1427   for (;;)
1428     {
1429       if (head == NULL)
1430         head = tail = gfc_get_actual_arglist ();
1431       else
1432         {
1433           tail->next = gfc_get_actual_arglist ();
1434           tail = tail->next;
1435         }
1436
1437       if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1438         {
1439           m = gfc_match_st_label (&label, 0);
1440           if (m == MATCH_NO)
1441             gfc_error ("Expected alternate return label at %C");
1442           if (m != MATCH_YES)
1443             goto cleanup;
1444
1445           tail->label = label;
1446           goto next;
1447         }
1448
1449       /* After the first keyword argument is seen, the following
1450          arguments must also have keywords.  */
1451       if (seen_keyword)
1452         {
1453           m = match_keyword_arg (tail, head);
1454
1455           if (m == MATCH_ERROR)
1456             goto cleanup;
1457           if (m == MATCH_NO)
1458             {
1459               gfc_error
1460                 ("Missing keyword name in actual argument list at %C");
1461               goto cleanup;
1462             }
1463
1464         }
1465       else
1466         {
1467           /* See if we have the first keyword argument.  */
1468           m = match_keyword_arg (tail, head);
1469           if (m == MATCH_YES)
1470             seen_keyword = 1;
1471           if (m == MATCH_ERROR)
1472             goto cleanup;
1473
1474           if (m == MATCH_NO)
1475             {
1476               /* Try for a non-keyword argument.  */
1477               m = match_actual_arg (&tail->expr);
1478               if (m == MATCH_ERROR)
1479                 goto cleanup;
1480               if (m == MATCH_NO)
1481                 goto syntax;
1482             }
1483         }
1484
1485     next:
1486       if (gfc_match_char (')') == MATCH_YES)
1487         break;
1488       if (gfc_match_char (',') != MATCH_YES)
1489         goto syntax;
1490     }
1491
1492   *argp = head;
1493   return MATCH_YES;
1494
1495 syntax:
1496   gfc_error ("Syntax error in argument list at %C");
1497
1498 cleanup:
1499   gfc_free_actual_arglist (head);
1500   gfc_current_locus = old_loc;
1501
1502   return MATCH_ERROR;
1503 }
1504
1505
1506 /* Used by match_varspec() to extend the reference list by one
1507    element.  */
1508
1509 static gfc_ref *
1510 extend_ref (gfc_expr * primary, gfc_ref * tail)
1511 {
1512
1513   if (primary->ref == NULL)
1514     primary->ref = tail = gfc_get_ref ();
1515   else
1516     {
1517       if (tail == NULL)
1518         gfc_internal_error ("extend_ref(): Bad tail");
1519       tail->next = gfc_get_ref ();
1520       tail = tail->next;
1521     }
1522
1523   return tail;
1524 }
1525
1526
1527 /* Match any additional specifications associated with the current
1528    variable like member references or substrings.  If equiv_flag is
1529    set we only match stuff that is allowed inside an EQUIVALENCE
1530    statement.  */
1531
1532 static match
1533 match_varspec (gfc_expr * primary, int equiv_flag)
1534 {
1535   char name[GFC_MAX_SYMBOL_LEN + 1];
1536   gfc_ref *substring, *tail;
1537   gfc_component *component;
1538   gfc_symbol *sym;
1539   match m;
1540
1541   tail = NULL;
1542
1543   if (primary->symtree->n.sym->attr.dimension
1544       || (equiv_flag
1545           && gfc_peek_char () == '('))
1546     {
1547
1548       tail = extend_ref (primary, tail);
1549       tail->type = REF_ARRAY;
1550
1551       m = gfc_match_array_ref (&tail->u.ar, primary->symtree->n.sym->as,
1552                                equiv_flag);
1553       if (m != MATCH_YES)
1554         return m;
1555     }
1556
1557   sym = primary->symtree->n.sym;
1558   primary->ts = sym->ts;
1559
1560   if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
1561     goto check_substring;
1562
1563   sym = sym->ts.derived;
1564
1565   for (;;)
1566     {
1567       m = gfc_match_name (name);
1568       if (m == MATCH_NO)
1569         gfc_error ("Expected structure component name at %C");
1570       if (m != MATCH_YES)
1571         return MATCH_ERROR;
1572
1573       component = gfc_find_component (sym, name);
1574       if (component == NULL)
1575         return MATCH_ERROR;
1576
1577       tail = extend_ref (primary, tail);
1578       tail->type = REF_COMPONENT;
1579
1580       tail->u.c.component = component;
1581       tail->u.c.sym = sym;
1582
1583       primary->ts = component->ts;
1584
1585       if (component->as != NULL)
1586         {
1587           tail = extend_ref (primary, tail);
1588           tail->type = REF_ARRAY;
1589
1590           m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1591           if (m != MATCH_YES)
1592             return m;
1593         }
1594
1595       if (component->ts.type != BT_DERIVED
1596           || gfc_match_char ('%') != MATCH_YES)
1597         break;
1598
1599       sym = component->ts.derived;
1600     }
1601
1602 check_substring:
1603   if (primary->ts.type == BT_CHARACTER)
1604     {
1605       switch (match_substring (primary->ts.cl, equiv_flag, &substring))
1606         {
1607         case MATCH_YES:
1608           if (tail == NULL)
1609             primary->ref = substring;
1610           else
1611             tail->next = substring;
1612
1613           if (primary->expr_type == EXPR_CONSTANT)
1614             primary->expr_type = EXPR_SUBSTRING;
1615
1616           break;
1617
1618         case MATCH_NO:
1619           break;
1620
1621         case MATCH_ERROR:
1622           return MATCH_ERROR;
1623         }
1624     }
1625
1626   return MATCH_YES;
1627 }
1628
1629
1630 /* Given an expression that is a variable, figure out what the
1631    ultimate variable's type and attribute is, traversing the reference
1632    structures if necessary.
1633
1634    This subroutine is trickier than it looks.  We start at the base
1635    symbol and store the attribute.  Component references load a
1636    completely new attribute.
1637
1638    A couple of rules come into play.  Subobjects of targets are always
1639    targets themselves.  If we see a component that goes through a
1640    pointer, then the expression must also be a target, since the
1641    pointer is associated with something (if it isn't core will soon be
1642    dumped).  If we see a full part or section of an array, the
1643    expression is also an array.
1644
1645    We can have at most one full array reference. */
1646
1647 symbol_attribute
1648 gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
1649 {
1650   int dimension, pointer, target;
1651   symbol_attribute attr;
1652   gfc_ref *ref;
1653
1654   if (expr->expr_type != EXPR_VARIABLE)
1655     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1656
1657   ref = expr->ref;
1658   attr = expr->symtree->n.sym->attr;
1659
1660   dimension = attr.dimension;
1661   pointer = attr.pointer;
1662
1663   target = attr.target;
1664   if (pointer)
1665     target = 1;
1666
1667   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1668     *ts = expr->symtree->n.sym->ts;
1669
1670   for (; ref; ref = ref->next)
1671     switch (ref->type)
1672       {
1673       case REF_ARRAY:
1674
1675         switch (ref->u.ar.type)
1676           {
1677           case AR_FULL:
1678             dimension = 1;
1679             break;
1680
1681           case AR_SECTION:
1682             pointer = 0;
1683             dimension = 1;
1684             break;
1685
1686           case AR_ELEMENT:
1687             pointer = 0;
1688             break;
1689
1690           case AR_UNKNOWN:
1691             gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1692           }
1693
1694         break;
1695
1696       case REF_COMPONENT:
1697         gfc_get_component_attr (&attr, ref->u.c.component);
1698         if (ts != NULL)
1699           *ts = ref->u.c.component->ts;
1700
1701         pointer = ref->u.c.component->pointer;
1702         if (pointer)
1703           target = 1;
1704
1705         break;
1706
1707       case REF_SUBSTRING:
1708         pointer = 0;
1709         break;
1710       }
1711
1712   attr.dimension = dimension;
1713   attr.pointer = pointer;
1714   attr.target = target;
1715
1716   return attr;
1717 }
1718
1719
1720 /* Return the attribute from a general expression.  */
1721
1722 symbol_attribute
1723 gfc_expr_attr (gfc_expr * e)
1724 {
1725   symbol_attribute attr;
1726
1727   switch (e->expr_type)
1728     {
1729     case EXPR_VARIABLE:
1730       attr = gfc_variable_attr (e, NULL);
1731       break;
1732
1733     case EXPR_FUNCTION:
1734       gfc_clear_attr (&attr);
1735
1736       if (e->value.function.esym != NULL)
1737         attr = e->value.function.esym->result->attr;
1738
1739       /* TODO: NULL() returns pointers.  May have to take care of this
1740          here.  */
1741
1742       break;
1743
1744     default:
1745       gfc_clear_attr (&attr);
1746       break;
1747     }
1748
1749   return attr;
1750 }
1751
1752
1753 /* Match a structure constructor.  The initial symbol has already been
1754    seen.  */
1755
1756 match
1757 gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
1758 {
1759   gfc_constructor *head, *tail;
1760   gfc_component *comp;
1761   gfc_expr *e;
1762   locus where;
1763   match m;
1764
1765   head = tail = NULL;
1766
1767   if (gfc_match_char ('(') != MATCH_YES)
1768     goto syntax;
1769
1770   where = gfc_current_locus;
1771
1772   gfc_find_component (sym, NULL);
1773
1774   for (comp = sym->components; comp; comp = comp->next)
1775     {
1776       if (head == NULL)
1777         tail = head = gfc_get_constructor ();
1778       else
1779         {
1780           tail->next = gfc_get_constructor ();
1781           tail = tail->next;
1782         }
1783
1784       m = gfc_match_expr (&tail->expr);
1785       if (m == MATCH_NO)
1786         goto syntax;
1787       if (m == MATCH_ERROR)
1788         goto cleanup;
1789
1790       if (gfc_match_char (',') == MATCH_YES)
1791         {
1792           if (comp->next == NULL)
1793             {
1794               gfc_error
1795                 ("Too many components in structure constructor at %C");
1796               goto cleanup;
1797             }
1798
1799           continue;
1800         }
1801
1802       break;
1803     }
1804
1805   if (gfc_match_char (')') != MATCH_YES)
1806     goto syntax;
1807
1808   if (comp->next != NULL)
1809     {
1810       gfc_error ("Too few components in structure constructor at %C");
1811       goto cleanup;
1812     }
1813
1814   e = gfc_get_expr ();
1815
1816   e->expr_type = EXPR_STRUCTURE;
1817
1818   e->ts.type = BT_DERIVED;
1819   e->ts.derived = sym;
1820   e->where = where;
1821
1822   e->value.constructor = head;
1823
1824   *result = e;
1825   return MATCH_YES;
1826
1827 syntax:
1828   gfc_error ("Syntax error in structure constructor at %C");
1829
1830 cleanup:
1831   gfc_free_constructor (head);
1832   return MATCH_ERROR;
1833 }
1834
1835
1836 /* Matches a variable name followed by anything that might follow it--
1837    array reference, argument list of a function, etc.  */
1838
1839 match
1840 gfc_match_rvalue (gfc_expr ** result)
1841 {
1842   gfc_actual_arglist *actual_arglist;
1843   char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
1844   gfc_state_data *st;
1845   gfc_symbol *sym;
1846   gfc_symtree *symtree;
1847   locus where, old_loc;
1848   gfc_expr *e;
1849   match m, m2;
1850   int i;
1851
1852   m = gfc_match_name (name);
1853   if (m != MATCH_YES)
1854     return m;
1855
1856   if (gfc_find_state (COMP_INTERFACE) == SUCCESS)
1857     i = gfc_get_sym_tree (name, NULL, &symtree);
1858   else
1859     i = gfc_get_ha_sym_tree (name, &symtree);
1860
1861   if (i)
1862     return MATCH_ERROR;
1863
1864   sym = symtree->n.sym;
1865   e = NULL;
1866   where = gfc_current_locus;
1867
1868   gfc_set_sym_referenced (sym);
1869
1870   if (sym->attr.function && sym->result == sym
1871       && (gfc_current_ns->proc_name == sym
1872           || (gfc_current_ns->parent != NULL
1873               && gfc_current_ns->parent->proc_name == sym)))
1874     goto variable;
1875
1876   if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
1877     goto function0;
1878
1879   if (sym->attr.generic)
1880     goto generic_function;
1881
1882   switch (sym->attr.flavor)
1883     {
1884     case FL_VARIABLE:
1885     variable:
1886       if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
1887           && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
1888         gfc_set_default_type (sym, 0, sym->ns);
1889
1890       e = gfc_get_expr ();
1891
1892       e->expr_type = EXPR_VARIABLE;
1893       e->symtree = symtree;
1894
1895       m = match_varspec (e, 0);
1896       break;
1897
1898     case FL_PARAMETER:
1899       if (sym->value
1900           && sym->value->expr_type != EXPR_ARRAY)
1901         e = gfc_copy_expr (sym->value);
1902       else
1903         {
1904           e = gfc_get_expr ();
1905           e->expr_type = EXPR_VARIABLE;
1906         }
1907
1908       e->symtree = symtree;
1909       m = match_varspec (e, 0);
1910       break;
1911
1912     case FL_DERIVED:
1913       sym = gfc_use_derived (sym);
1914       if (sym == NULL)
1915         m = MATCH_ERROR;
1916       else
1917         m = gfc_match_structure_constructor (sym, &e);
1918       break;
1919
1920     /* If we're here, then the name is known to be the name of a
1921        procedure, yet it is not sure to be the name of a function.  */
1922     case FL_PROCEDURE:
1923       if (sym->attr.subroutine)
1924         {
1925           gfc_error ("Unexpected use of subroutine name '%s' at %C",
1926                      sym->name);
1927           m = MATCH_ERROR;
1928           break;
1929         }
1930
1931       /* At this point, the name has to be a non-statement function.
1932          If the name is the same as the current function being
1933          compiled, then we have a variable reference (to the function
1934          result) if the name is non-recursive.  */
1935
1936       st = gfc_enclosing_unit (NULL);
1937
1938       if (st != NULL && st->state == COMP_FUNCTION
1939           && st->sym == sym
1940           && !sym->attr.recursive)
1941         {
1942           e = gfc_get_expr ();
1943           e->symtree = symtree;
1944           e->expr_type = EXPR_VARIABLE;
1945
1946           m = match_varspec (e, 0);
1947           break;
1948         }
1949
1950     /* Match a function reference.  */
1951     function0:
1952       m = gfc_match_actual_arglist (0, &actual_arglist);
1953       if (m == MATCH_NO)
1954         {
1955           if (sym->attr.proc == PROC_ST_FUNCTION)
1956             gfc_error ("Statement function '%s' requires argument list at %C",
1957                        sym->name);
1958           else
1959             gfc_error ("Function '%s' requires an argument list at %C",
1960                        sym->name);
1961
1962           m = MATCH_ERROR;
1963           break;
1964         }
1965
1966       if (m != MATCH_YES)
1967         {
1968           m = MATCH_ERROR;
1969           break;
1970         }
1971
1972       gfc_get_ha_sym_tree (name, &symtree);     /* Can't fail */
1973       sym = symtree->n.sym;
1974
1975       e = gfc_get_expr ();
1976       e->symtree = symtree;
1977       e->expr_type = EXPR_FUNCTION;
1978       e->value.function.actual = actual_arglist;
1979       e->where = gfc_current_locus;
1980
1981       if (sym->as != NULL)
1982         e->rank = sym->as->rank;
1983
1984       if (!sym->attr.function
1985           && gfc_add_function (&sym->attr, NULL) == FAILURE)
1986         {
1987           m = MATCH_ERROR;
1988           break;
1989         }
1990
1991       if (sym->result == NULL)
1992         sym->result = sym;
1993
1994       m = MATCH_YES;
1995       break;
1996
1997     case FL_UNKNOWN:
1998
1999       /* Special case for derived type variables that get their types
2000          via an IMPLICIT statement.  This can't wait for the
2001          resolution phase.  */
2002
2003       if (gfc_peek_char () == '%'
2004           && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2005         gfc_set_default_type (sym, 0, sym->ns);
2006
2007       /* If the symbol has a dimension attribute, the expression is a
2008          variable.  */
2009
2010       if (sym->attr.dimension)
2011         {
2012           if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
2013             {
2014               m = MATCH_ERROR;
2015               break;
2016             }
2017
2018           e = gfc_get_expr ();
2019           e->symtree = symtree;
2020           e->expr_type = EXPR_VARIABLE;
2021           m = match_varspec (e, 0);
2022           break;
2023         }
2024
2025       /* Name is not an array, so we peek to see if a '(' implies a
2026          function call or a substring reference.  Otherwise the
2027          variable is just a scalar.  */
2028
2029       gfc_gobble_whitespace ();
2030       if (gfc_peek_char () != '(')
2031         {
2032           /* Assume a scalar variable */
2033           e = gfc_get_expr ();
2034           e->symtree = symtree;
2035           e->expr_type = EXPR_VARIABLE;
2036
2037           if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
2038             {
2039               m = MATCH_ERROR;
2040               break;
2041             }
2042
2043           e->ts = sym->ts;
2044           m = match_varspec (e, 0);
2045           break;
2046         }
2047
2048       /* See if this is a function reference with a keyword argument
2049          as first argument. We do this because otherwise a spurious
2050          symbol would end up in the symbol table.  */
2051
2052       old_loc = gfc_current_locus;
2053       m2 = gfc_match (" ( %n =", argname);
2054       gfc_current_locus = old_loc;
2055
2056       e = gfc_get_expr ();
2057       e->symtree = symtree;
2058
2059       if (m2 != MATCH_YES)
2060         {
2061           /* See if this could possibly be a substring reference of a name
2062              that we're not sure is a variable yet.  */
2063
2064           if ((sym->ts.type == BT_UNKNOWN || sym->ts.type == BT_CHARACTER)
2065               && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
2066             {
2067
2068               e->expr_type = EXPR_VARIABLE;
2069
2070               if (sym->attr.flavor != FL_VARIABLE
2071                   && gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
2072                 {
2073                   m = MATCH_ERROR;
2074                   break;
2075                 }
2076
2077               if (sym->ts.type == BT_UNKNOWN
2078                   && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2079                 {
2080                   m = MATCH_ERROR;
2081                   break;
2082                 }
2083
2084               e->ts = sym->ts;
2085               m = MATCH_YES;
2086               break;
2087             }
2088         }
2089
2090       /* Give up, assume we have a function.  */
2091
2092       gfc_get_sym_tree (name, NULL, &symtree);  /* Can't fail */
2093       sym = symtree->n.sym;
2094       e->expr_type = EXPR_FUNCTION;
2095
2096       if (!sym->attr.function
2097           && gfc_add_function (&sym->attr, NULL) == FAILURE)
2098         {
2099           m = MATCH_ERROR;
2100           break;
2101         }
2102
2103       sym->result = sym;
2104
2105       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2106       if (m == MATCH_NO)
2107         gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2108
2109       if (m != MATCH_YES)
2110         {
2111           m = MATCH_ERROR;
2112           break;
2113         }
2114
2115       /* If our new function returns a character, array or structure
2116          type, it might have subsequent references.  */
2117
2118       m = match_varspec (e, 0);
2119       if (m == MATCH_NO)
2120         m = MATCH_YES;
2121
2122       break;
2123
2124     generic_function:
2125       gfc_get_sym_tree (name, NULL, &symtree);  /* Can't fail */
2126
2127       e = gfc_get_expr ();
2128       e->symtree = symtree;
2129       e->expr_type = EXPR_FUNCTION;
2130
2131       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2132       break;
2133
2134     default:
2135       gfc_error ("Symbol at %C is not appropriate for an expression");
2136       return MATCH_ERROR;
2137     }
2138
2139   if (m == MATCH_YES)
2140     {
2141       e->where = where;
2142       *result = e;
2143     }
2144   else
2145     gfc_free_expr (e);
2146
2147   return m;
2148 }
2149
2150
2151 /* Match a variable, ie something that can be assigned to.  This
2152    starts as a symbol, can be a structure component or an array
2153    reference.  It can be a function if the function doesn't have a
2154    separate RESULT variable.  If the symbol has not been previously
2155    seen, we assume it is a variable.  */
2156
2157 match
2158 gfc_match_variable (gfc_expr ** result, int equiv_flag)
2159 {
2160   gfc_symbol *sym;
2161   gfc_symtree *st;
2162   gfc_expr *expr;
2163   locus where;
2164   match m;
2165
2166   m = gfc_match_sym_tree (&st, 1);
2167   if (m != MATCH_YES)
2168     return m;
2169   where = gfc_current_locus;
2170
2171   sym = st->n.sym;
2172   gfc_set_sym_referenced (sym);
2173   switch (sym->attr.flavor)
2174     {
2175     case FL_VARIABLE:
2176       break;
2177
2178     case FL_UNKNOWN:
2179       if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
2180         return MATCH_ERROR;
2181
2182       /* Special case for derived type variables that get their types
2183          via an IMPLICIT statement.  This can't wait for the
2184          resolution phase.  */
2185
2186       if (gfc_peek_char () == '%'
2187           && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2188         gfc_set_default_type (sym, 0, sym->ns);
2189
2190       break;
2191
2192     case FL_PROCEDURE:
2193       /* Check for a nonrecursive function result */
2194       if (sym->attr.function && (sym->result == sym || sym->attr.entry))
2195         {
2196
2197           /* If a function result is a derived type, then the derived
2198              type may still have to be resolved.  */
2199
2200           if (sym->ts.type == BT_DERIVED
2201               && gfc_use_derived (sym->ts.derived) == NULL)
2202             return MATCH_ERROR;
2203
2204           break;
2205         }
2206
2207       /* Fall through to error */
2208
2209     default:
2210       gfc_error ("Expected VARIABLE at %C");
2211       return MATCH_ERROR;
2212     }
2213
2214   expr = gfc_get_expr ();
2215
2216   expr->expr_type = EXPR_VARIABLE;
2217   expr->symtree = st;
2218   expr->ts = sym->ts;
2219   expr->where = where;
2220
2221   /* Now see if we have to do more.  */
2222   m = match_varspec (expr, equiv_flag);
2223   if (m != MATCH_YES)
2224     {
2225       gfc_free_expr (expr);
2226       return m;
2227     }
2228
2229   *result = expr;
2230   return MATCH_YES;
2231 }