gcc/fortran/primary.c

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