gcc/fortran/primary.c

   1 /* Primary expression subroutines
   2    Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
   3    Free Software Foundation, 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 3, 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 COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "flags.h"
  25 #include "gfortran.h"
  26 #include "arith.h"
  27 #include "match.h"
  28 #include "parse.h"
  29 #include "toplev.h"
  30
  31 /* Matches a kind-parameter expression, which is either a named
  32    symbolic constant or a nonnegative integer constant.  If
  33    successful, sets the kind value to the correct integer.  */
  34
  35 static match
  36 match_kind_param (int *kind)
  37 {
  38   char name[GFC_MAX_SYMBOL_LEN + 1];
  39   gfc_symbol *sym;
  40   const char *p;
  41   match m;
  42
  43   m = gfc_match_small_literal_int (kind, NULL);
  44   if (m != MATCH_NO)
  45     return m;
  46
  47   m = gfc_match_name (name);
  48   if (m != MATCH_YES)
  49     return m;
  50
  51   if (gfc_find_symbol (name, NULL, 1, &sym))
  52     return MATCH_ERROR;
  53
  54   if (sym == NULL)
  55     return MATCH_NO;
  56
  57   if (sym->attr.flavor != FL_PARAMETER)
  58     return MATCH_NO;
  59
  60   if (sym->value == NULL)
  61     return MATCH_NO;
  62
  63   p = gfc_extract_int (sym->value, kind);
  64   if (p != NULL)
  65     return MATCH_NO;
  66
  67   gfc_set_sym_referenced (sym);
  68
  69   if (*kind < 0)
  70     return MATCH_NO;
  71
  72   return MATCH_YES;
  73 }
  74
  75
  76 /* Get a trailing kind-specification for non-character variables.
  77    Returns:
  78       the integer kind value or:
  79       -1 if an error was generated
  80       -2 if no kind was found */
  81
  82 static int
  83 get_kind (void)
  84 {
  85   int kind;
  86   match m;
  87
  88   if (gfc_match_char ('_') != MATCH_YES)
  89     return -2;
  90
  91   m = match_kind_param (&kind);
  92   if (m == MATCH_NO)
  93     gfc_error ("Missing kind-parameter at %C");
  94
  95   return (m == MATCH_YES) ? kind : -1;
  96 }
  97
  98
  99 /* Given a character and a radix, see if the character is a valid
 100    digit in that radix.  */
 101
 102 int
 103 gfc_check_digit (char c, int radix)
 104 {
 105   int r;
 106
 107   switch (radix)
 108     {
 109     case 2:
 110       r = ('0' <= c && c <= '1');
 111       break;
 112
 113     case 8:
 114       r = ('0' <= c && c <= '7');
 115       break;
 116
 117     case 10:
 118       r = ('0' <= c && c <= '9');
 119       break;
 120
 121     case 16:
 122       r = ISXDIGIT (c);
 123       break;
 124
 125     default:
 126       gfc_internal_error ("gfc_check_digit(): bad radix");
 127     }
 128
 129   return r;
 130 }
 131
 132
 133 /* Match the digit string part of an integer if signflag is not set,
 134    the signed digit string part if signflag is set.  If the buffer
 135    is NULL, we just count characters for the resolution pass.  Returns
 136    the number of characters matched, -1 for no match.  */
 137
 138 static int
 139 match_digits (int signflag, int radix, char *buffer)
 140 {
 141   locus old_loc;
 142   int length;
 143   char c;
 144
 145   length = 0;
 146   c = gfc_next_ascii_char ();
 147
 148   if (signflag && (c == '+' || c == '-'))
 149     {
 150       if (buffer != NULL)
 151         *buffer++ = c;
 152       gfc_gobble_whitespace ();
 153       c = gfc_next_ascii_char ();
 154       length++;
 155     }
 156
 157   if (!gfc_check_digit (c, radix))
 158     return -1;
 159
 160   length++;
 161   if (buffer != NULL)
 162     *buffer++ = c;
 163
 164   for (;;)
 165     {
 166       old_loc = gfc_current_locus;
 167       c = gfc_next_ascii_char ();
 168
 169       if (!gfc_check_digit (c, radix))
 170         break;
 171
 172       if (buffer != NULL)
 173         *buffer++ = c;
 174       length++;
 175     }
 176
 177   gfc_current_locus = old_loc;
 178
 179   return length;
 180 }
 181
 182
 183 /* Match an integer (digit string and optional kind).
 184    A sign will be accepted if signflag is set.  */
 185
 186 static match
 187 match_integer_constant (gfc_expr **result, int signflag)
 188 {
 189   int length, kind;
 190   locus old_loc;
 191   char *buffer;
 192   gfc_expr *e;
 193
 194   old_loc = gfc_current_locus;
 195   gfc_gobble_whitespace ();
 196
 197   length = match_digits (signflag, 10, NULL);
 198   gfc_current_locus = old_loc;
 199   if (length == -1)
 200     return MATCH_NO;
 201
 202   buffer = (char *) alloca (length + 1);
 203   memset (buffer, '\0', length + 1);
 204
 205   gfc_gobble_whitespace ();
 206
 207   match_digits (signflag, 10, buffer);
 208
 209   kind = get_kind ();
 210   if (kind == -2)
 211     kind = gfc_default_integer_kind;
 212   if (kind == -1)
 213     return MATCH_ERROR;
 214
 215   if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
 216     {
 217       gfc_error ("Integer kind %d at %C not available", kind);
 218       return MATCH_ERROR;
 219     }
 220
 221   e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
 222
 223   if (gfc_range_check (e) != ARITH_OK)
 224     {
 225       gfc_error ("Integer too big for its kind at %C. This check can be "
 226                  "disabled with the option -fno-range-check");
 227
 228       gfc_free_expr (e);
 229       return MATCH_ERROR;
 230     }
 231
 232   *result = e;
 233   return MATCH_YES;
 234 }
 235
 236
 237 /* Match a Hollerith constant.  */
 238
 239 static match
 240 match_hollerith_constant (gfc_expr **result)
 241 {
 242   locus old_loc;
 243   gfc_expr *e = NULL;
 244   const char *msg;
 245   int num;
 246   int i;
 247
 248   old_loc = gfc_current_locus;
 249   gfc_gobble_whitespace ();
 250
 251   if (match_integer_constant (&e, 0) == MATCH_YES
 252       && gfc_match_char ('h') == MATCH_YES)
 253     {
 254       if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
 255                           "at %C") == FAILURE)
 256         goto cleanup;
 257
 258       msg = gfc_extract_int (e, &num);
 259       if (msg != NULL)
 260         {
 261           gfc_error (msg);
 262           goto cleanup;
 263         }
 264       if (num == 0)
 265         {
 266           gfc_error ("Invalid Hollerith constant: %L must contain at least "
 267                      "one character", &old_loc);
 268           goto cleanup;
 269         }
 270       if (e->ts.kind != gfc_default_integer_kind)
 271         {
 272           gfc_error ("Invalid Hollerith constant: Integer kind at %L "
 273                      "should be default", &old_loc);
 274           goto cleanup;
 275         }
 276       else
 277         {
 278           gfc_free_expr (e);
 279           e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
 280                                    &gfc_current_locus);
 281
 282           e->representation.string = XCNEWVEC (char, num + 1);
 283
 284           for (i = 0; i < num; i++)
 285             {
 286               gfc_char_t c = gfc_next_char_literal (1);
 287               if (! gfc_wide_fits_in_byte (c))
 288                 {
 289                   gfc_error ("Invalid Hollerith constant at %L contains a "
 290                              "wide character", &old_loc);
 291                   goto cleanup;
 292                 }
 293
 294               e->representation.string[i] = (unsigned char) c;
 295             }
 296
 297           e->representation.string[num] = '\0';
 298           e->representation.length = num;
 299
 300           *result = e;
 301           return MATCH_YES;
 302         }
 303     }
 304
 305   gfc_free_expr (e);
 306   gfc_current_locus = old_loc;
 307   return MATCH_NO;
 308
 309 cleanup:
 310   gfc_free_expr (e);
 311   return MATCH_ERROR;
 312 }
 313
 314
 315 /* Match a binary, octal or hexadecimal constant that can be found in
 316    a DATA statement.  The standard permits b'010...', o'73...', and
 317    z'a1...' where b, o, and z can be capital letters.  This function
 318    also accepts postfixed forms of the constants: '01...'b, '73...'o,
 319    and 'a1...'z.  An additional extension is the use of x for z.  */
 320
 321 static match
 322 match_boz_constant (gfc_expr **result)
 323 {
 324   int radix, length, x_hex, kind;
 325   locus old_loc, start_loc;
 326   char *buffer, post, delim;
 327   gfc_expr *e;
 328
 329   start_loc = old_loc = gfc_current_locus;
 330   gfc_gobble_whitespace ();
 331
 332   x_hex = 0;
 333   switch (post = gfc_next_ascii_char ())
 334     {
 335     case 'b':
 336       radix = 2;
 337       post = 0;
 338       break;
 339     case 'o':
 340       radix = 8;
 341       post = 0;
 342       break;
 343     case 'x':
 344       x_hex = 1;
 345       /* Fall through.  */
 346     case 'z':
 347       radix = 16;
 348       post = 0;
 349       break;
 350     case '\'':
 351       /* Fall through.  */
 352     case '\"':
 353       delim = post;
 354       post = 1;
 355       radix = 16;  /* Set to accept any valid digit string.  */
 356       break;
 357     default:
 358       goto backup;
 359     }
 360
 361   /* No whitespace allowed here.  */
 362
 363   if (post == 0)
 364     delim = gfc_next_ascii_char ();
 365
 366   if (delim != '\'' && delim != '\"')
 367     goto backup;
 368
 369   if (x_hex
 370       && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
 371                           "constant at %C uses non-standard syntax")
 372           == FAILURE))
 373       return MATCH_ERROR;
 374
 375   old_loc = gfc_current_locus;
 376
 377   length = match_digits (0, radix, NULL);
 378   if (length == -1)
 379     {
 380       gfc_error ("Empty set of digits in BOZ constant at %C");
 381       return MATCH_ERROR;
 382     }
 383
 384   if (gfc_next_ascii_char () != delim)
 385     {
 386       gfc_error ("Illegal character in BOZ constant at %C");
 387       return MATCH_ERROR;
 388     }
 389
 390   if (post == 1)
 391     {
 392       switch (gfc_next_ascii_char ())
 393         {
 394         case 'b':
 395           radix = 2;
 396           break;
 397         case 'o':
 398           radix = 8;
 399           break;
 400         case 'x':
 401           /* Fall through.  */
 402         case 'z':
 403           radix = 16;
 404           break;
 405         default:
 406           goto backup;
 407         }
 408
 409       if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
 410                           "at %C uses non-standard postfix syntax")
 411           == FAILURE)
 412         return MATCH_ERROR;
 413     }
 414
 415   gfc_current_locus = old_loc;
 416
 417   buffer = (char *) alloca (length + 1);
 418   memset (buffer, '\0', length + 1);
 419
 420   match_digits (0, radix, buffer);
 421   gfc_next_ascii_char ();    /* Eat delimiter.  */
 422   if (post == 1)
 423     gfc_next_ascii_char ();  /* Eat postfixed b, o, z, or x.  */
 424
 425   /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
 426      "If a data-stmt-constant is a boz-literal-constant, the corresponding
 427      variable shall be of type integer.  The boz-literal-constant is treated
 428      as if it were an int-literal-constant with a kind-param that specifies
 429      the representation method with the largest decimal exponent range
 430      supported by the processor."  */
 431
 432   kind = gfc_max_integer_kind;
 433   e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
 434
 435   /* Mark as boz variable.  */
 436   e->is_boz = 1;
 437
 438   if (gfc_range_check (e) != ARITH_OK)
 439     {
 440       gfc_error ("Integer too big for integer kind %i at %C", kind);
 441       gfc_free_expr (e);
 442       return MATCH_ERROR;
 443     }
 444
 445   if (!gfc_in_match_data ()
 446       && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BOZ used outside a DATA "
 447                           "statement at %C")
 448           == FAILURE))
 449       return MATCH_ERROR;
 450
 451   *result = e;
 452   return MATCH_YES;
 453
 454 backup:
 455   gfc_current_locus = start_loc;
 456   return MATCH_NO;
 457 }
 458
 459
 460 /* Match a real constant of some sort.  Allow a signed constant if signflag
 461    is nonzero.  */
 462
 463 static match
 464 match_real_constant (gfc_expr **result, int signflag)
 465 {
 466   int kind, count, seen_dp, seen_digits;
 467   locus old_loc, temp_loc;
 468   char *p, *buffer, c, exp_char;
 469   gfc_expr *e;
 470   bool negate;
 471
 472   old_loc = gfc_current_locus;
 473   gfc_gobble_whitespace ();
 474
 475   e = NULL;
 476
 477   count = 0;
 478   seen_dp = 0;
 479   seen_digits = 0;
 480   exp_char = ' ';
 481   negate = FALSE;
 482
 483   c = gfc_next_ascii_char ();
 484   if (signflag && (c == '+' || c == '-'))
 485     {
 486       if (c == '-')
 487         negate = TRUE;
 488
 489       gfc_gobble_whitespace ();
 490       c = gfc_next_ascii_char ();
 491     }
 492
 493   /* Scan significand.  */
 494   for (;; c = gfc_next_ascii_char (), count++)
 495     {
 496       if (c == '.')
 497         {
 498           if (seen_dp)
 499             goto done;
 500
 501           /* Check to see if "." goes with a following operator like
 502              ".eq.".  */
 503           temp_loc = gfc_current_locus;
 504           c = gfc_next_ascii_char ();
 505
 506           if (c == 'e' || c == 'd' || c == 'q')
 507             {
 508               c = gfc_next_ascii_char ();
 509               if (c == '.')
 510                 goto done;      /* Operator named .e. or .d.  */
 511             }
 512
 513           if (ISALPHA (c))
 514             goto done;          /* Distinguish 1.e9 from 1.eq.2 */
 515
 516           gfc_current_locus = temp_loc;
 517           seen_dp = 1;
 518           continue;
 519         }
 520
 521       if (ISDIGIT (c))
 522         {
 523           seen_digits = 1;
 524           continue;
 525         }
 526
 527       break;
 528     }
 529
 530   if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
 531     goto done;
 532   exp_char = c;
 533
 534   /* Scan exponent.  */
 535   c = gfc_next_ascii_char ();
 536   count++;
 537
 538   if (c == '+' || c == '-')
 539     {                           /* optional sign */
 540       c = gfc_next_ascii_char ();
 541       count++;
 542     }
 543
 544   if (!ISDIGIT (c))
 545     {
 546       gfc_error ("Missing exponent in real number at %C");
 547       return MATCH_ERROR;
 548     }
 549
 550   while (ISDIGIT (c))
 551     {
 552       c = gfc_next_ascii_char ();
 553       count++;
 554     }
 555
 556 done:
 557   /* Check that we have a numeric constant.  */
 558   if (!seen_digits || (!seen_dp && exp_char == ' '))
 559     {
 560       gfc_current_locus = old_loc;
 561       return MATCH_NO;
 562     }
 563
 564   /* Convert the number.  */
 565   gfc_current_locus = old_loc;
 566   gfc_gobble_whitespace ();
 567
 568   buffer = (char *) alloca (count + 1);
 569   memset (buffer, '\0', count + 1);
 570
 571   p = buffer;
 572   c = gfc_next_ascii_char ();
 573   if (c == '+' || c == '-')
 574     {
 575       gfc_gobble_whitespace ();
 576       c = gfc_next_ascii_char ();
 577     }
 578
 579   /* Hack for mpfr_set_str().  */
 580   for (;;)
 581     {
 582       if (c == 'd' || c == 'q')
 583         *p = 'e';
 584       else
 585         *p = c;
 586       p++;
 587       if (--count == 0)
 588         break;
 589
 590       c = gfc_next_ascii_char ();
 591     }
 592
 593   kind = get_kind ();
 594   if (kind == -1)
 595     goto cleanup;
 596
 597   switch (exp_char)
 598     {
 599     case 'd':
 600       if (kind != -2)
 601         {
 602           gfc_error ("Real number at %C has a 'd' exponent and an explicit "
 603                      "kind");
 604           goto cleanup;
 605         }
 606       kind = gfc_default_double_kind;
 607       break;
 608
 609     default:
 610       if (kind == -2)
 611         kind = gfc_default_real_kind;
 612
 613       if (gfc_validate_kind (BT_REAL, kind, true) < 0)
 614         {
 615           gfc_error ("Invalid real kind %d at %C", kind);
 616           goto cleanup;
 617         }
 618     }
 619
 620   e = gfc_convert_real (buffer, kind, &gfc_current_locus);
 621   if (negate)
 622     mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
 623
 624   switch (gfc_range_check (e))
 625     {
 626     case ARITH_OK:
 627       break;
 628     case ARITH_OVERFLOW:
 629       gfc_error ("Real constant overflows its kind at %C");
 630       goto cleanup;
 631
 632     case ARITH_UNDERFLOW:
 633       if (gfc_option.warn_underflow)
 634         gfc_warning ("Real constant underflows its kind at %C");
 635       mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
 636       break;
 637
 638     default:
 639       gfc_internal_error ("gfc_range_check() returned bad value");
 640     }
 641
 642   *result = e;
 643   return MATCH_YES;
 644
 645 cleanup:
 646   gfc_free_expr (e);
 647   return MATCH_ERROR;
 648 }
 649
 650
 651 /* Match a substring reference.  */
 652
 653 static match
 654 match_substring (gfc_charlen *cl, int init, gfc_ref **result)
 655 {
 656   gfc_expr *start, *end;
 657   locus old_loc;
 658   gfc_ref *ref;
 659   match m;
 660
 661   start = NULL;
 662   end = NULL;
 663
 664   old_loc = gfc_current_locus;
 665
 666   m = gfc_match_char ('(');
 667   if (m != MATCH_YES)
 668     return MATCH_NO;
 669
 670   if (gfc_match_char (':') != MATCH_YES)
 671     {
 672       if (init)
 673         m = gfc_match_init_expr (&start);
 674       else
 675         m = gfc_match_expr (&start);
 676
 677       if (m != MATCH_YES)
 678         {
 679           m = MATCH_NO;
 680           goto cleanup;
 681         }
 682
 683       m = gfc_match_char (':');
 684       if (m != MATCH_YES)
 685         goto cleanup;
 686     }
 687
 688   if (gfc_match_char (')') != MATCH_YES)
 689     {
 690       if (init)
 691         m = gfc_match_init_expr (&end);
 692       else
 693         m = gfc_match_expr (&end);
 694
 695       if (m == MATCH_NO)
 696         goto syntax;
 697       if (m == MATCH_ERROR)
 698         goto cleanup;
 699
 700       m = gfc_match_char (')');
 701       if (m == MATCH_NO)
 702         goto syntax;
 703     }
 704
 705   /* Optimize away the (:) reference.  */
 706   if (start == NULL && end == NULL)
 707     ref = NULL;
 708   else
 709     {
 710       ref = gfc_get_ref ();
 711
 712       ref->type = REF_SUBSTRING;
 713       if (start == NULL)
 714         start = gfc_int_expr (1);
 715       ref->u.ss.start = start;
 716       if (end == NULL && cl)
 717         end = gfc_copy_expr (cl->length);
 718       ref->u.ss.end = end;
 719       ref->u.ss.length = cl;
 720     }
 721
 722   *result = ref;
 723   return MATCH_YES;
 724
 725 syntax:
 726   gfc_error ("Syntax error in SUBSTRING specification at %C");
 727   m = MATCH_ERROR;
 728
 729 cleanup:
 730   gfc_free_expr (start);
 731   gfc_free_expr (end);
 732
 733   gfc_current_locus = old_loc;
 734   return m;
 735 }
 736
 737
 738 /* Reads the next character of a string constant, taking care to
 739    return doubled delimiters on the input as a single instance of
 740    the delimiter.
 741
 742    Special return values for "ret" argument are:
 743      -1   End of the string, as determined by the delimiter
 744      -2   Unterminated string detected
 745
 746    Backslash codes are also expanded at this time.  */
 747
 748 static gfc_char_t
 749 next_string_char (gfc_char_t delimiter, int *ret)
 750 {
 751   locus old_locus;
 752   gfc_char_t c;
 753
 754   c = gfc_next_char_literal (1);
 755   *ret = 0;
 756
 757   if (c == '\n')
 758     {
 759       *ret = -2;
 760       return 0;
 761     }
 762
 763   if (gfc_option.flag_backslash && c == '\\')
 764     {
 765       old_locus = gfc_current_locus;
 766
 767       if (gfc_match_special_char (&c) == MATCH_NO)
 768         gfc_current_locus = old_locus;
 769
 770       if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
 771         gfc_warning ("Extension: backslash character at %C");
 772     }
 773
 774   if (c != delimiter)
 775     return c;
 776
 777   old_locus = gfc_current_locus;
 778   c = gfc_next_char_literal (0);
 779
 780   if (c == delimiter)
 781     return c;
 782   gfc_current_locus = old_locus;
 783
 784   *ret = -1;
 785   return 0;
 786 }
 787
 788
 789 /* Special case of gfc_match_name() that matches a parameter kind name
 790    before a string constant.  This takes case of the weird but legal
 791    case of:
 792
 793      kind_____'string'
 794
 795    where kind____ is a parameter. gfc_match_name() will happily slurp
 796    up all the underscores, which leads to problems.  If we return
 797    MATCH_YES, the parse pointer points to the final underscore, which
 798    is not part of the name.  We never return MATCH_ERROR-- errors in
 799    the name will be detected later.  */
 800
 801 static match
 802 match_charkind_name (char *name)
 803 {
 804   locus old_loc;
 805   char c, peek;
 806   int len;
 807
 808   gfc_gobble_whitespace ();
 809   c = gfc_next_ascii_char ();
 810   if (!ISALPHA (c))
 811     return MATCH_NO;
 812
 813   *name++ = c;
 814   len = 1;
 815
 816   for (;;)
 817     {
 818       old_loc = gfc_current_locus;
 819       c = gfc_next_ascii_char ();
 820
 821       if (c == '_')
 822         {
 823           peek = gfc_peek_ascii_char ();
 824
 825           if (peek == '\'' || peek == '\"')
 826             {
 827               gfc_current_locus = old_loc;
 828               *name = '\0';
 829               return MATCH_YES;
 830             }
 831         }
 832
 833       if (!ISALNUM (c)
 834           && c != '_'
 835           && (c != '$' || !gfc_option.flag_dollar_ok))
 836         break;
 837
 838       *name++ = c;
 839       if (++len > GFC_MAX_SYMBOL_LEN)
 840         break;
 841     }
 842
 843   return MATCH_NO;
 844 }
 845
 846
 847 /* See if the current input matches a character constant.  Lots of
 848    contortions have to be done to match the kind parameter which comes
 849    before the actual string.  The main consideration is that we don't
 850    want to error out too quickly.  For example, we don't actually do
 851    any validation of the kinds until we have actually seen a legal
 852    delimiter.  Using match_kind_param() generates errors too quickly.  */
 853
 854 static match
 855 match_string_constant (gfc_expr **result)
 856 {
 857   char name[GFC_MAX_SYMBOL_LEN + 1], peek;
 858   int i, kind, length, warn_ampersand, ret;
 859   locus old_locus, start_locus;
 860   gfc_symbol *sym;
 861   gfc_expr *e;
 862   const char *q;
 863   match m;
 864   gfc_char_t c, delimiter, *p;
 865
 866   old_locus = gfc_current_locus;
 867
 868   gfc_gobble_whitespace ();
 869
 870   start_locus = gfc_current_locus;
 871
 872   c = gfc_next_char ();
 873   if (c == '\'' || c == '"')
 874     {
 875       kind = gfc_default_character_kind;
 876       goto got_delim;
 877     }
 878
 879   if (gfc_wide_is_digit (c))
 880     {
 881       kind = 0;
 882
 883       while (gfc_wide_is_digit (c))
 884         {
 885           kind = kind * 10 + c - '0';
 886           if (kind > 9999999)
 887             goto no_match;
 888           c = gfc_next_char ();
 889         }
 890
 891     }
 892   else
 893     {
 894       gfc_current_locus = old_locus;
 895
 896       m = match_charkind_name (name);
 897       if (m != MATCH_YES)
 898         goto no_match;
 899
 900       if (gfc_find_symbol (name, NULL, 1, &sym)
 901           || sym == NULL
 902           || sym->attr.flavor != FL_PARAMETER)
 903         goto no_match;
 904
 905       kind = -1;
 906       c = gfc_next_char ();
 907     }
 908
 909   if (c == ' ')
 910     {
 911       gfc_gobble_whitespace ();
 912       c = gfc_next_char ();
 913     }
 914
 915   if (c != '_')
 916     goto no_match;
 917
 918   gfc_gobble_whitespace ();
 919   start_locus = gfc_current_locus;
 920
 921   c = gfc_next_char ();
 922   if (c != '\'' && c != '"')
 923     goto no_match;
 924
 925   if (kind == -1)
 926     {
 927       q = gfc_extract_int (sym->value, &kind);
 928       if (q != NULL)
 929         {
 930           gfc_error (q);
 931           return MATCH_ERROR;
 932         }
 933       gfc_set_sym_referenced (sym);
 934     }
 935
 936   if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
 937     {
 938       gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
 939       return MATCH_ERROR;
 940     }
 941
 942 got_delim:
 943   /* Scan the string into a block of memory by first figuring out how
 944      long it is, allocating the structure, then re-reading it.  This
 945      isn't particularly efficient, but string constants aren't that
 946      common in most code.  TODO: Use obstacks?  */
 947
 948   delimiter = c;
 949   length = 0;
 950
 951   for (;;)
 952     {
 953       c = next_string_char (delimiter, &ret);
 954       if (ret == -1)
 955         break;
 956       if (ret == -2)
 957         {
 958           gfc_current_locus = start_locus;
 959           gfc_error ("Unterminated character constant beginning at %C");
 960           return MATCH_ERROR;
 961         }
 962
 963       length++;
 964     }
 965
 966   /* Peek at the next character to see if it is a b, o, z, or x for the
 967      postfixed BOZ literal constants.  */
 968   peek = gfc_peek_ascii_char ();
 969   if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
 970     goto no_match;
 971
 972
 973   e = gfc_get_expr ();
 974
 975   e->expr_type = EXPR_CONSTANT;
 976   e->ref = NULL;
 977   e->ts.type = BT_CHARACTER;
 978   e->ts.kind = kind;
 979   e->ts.is_c_interop = 0;
 980   e->ts.is_iso_c = 0;
 981   e->where = start_locus;
 982
 983   e->value.character.string = p = gfc_get_wide_string (length + 1);
 984   e->value.character.length = length;
 985
 986   gfc_current_locus = start_locus;
 987   gfc_next_char ();             /* Skip delimiter */
 988
 989   /* We disable the warning for the following loop as the warning has already
 990      been printed in the loop above.  */
 991   warn_ampersand = gfc_option.warn_ampersand;
 992   gfc_option.warn_ampersand = 0;
 993
 994   for (i = 0; i < length; i++)
 995     {
 996       c = next_string_char (delimiter, &ret);
 997
 998       if (!gfc_check_character_range (c, kind))
 999         {
1000           gfc_error ("Character '%s' in string at %C is not representable "
1001                      "in character kind %d", gfc_print_wide_char (c), kind);
1002           return MATCH_ERROR;
1003         }
1004
1005       *p++ = c;
1006     }
1007
1008   *p = '\0';    /* TODO: C-style string is for development/debug purposes.  */
1009   gfc_option.warn_ampersand = warn_ampersand;
1010
1011   next_string_char (delimiter, &ret);
1012   if (ret != -1)
1013     gfc_internal_error ("match_string_constant(): Delimiter not found");
1014
1015   if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
1016     e->expr_type = EXPR_SUBSTRING;
1017
1018   *result = e;
1019
1020   return MATCH_YES;
1021
1022 no_match:
1023   gfc_current_locus = old_locus;
1024   return MATCH_NO;
1025 }
1026
1027
1028 /* Match a .true. or .false.  Returns 1 if a .true. was found,
1029    0 if a .false. was found, and -1 otherwise.  */
1030 static int
1031 match_logical_constant_string (void)
1032 {
1033   locus orig_loc = gfc_current_locus;
1034
1035   gfc_gobble_whitespace ();
1036   if (gfc_next_ascii_char () == '.')
1037     {
1038       char ch = gfc_next_ascii_char ();
1039       if (ch == 'f')
1040         {
1041           if (gfc_next_ascii_char () == 'a'
1042               && gfc_next_ascii_char () == 'l'
1043               && gfc_next_ascii_char () == 's'
1044               && gfc_next_ascii_char () == 'e'
1045               && gfc_next_ascii_char () == '.')
1046             /* Matched ".false.".  */
1047             return 0;
1048         }
1049       else if (ch == 't')
1050         {
1051           if (gfc_next_ascii_char () == 'r'
1052               && gfc_next_ascii_char () == 'u'
1053               && gfc_next_ascii_char () == 'e'
1054               && gfc_next_ascii_char () == '.')
1055             /* Matched ".true.".  */
1056             return 1;
1057         }
1058     }
1059   gfc_current_locus = orig_loc;
1060   return -1;
1061 }
1062
1063 /* Match a .true. or .false.  */
1064
1065 static match
1066 match_logical_constant (gfc_expr **result)
1067 {
1068   gfc_expr *e;
1069   int i, kind;
1070
1071   i = match_logical_constant_string ();
1072   if (i == -1)
1073     return MATCH_NO;
1074
1075   kind = get_kind ();
1076   if (kind == -1)
1077     return MATCH_ERROR;
1078   if (kind == -2)
1079     kind = gfc_default_logical_kind;
1080
1081   if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1082     {
1083       gfc_error ("Bad kind for logical constant at %C");
1084       return MATCH_ERROR;
1085     }
1086
1087   e = gfc_get_expr ();
1088
1089   e->expr_type = EXPR_CONSTANT;
1090   e->value.logical = i;
1091   e->ts.type = BT_LOGICAL;
1092   e->ts.kind = kind;
1093   e->ts.is_c_interop = 0;
1094   e->ts.is_iso_c = 0;
1095   e->where = gfc_current_locus;
1096
1097   *result = e;
1098   return MATCH_YES;
1099 }
1100
1101
1102 /* Match a real or imaginary part of a complex constant that is a
1103    symbolic constant.  */
1104
1105 static match
1106 match_sym_complex_part (gfc_expr **result)
1107 {
1108   char name[GFC_MAX_SYMBOL_LEN + 1];
1109   gfc_symbol *sym;
1110   gfc_expr *e;
1111   match m;
1112
1113   m = gfc_match_name (name);
1114   if (m != MATCH_YES)
1115     return m;
1116
1117   if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1118     return MATCH_NO;
1119
1120   if (sym->attr.flavor != FL_PARAMETER)
1121     {
1122       gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1123       return MATCH_ERROR;
1124     }
1125
1126   if (!gfc_numeric_ts (&sym->value->ts))
1127     {
1128       gfc_error ("Numeric PARAMETER required in complex constant at %C");
1129       return MATCH_ERROR;
1130     }
1131
1132   if (sym->value->rank != 0)
1133     {
1134       gfc_error ("Scalar PARAMETER required in complex constant at %C");
1135       return MATCH_ERROR;
1136     }
1137
1138   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1139                       "complex constant at %C") == FAILURE)
1140     return MATCH_ERROR;
1141
1142   switch (sym->value->ts.type)
1143     {
1144     case BT_REAL:
1145       e = gfc_copy_expr (sym->value);
1146       break;
1147
1148     case BT_COMPLEX:
1149       e = gfc_complex2real (sym->value, sym->value->ts.kind);
1150       if (e == NULL)
1151         goto error;
1152       break;
1153
1154     case BT_INTEGER:
1155       e = gfc_int2real (sym->value, gfc_default_real_kind);
1156       if (e == NULL)
1157         goto error;
1158       break;
1159
1160     default:
1161       gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1162     }
1163
1164   *result = e;          /* e is a scalar, real, constant expression.  */
1165   return MATCH_YES;
1166
1167 error:
1168   gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1169   return MATCH_ERROR;
1170 }
1171
1172
1173 /* Match a real or imaginary part of a complex number.  */
1174
1175 static match
1176 match_complex_part (gfc_expr **result)
1177 {
1178   match m;
1179
1180   m = match_sym_complex_part (result);
1181   if (m != MATCH_NO)
1182     return m;
1183
1184   m = match_real_constant (result, 1);
1185   if (m != MATCH_NO)
1186     return m;
1187
1188   return match_integer_constant (result, 1);
1189 }
1190
1191
1192 /* Try to match a complex constant.  */
1193
1194 static match
1195 match_complex_constant (gfc_expr **result)
1196 {
1197   gfc_expr *e, *real, *imag;
1198   gfc_error_buf old_error;
1199   gfc_typespec target;
1200   locus old_loc;
1201   int kind;
1202   match m;
1203
1204   old_loc = gfc_current_locus;
1205   real = imag = e = NULL;
1206
1207   m = gfc_match_char ('(');
1208   if (m != MATCH_YES)
1209     return m;
1210
1211   gfc_push_error (&old_error);
1212
1213   m = match_complex_part (&real);
1214   if (m == MATCH_NO)
1215     {
1216       gfc_free_error (&old_error);
1217       goto cleanup;
1218     }
1219
1220   if (gfc_match_char (',') == MATCH_NO)
1221     {
1222       gfc_pop_error (&old_error);
1223       m = MATCH_NO;
1224       goto cleanup;
1225     }
1226
1227   /* If m is error, then something was wrong with the real part and we
1228      assume we have a complex constant because we've seen the ','.  An
1229      ambiguous case here is the start of an iterator list of some
1230      sort. These sort of lists are matched prior to coming here.  */
1231
1232   if (m == MATCH_ERROR)
1233     {
1234       gfc_free_error (&old_error);
1235       goto cleanup;
1236     }
1237   gfc_pop_error (&old_error);
1238
1239   m = match_complex_part (&imag);
1240   if (m == MATCH_NO)
1241     goto syntax;
1242   if (m == MATCH_ERROR)
1243     goto cleanup;
1244
1245   m = gfc_match_char (')');
1246   if (m == MATCH_NO)
1247     {
1248       /* Give the matcher for implied do-loops a chance to run.  This
1249          yields a much saner error message for (/ (i, 4=i, 6) /).  */
1250       if (gfc_peek_ascii_char () == '=')
1251         {
1252           m = MATCH_ERROR;
1253           goto cleanup;
1254         }
1255       else
1256     goto syntax;
1257     }
1258
1259   if (m == MATCH_ERROR)
1260     goto cleanup;
1261
1262   /* Decide on the kind of this complex number.  */
1263   if (real->ts.type == BT_REAL)
1264     {
1265       if (imag->ts.type == BT_REAL)
1266         kind = gfc_kind_max (real, imag);
1267       else
1268         kind = real->ts.kind;
1269     }
1270   else
1271     {
1272       if (imag->ts.type == BT_REAL)
1273         kind = imag->ts.kind;
1274       else
1275         kind = gfc_default_real_kind;
1276     }
1277   target.type = BT_REAL;
1278   target.kind = kind;
1279   target.is_c_interop = 0;
1280   target.is_iso_c = 0;
1281
1282   if (real->ts.type != BT_REAL || kind != real->ts.kind)
1283     gfc_convert_type (real, &target, 2);
1284   if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1285     gfc_convert_type (imag, &target, 2);
1286
1287   e = gfc_convert_complex (real, imag, kind);
1288   e->where = gfc_current_locus;
1289
1290   gfc_free_expr (real);
1291   gfc_free_expr (imag);
1292
1293   *result = e;
1294   return MATCH_YES;
1295
1296 syntax:
1297   gfc_error ("Syntax error in COMPLEX constant at %C");
1298   m = MATCH_ERROR;
1299
1300 cleanup:
1301   gfc_free_expr (e);
1302   gfc_free_expr (real);
1303   gfc_free_expr (imag);
1304   gfc_current_locus = old_loc;
1305
1306   return m;
1307 }
1308
1309
1310 /* Match constants in any of several forms.  Returns nonzero for a
1311    match, zero for no match.  */
1312
1313 match
1314 gfc_match_literal_constant (gfc_expr **result, int signflag)
1315 {
1316   match m;
1317
1318   m = match_complex_constant (result);
1319   if (m != MATCH_NO)
1320     return m;
1321
1322   m = match_string_constant (result);
1323   if (m != MATCH_NO)
1324     return m;
1325
1326   m = match_boz_constant (result);
1327   if (m != MATCH_NO)
1328     return m;
1329
1330   m = match_real_constant (result, signflag);
1331   if (m != MATCH_NO)
1332     return m;
1333
1334   m = match_hollerith_constant (result);
1335   if (m != MATCH_NO)
1336     return m;
1337
1338   m = match_integer_constant (result, signflag);
1339   if (m != MATCH_NO)
1340     return m;
1341
1342   m = match_logical_constant (result);
1343   if (m != MATCH_NO)
1344     return m;
1345
1346   return MATCH_NO;
1347 }
1348
1349
1350 /* This checks if a symbol is the return value of an encompassing function.
1351    Function nesting can be maximally two levels deep, but we may have
1352    additional local namespaces like BLOCK etc.  */
1353
1354 bool
1355 gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
1356 {
1357   if (!sym->attr.function || (sym->result != sym))
1358     return false;
1359   while (ns)
1360     {
1361       if (ns->proc_name == sym)
1362         return true;
1363       ns = ns->parent;
1364     }
1365   return false;
1366 }
1367
1368
1369 /* Match a single actual argument value.  An actual argument is
1370    usually an expression, but can also be a procedure name.  If the
1371    argument is a single name, it is not always possible to tell
1372    whether the name is a dummy procedure or not.  We treat these cases
1373    by creating an argument that looks like a dummy procedure and
1374    fixing things later during resolution.  */
1375
1376 static match
1377 match_actual_arg (gfc_expr **result)
1378 {
1379   char name[GFC_MAX_SYMBOL_LEN + 1];
1380   gfc_symtree *symtree;
1381   locus where, w;
1382   gfc_expr *e;
1383   char c;
1384
1385   gfc_gobble_whitespace ();
1386   where = gfc_current_locus;
1387
1388   switch (gfc_match_name (name))
1389     {
1390     case MATCH_ERROR:
1391       return MATCH_ERROR;
1392
1393     case MATCH_NO:
1394       break;
1395
1396     case MATCH_YES:
1397       w = gfc_current_locus;
1398       gfc_gobble_whitespace ();
1399       c = gfc_next_ascii_char ();
1400       gfc_current_locus = w;
1401
1402       if (c != ',' && c != ')')
1403         break;
1404
1405       if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1406         break;
1407       /* Handle error elsewhere.  */
1408
1409       /* Eliminate a couple of common cases where we know we don't
1410          have a function argument.  */
1411       if (symtree == NULL)
1412         {
1413           gfc_get_sym_tree (name, NULL, &symtree, false);
1414           gfc_set_sym_referenced (symtree->n.sym);
1415         }
1416       else
1417         {
1418           gfc_symbol *sym;
1419
1420           sym = symtree->n.sym;
1421           gfc_set_sym_referenced (sym);
1422           if (sym->attr.flavor != FL_PROCEDURE
1423               && sym->attr.flavor != FL_UNKNOWN)
1424             break;
1425
1426           if (sym->attr.in_common && !sym->attr.proc_pointer)
1427             {
1428               gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
1429                               &sym->declared_at);
1430               break;
1431             }
1432
1433           /* If the symbol is a function with itself as the result and
1434              is being defined, then we have a variable.  */
1435           if (sym->attr.function && sym->result == sym)
1436             {
1437               if (gfc_is_function_return_value (sym, gfc_current_ns))
1438                 break;
1439
1440               if (sym->attr.entry
1441                   && (sym->ns == gfc_current_ns
1442                       || sym->ns == gfc_current_ns->parent))
1443                 {
1444                   gfc_entry_list *el = NULL;
1445
1446                   for (el = sym->ns->entries; el; el = el->next)
1447                     if (sym == el->sym)
1448                       break;
1449
1450                   if (el)
1451                     break;
1452                 }
1453             }
1454         }
1455
1456       e = gfc_get_expr ();      /* Leave it unknown for now */
1457       e->symtree = symtree;
1458       e->expr_type = EXPR_VARIABLE;
1459       e->ts.type = BT_PROCEDURE;
1460       e->where = where;
1461
1462       *result = e;
1463       return MATCH_YES;
1464     }
1465
1466   gfc_current_locus = where;
1467   return gfc_match_expr (result);
1468 }
1469
1470
1471 /* Match a keyword argument.  */
1472
1473 static match
1474 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1475 {
1476   char name[GFC_MAX_SYMBOL_LEN + 1];
1477   gfc_actual_arglist *a;
1478   locus name_locus;
1479   match m;
1480
1481   name_locus = gfc_current_locus;
1482   m = gfc_match_name (name);
1483
1484   if (m != MATCH_YES)
1485     goto cleanup;
1486   if (gfc_match_char ('=') != MATCH_YES)
1487     {
1488       m = MATCH_NO;
1489       goto cleanup;
1490     }
1491
1492   m = match_actual_arg (&actual->expr);
1493   if (m != MATCH_YES)
1494     goto cleanup;
1495
1496   /* Make sure this name has not appeared yet.  */
1497
1498   if (name[0] != '\0')
1499     {
1500       for (a = base; a; a = a->next)
1501         if (a->name != NULL && strcmp (a->name, name) == 0)
1502           {
1503             gfc_error ("Keyword '%s' at %C has already appeared in the "
1504                        "current argument list", name);
1505             return MATCH_ERROR;
1506           }
1507     }
1508
1509   actual->name = gfc_get_string (name);
1510   return MATCH_YES;
1511
1512 cleanup:
1513   gfc_current_locus = name_locus;
1514   return m;
1515 }
1516
1517
1518 /* Match an argument list function, such as %VAL.  */
1519
1520 static match
1521 match_arg_list_function (gfc_actual_arglist *result)
1522 {
1523   char name[GFC_MAX_SYMBOL_LEN + 1];
1524   locus old_locus;
1525   match m;
1526
1527   old_locus = gfc_current_locus;
1528
1529   if (gfc_match_char ('%') != MATCH_YES)
1530     {
1531       m = MATCH_NO;
1532       goto cleanup;
1533     }
1534
1535   m = gfc_match ("%n (", name);
1536   if (m != MATCH_YES)
1537     goto cleanup;
1538
1539   if (name[0] != '\0')
1540     {
1541       switch (name[0])
1542         {
1543         case 'l':
1544           if (strncmp (name, "loc", 3) == 0)
1545             {
1546               result->name = "%LOC";
1547               break;
1548             }
1549         case 'r':
1550           if (strncmp (name, "ref", 3) == 0)
1551             {
1552               result->name = "%REF";
1553               break;
1554             }
1555         case 'v':
1556           if (strncmp (name, "val", 3) == 0)
1557             {
1558               result->name = "%VAL";
1559               break;
1560             }
1561         default:
1562           m = MATCH_ERROR;
1563           goto cleanup;
1564         }
1565     }
1566
1567   if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1568                       "function at %C") == FAILURE)
1569     {
1570       m = MATCH_ERROR;
1571       goto cleanup;
1572     }
1573
1574   m = match_actual_arg (&result->expr);
1575   if (m != MATCH_YES)
1576     goto cleanup;
1577
1578   if (gfc_match_char (')') != MATCH_YES)
1579     {
1580       m = MATCH_NO;
1581       goto cleanup;
1582     }
1583
1584   return MATCH_YES;
1585
1586 cleanup:
1587   gfc_current_locus = old_locus;
1588   return m;
1589 }
1590
1591
1592 /* Matches an actual argument list of a function or subroutine, from
1593    the opening parenthesis to the closing parenthesis.  The argument
1594    list is assumed to allow keyword arguments because we don't know if
1595    the symbol associated with the procedure has an implicit interface
1596    or not.  We make sure keywords are unique. If sub_flag is set,
1597    we're matching the argument list of a subroutine.  */
1598
1599 match
1600 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1601 {
1602   gfc_actual_arglist *head, *tail;
1603   int seen_keyword;
1604   gfc_st_label *label;
1605   locus old_loc;
1606   match m;
1607
1608   *argp = tail = NULL;
1609   old_loc = gfc_current_locus;
1610
1611   seen_keyword = 0;
1612
1613   if (gfc_match_char ('(') == MATCH_NO)
1614     return (sub_flag) ? MATCH_YES : MATCH_NO;
1615
1616   if (gfc_match_char (')') == MATCH_YES)
1617     return MATCH_YES;
1618   head = NULL;
1619
1620   for (;;)
1621     {
1622       if (head == NULL)
1623         head = tail = gfc_get_actual_arglist ();
1624       else
1625         {
1626           tail->next = gfc_get_actual_arglist ();
1627           tail = tail->next;
1628         }
1629
1630       if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1631         {
1632           m = gfc_match_st_label (&label);
1633           if (m == MATCH_NO)
1634             gfc_error ("Expected alternate return label at %C");
1635           if (m != MATCH_YES)
1636             goto cleanup;
1637
1638           tail->label = label;
1639           goto next;
1640         }
1641
1642       /* After the first keyword argument is seen, the following
1643          arguments must also have keywords.  */
1644       if (seen_keyword)
1645         {
1646           m = match_keyword_arg (tail, head);
1647
1648           if (m == MATCH_ERROR)
1649             goto cleanup;
1650           if (m == MATCH_NO)
1651             {
1652               gfc_error ("Missing keyword name in actual argument list at %C");
1653               goto cleanup;
1654             }
1655
1656         }
1657       else
1658         {
1659           /* Try an argument list function, like %VAL.  */
1660           m = match_arg_list_function (tail);
1661           if (m == MATCH_ERROR)
1662             goto cleanup;
1663
1664           /* See if we have the first keyword argument.  */
1665           if (m == MATCH_NO)
1666             {
1667               m = match_keyword_arg (tail, head);
1668               if (m == MATCH_YES)
1669                 seen_keyword = 1;
1670               if (m == MATCH_ERROR)
1671                 goto cleanup;
1672             }
1673
1674           if (m == MATCH_NO)
1675             {
1676               /* Try for a non-keyword argument.  */
1677               m = match_actual_arg (&tail->expr);
1678               if (m == MATCH_ERROR)
1679                 goto cleanup;
1680               if (m == MATCH_NO)
1681                 goto syntax;
1682             }
1683         }
1684
1685
1686     next:
1687       if (gfc_match_char (')') == MATCH_YES)
1688         break;
1689       if (gfc_match_char (',') != MATCH_YES)
1690         goto syntax;
1691     }
1692
1693   *argp = head;
1694   return MATCH_YES;
1695
1696 syntax:
1697   gfc_error ("Syntax error in argument list at %C");
1698
1699 cleanup:
1700   gfc_free_actual_arglist (head);
1701   gfc_current_locus = old_loc;
1702
1703   return MATCH_ERROR;
1704 }
1705
1706
1707 /* Used by gfc_match_varspec() to extend the reference list by one
1708    element.  */
1709
1710 static gfc_ref *
1711 extend_ref (gfc_expr *primary, gfc_ref *tail)
1712 {
1713   if (primary->ref == NULL)
1714     primary->ref = tail = gfc_get_ref ();
1715   else
1716     {
1717       if (tail == NULL)
1718         gfc_internal_error ("extend_ref(): Bad tail");
1719       tail->next = gfc_get_ref ();
1720       tail = tail->next;
1721     }
1722
1723   return tail;
1724 }
1725
1726
1727 /* Match any additional specifications associated with the current
1728    variable like member references or substrings.  If equiv_flag is
1729    set we only match stuff that is allowed inside an EQUIVALENCE
1730    statement.  sub_flag tells whether we expect a type-bound procedure found
1731    to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1732    components, 'ppc_arg' determines whether the PPC may be called (with an
1733    argument list), or whether it may just be referred to as a pointer.  */
1734
1735 match
1736 gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
1737                    bool ppc_arg)
1738 {
1739   char name[GFC_MAX_SYMBOL_LEN + 1];
1740   gfc_ref *substring, *tail;
1741   gfc_component *component;
1742   gfc_symbol *sym = primary->symtree->n.sym;
1743   match m;
1744   bool unknown;
1745
1746   tail = NULL;
1747
1748   gfc_gobble_whitespace ();
1749   if ((equiv_flag && gfc_peek_ascii_char () == '(')
1750       || (sym->attr.dimension && !sym->attr.proc_pointer
1751           && !gfc_is_proc_ptr_comp (primary, NULL)
1752           && !(gfc_matching_procptr_assignment
1753                && sym->attr.flavor == FL_PROCEDURE))
1754       || (sym->ts.type == BT_CLASS
1755           && sym->ts.u.derived->components->attr.dimension))
1756     {
1757       /* In EQUIVALENCE, we don't know yet whether we are seeing
1758          an array, character variable or array of character
1759          variables.  We'll leave the decision till resolve time.  */
1760       tail = extend_ref (primary, tail);
1761       tail->type = REF_ARRAY;
1762
1763       m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1764                                equiv_flag);
1765       if (m != MATCH_YES)
1766         return m;
1767
1768       gfc_gobble_whitespace ();
1769       if (equiv_flag && gfc_peek_ascii_char () == '(')
1770         {
1771           tail = extend_ref (primary, tail);
1772           tail->type = REF_ARRAY;
1773
1774           m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
1775           if (m != MATCH_YES)
1776             return m;
1777         }
1778     }
1779
1780   primary->ts = sym->ts;
1781
1782   if (equiv_flag)
1783     return MATCH_YES;
1784
1785   if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
1786       && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
1787     gfc_set_default_type (sym, 0, sym->ns);
1788
1789   if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
1790       || gfc_match_char ('%') != MATCH_YES)
1791     goto check_substring;
1792
1793   sym = sym->ts.u.derived;
1794
1795   for (;;)
1796     {
1797       gfc_try t;
1798       gfc_symtree *tbp;
1799
1800       m = gfc_match_name (name);
1801       if (m == MATCH_NO)
1802         gfc_error ("Expected structure component name at %C");
1803       if (m != MATCH_YES)
1804         return MATCH_ERROR;
1805
1806       if (sym->f2k_derived)
1807         tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
1808       else
1809         tbp = NULL;
1810
1811       if (tbp)
1812         {
1813           gfc_symbol* tbp_sym;
1814
1815           if (t == FAILURE)
1816             return MATCH_ERROR;
1817
1818           gcc_assert (!tail || !tail->next);
1819           gcc_assert (primary->expr_type == EXPR_VARIABLE);
1820
1821           if (tbp->n.tb->is_generic)
1822             tbp_sym = NULL;
1823           else
1824             tbp_sym = tbp->n.tb->u.specific->n.sym;
1825
1826           primary->expr_type = EXPR_COMPCALL;
1827           primary->value.compcall.tbp = tbp->n.tb;
1828           primary->value.compcall.name = tbp->name;
1829           primary->value.compcall.ignore_pass = 0;
1830           primary->value.compcall.assign = 0;
1831           primary->value.compcall.base_object = NULL;
1832           gcc_assert (primary->symtree->n.sym->attr.referenced);
1833           if (tbp_sym)
1834             primary->ts = tbp_sym->ts;
1835
1836           m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
1837                                         &primary->value.compcall.actual);
1838           if (m == MATCH_ERROR)
1839             return MATCH_ERROR;
1840           if (m == MATCH_NO)
1841             {
1842               if (sub_flag)
1843                 primary->value.compcall.actual = NULL;
1844               else
1845                 {
1846                   gfc_error ("Expected argument list at %C");
1847                   return MATCH_ERROR;
1848                 }
1849             }
1850
1851           break;
1852         }
1853
1854       component = gfc_find_component (sym, name, false, false);
1855       if (component == NULL)
1856         return MATCH_ERROR;
1857
1858       tail = extend_ref (primary, tail);
1859       tail->type = REF_COMPONENT;
1860
1861       tail->u.c.component = component;
1862       tail->u.c.sym = sym;
1863
1864       primary->ts = component->ts;
1865
1866       if (component->attr.proc_pointer && ppc_arg
1867           && !gfc_matching_procptr_assignment)
1868         {
1869           m = gfc_match_actual_arglist (sub_flag,
1870                                         &primary->value.compcall.actual);
1871           if (m == MATCH_ERROR)
1872             return MATCH_ERROR;
1873           if (m == MATCH_YES)
1874             primary->expr_type = EXPR_PPC;
1875
1876           break;
1877         }
1878
1879       if (component->as != NULL && !component->attr.proc_pointer)
1880         {
1881           tail = extend_ref (primary, tail);
1882           tail->type = REF_ARRAY;
1883
1884           m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1885           if (m != MATCH_YES)
1886             return m;
1887         }
1888       else if (component->ts.type == BT_CLASS
1889                && component->ts.u.derived->components->as != NULL
1890                && !component->attr.proc_pointer)
1891         {
1892           tail = extend_ref (primary, tail);
1893           tail->type = REF_ARRAY;
1894
1895           m = gfc_match_array_ref (&tail->u.ar,
1896                                    component->ts.u.derived->components->as,
1897                                    equiv_flag);
1898           if (m != MATCH_YES)
1899             return m;
1900         }
1901
1902       if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
1903           || gfc_match_char ('%') != MATCH_YES)
1904         break;
1905
1906       sym = component->ts.u.derived;
1907     }
1908
1909 check_substring:
1910   unknown = false;
1911   if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
1912     {
1913       if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
1914        {
1915          gfc_set_default_type (sym, 0, sym->ns);
1916          primary->ts = sym->ts;
1917          unknown = true;
1918        }
1919     }
1920
1921   if (primary->ts.type == BT_CHARACTER)
1922     {
1923       switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
1924         {
1925         case MATCH_YES:
1926           if (tail == NULL)
1927             primary->ref = substring;
1928           else
1929             tail->next = substring;
1930
1931           if (primary->expr_type == EXPR_CONSTANT)
1932             primary->expr_type = EXPR_SUBSTRING;
1933
1934           if (substring)
1935             primary->ts.u.cl = NULL;
1936
1937           break;
1938
1939         case MATCH_NO:
1940           if (unknown)
1941             {
1942               gfc_clear_ts (&primary->ts);
1943               gfc_clear_ts (&sym->ts);
1944             }
1945           break;
1946
1947         case MATCH_ERROR:
1948           return MATCH_ERROR;
1949         }
1950     }
1951
1952   return MATCH_YES;
1953 }
1954
1955
1956 /* Given an expression that is a variable, figure out what the
1957    ultimate variable's type and attribute is, traversing the reference
1958    structures if necessary.
1959
1960    This subroutine is trickier than it looks.  We start at the base
1961    symbol and store the attribute.  Component references load a
1962    completely new attribute.
1963
1964    A couple of rules come into play.  Subobjects of targets are always
1965    targets themselves.  If we see a component that goes through a
1966    pointer, then the expression must also be a target, since the
1967    pointer is associated with something (if it isn't core will soon be
1968    dumped).  If we see a full part or section of an array, the
1969    expression is also an array.
1970
1971    We can have at most one full array reference.  */
1972
1973 symbol_attribute
1974 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
1975 {
1976   int dimension, pointer, allocatable, target;
1977   symbol_attribute attr;
1978   gfc_ref *ref;
1979   gfc_symbol *sym;
1980   gfc_component *comp;
1981
1982   if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
1983     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1984
1985   ref = expr->ref;
1986   sym = expr->symtree->n.sym;
1987   attr = sym->attr;
1988
1989   if (sym->ts.type == BT_CLASS)
1990     {
1991       dimension = sym->ts.u.derived->components->attr.dimension;
1992       pointer = sym->ts.u.derived->components->attr.pointer;
1993       allocatable = sym->ts.u.derived->components->attr.allocatable;
1994     }
1995   else
1996     {
1997       dimension = attr.dimension;
1998       pointer = attr.pointer;
1999       allocatable = attr.allocatable;
2000     }
2001
2002   target = attr.target;
2003   if (pointer || attr.proc_pointer)
2004     target = 1;
2005
2006   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2007     *ts = sym->ts;
2008
2009   for (; ref; ref = ref->next)
2010     switch (ref->type)
2011       {
2012       case REF_ARRAY:
2013
2014         switch (ref->u.ar.type)
2015           {
2016           case AR_FULL:
2017             dimension = 1;
2018             break;
2019
2020           case AR_SECTION:
2021             allocatable = pointer = 0;
2022             dimension = 1;
2023             break;
2024
2025           case AR_ELEMENT:
2026             allocatable = pointer = 0;
2027             break;
2028
2029           case AR_UNKNOWN:
2030             gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2031           }
2032
2033         break;
2034
2035       case REF_COMPONENT:
2036         comp = ref->u.c.component;
2037         attr = comp->attr;
2038         if (ts != NULL)
2039           {
2040             *ts = comp->ts;
2041             /* Don't set the string length if a substring reference
2042                follows.  */
2043             if (ts->type == BT_CHARACTER
2044                 && ref->next && ref->next->type == REF_SUBSTRING)
2045                 ts->u.cl = NULL;
2046           }
2047
2048         if (comp->ts.type == BT_CLASS)
2049           {
2050             pointer = comp->ts.u.derived->components->attr.pointer;
2051             allocatable = comp->ts.u.derived->components->attr.allocatable;
2052           }
2053         else
2054           {
2055             pointer = comp->attr.pointer;
2056             allocatable = comp->attr.allocatable;
2057           }
2058         if (pointer || attr.proc_pointer)
2059           target = 1;
2060
2061         break;
2062
2063       case REF_SUBSTRING:
2064         allocatable = pointer = 0;
2065         break;
2066       }
2067
2068   attr.dimension = dimension;
2069   attr.pointer = pointer;
2070   attr.allocatable = allocatable;
2071   attr.target = target;
2072
2073   return attr;
2074 }
2075
2076
2077 /* Return the attribute from a general expression.  */
2078
2079 symbol_attribute
2080 gfc_expr_attr (gfc_expr *e)
2081 {
2082   symbol_attribute attr;
2083
2084   switch (e->expr_type)
2085     {
2086     case EXPR_VARIABLE:
2087       attr = gfc_variable_attr (e, NULL);
2088       break;
2089
2090     case EXPR_FUNCTION:
2091       gfc_clear_attr (&attr);
2092
2093       if (e->value.function.esym != NULL)
2094         {
2095           gfc_symbol *sym = e->value.function.esym->result;
2096           attr = sym->attr;
2097           if (sym->ts.type == BT_CLASS)
2098             {
2099               attr.dimension = sym->ts.u.derived->components->attr.dimension;
2100               attr.pointer = sym->ts.u.derived->components->attr.pointer;
2101               attr.allocatable = sym->ts.u.derived->components->attr.allocatable;
2102             }
2103         }
2104       else
2105         attr = gfc_variable_attr (e, NULL);
2106
2107       /* TODO: NULL() returns pointers.  May have to take care of this
2108          here.  */
2109
2110       break;
2111
2112     default:
2113       gfc_clear_attr (&attr);
2114       break;
2115     }
2116
2117   return attr;
2118 }
2119
2120
2121 /* Match a structure constructor.  The initial symbol has already been
2122    seen.  */
2123
2124 typedef struct gfc_structure_ctor_component
2125 {
2126   char* name;
2127   gfc_expr* val;
2128   locus where;
2129   struct gfc_structure_ctor_component* next;
2130 }
2131 gfc_structure_ctor_component;
2132
2133 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2134
2135 static void
2136 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
2137 {
2138   gfc_free (comp->name);
2139   gfc_free_expr (comp->val);
2140 }
2141
2142
2143 /* Translate the component list into the actual constructor by sorting it in
2144    the order required; this also checks along the way that each and every
2145    component actually has an initializer and handles default initializers
2146    for components without explicit value given.  */
2147 static gfc_try
2148 build_actual_constructor (gfc_structure_ctor_component **comp_head,
2149                           gfc_constructor **ctor_head, gfc_symbol *sym)
2150 {
2151   gfc_structure_ctor_component *comp_iter;
2152   gfc_constructor *ctor_tail = NULL;
2153   gfc_component *comp;
2154
2155   for (comp = sym->components; comp; comp = comp->next)
2156     {
2157       gfc_structure_ctor_component **next_ptr;
2158       gfc_expr *value = NULL;
2159
2160       /* Try to find the initializer for the current component by name.  */
2161       next_ptr = comp_head;
2162       for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
2163         {
2164           if (!strcmp (comp_iter->name, comp->name))
2165             break;
2166           next_ptr = &comp_iter->next;
2167         }
2168
2169       /* If an extension, try building the parent derived type by building
2170          a value expression for the parent derived type and calling self.  */
2171       if (!comp_iter && comp == sym->components && sym->attr.extension)
2172         {
2173           value = gfc_get_expr ();
2174           value->expr_type = EXPR_STRUCTURE;
2175           value->value.constructor = NULL;
2176           value->ts = comp->ts;
2177           value->where = gfc_current_locus;
2178
2179           if (build_actual_constructor (comp_head, &value->value.constructor,
2180                                         comp->ts.u.derived) == FAILURE)
2181             {
2182               gfc_free_expr (value);
2183               return FAILURE;
2184             }
2185           *ctor_head = ctor_tail = gfc_get_constructor ();
2186           ctor_tail->expr = value;
2187           continue;
2188         }
2189
2190       /* If it was not found, try the default initializer if there's any;
2191          otherwise, it's an error.  */
2192       if (!comp_iter)
2193         {
2194           if (comp->initializer)
2195             {
2196               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2197                                   " constructor with missing optional arguments"
2198                                   " at %C") == FAILURE)
2199                 return FAILURE;
2200               value = gfc_copy_expr (comp->initializer);
2201             }
2202           else
2203             {
2204               gfc_error ("No initializer for component '%s' given in the"
2205                          " structure constructor at %C!", comp->name);
2206               return FAILURE;
2207             }
2208         }
2209       else
2210         value = comp_iter->val;
2211
2212       /* Add the value to the constructor chain built.  */
2213       if (ctor_tail)
2214         {
2215           ctor_tail->next = gfc_get_constructor ();
2216           ctor_tail = ctor_tail->next;
2217         }
2218       else
2219         *ctor_head = ctor_tail = gfc_get_constructor ();
2220       gcc_assert (value);
2221       ctor_tail->expr = value;
2222
2223       /* Remove the entry from the component list.  We don't want the expression
2224          value to be free'd, so set it to NULL.  */
2225       if (comp_iter)
2226         {
2227           *next_ptr = comp_iter->next;
2228           comp_iter->val = NULL;
2229           gfc_free_structure_ctor_component (comp_iter);
2230         }
2231     }
2232   return SUCCESS;
2233 }
2234
2235 match
2236 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2237                                  bool parent)
2238 {
2239   gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2240   gfc_constructor *ctor_head, *ctor_tail;
2241   gfc_component *comp; /* Is set NULL when named component is first seen */
2242   gfc_expr *e;
2243   locus where;
2244   match m;
2245   const char* last_name = NULL;
2246
2247   comp_tail = comp_head = NULL;
2248   ctor_head = ctor_tail = NULL;
2249
2250   if (!parent && gfc_match_char ('(') != MATCH_YES)
2251     goto syntax;
2252
2253   where = gfc_current_locus;
2254
2255   gfc_find_component (sym, NULL, false, true);
2256
2257   /* Check that we're not about to construct an ABSTRACT type.  */
2258   if (!parent && sym->attr.abstract)
2259     {
2260       gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
2261       return MATCH_ERROR;
2262     }
2263
2264   /* Match the component list and store it in a list together with the
2265      corresponding component names.  Check for empty argument list first.  */
2266   if (gfc_match_char (')') != MATCH_YES)
2267     {
2268       comp = sym->components;
2269       do
2270         {
2271           gfc_component *this_comp = NULL;
2272
2273           if (!comp_head)
2274             comp_tail = comp_head = gfc_get_structure_ctor_component ();
2275           else
2276             {
2277               comp_tail->next = gfc_get_structure_ctor_component ();
2278               comp_tail = comp_tail->next;
2279             }
2280           comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
2281           comp_tail->val = NULL;
2282           comp_tail->where = gfc_current_locus;
2283
2284           /* Try matching a component name.  */
2285           if (gfc_match_name (comp_tail->name) == MATCH_YES
2286               && gfc_match_char ('=') == MATCH_YES)
2287             {
2288               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2289                                   " constructor with named arguments at %C")
2290                   == FAILURE)
2291                 goto cleanup;
2292
2293               last_name = comp_tail->name;
2294               comp = NULL;
2295             }
2296           else
2297             {
2298               /* Components without name are not allowed after the first named
2299                  component initializer!  */
2300               if (!comp)
2301                 {
2302                   if (last_name)
2303                     gfc_error ("Component initializer without name after"
2304                                " component named %s at %C!", last_name);
2305                   else if (!parent)
2306                     gfc_error ("Too many components in structure constructor at"
2307                                " %C!");
2308                   goto cleanup;
2309                 }
2310
2311               gfc_current_locus = comp_tail->where;
2312               strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
2313             }
2314
2315           /* Find the current component in the structure definition and check
2316              its access is not private.  */
2317           if (comp)
2318             this_comp = gfc_find_component (sym, comp->name, false, false);
2319           else
2320             {
2321               this_comp = gfc_find_component (sym,
2322                                               (const char *)comp_tail->name,
2323                                               false, false);
2324               comp = NULL; /* Reset needed!  */
2325             }
2326
2327           /* Here we can check if a component name is given which does not
2328              correspond to any component of the defined structure.  */
2329           if (!this_comp)
2330             goto cleanup;
2331
2332           /* Check if this component is already given a value.  */
2333           for (comp_iter = comp_head; comp_iter != comp_tail;
2334                comp_iter = comp_iter->next)
2335             {
2336               gcc_assert (comp_iter);
2337               if (!strcmp (comp_iter->name, comp_tail->name))
2338                 {
2339                   gfc_error ("Component '%s' is initialized twice in the"
2340                              " structure constructor at %C!", comp_tail->name);
2341                   goto cleanup;
2342                 }
2343             }
2344
2345           /* Match the current initializer expression.  */
2346           m = gfc_match_expr (&comp_tail->val);
2347           if (m == MATCH_NO)
2348             goto syntax;
2349           if (m == MATCH_ERROR)
2350             goto cleanup;
2351
2352           /* If not explicitly a parent constructor, gather up the components
2353              and build one.  */
2354           if (comp && comp == sym->components
2355                 && sym->attr.extension
2356                 && (comp_tail->val->ts.type != BT_DERIVED
2357                       ||
2358                     comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
2359             {
2360               gfc_current_locus = where;
2361               gfc_free_expr (comp_tail->val);
2362               comp_tail->val = NULL;
2363
2364               m = gfc_match_structure_constructor (comp->ts.u.derived,
2365                                                    &comp_tail->val, true);
2366               if (m == MATCH_NO)
2367                 goto syntax;
2368               if (m == MATCH_ERROR)
2369                 goto cleanup;
2370             }
2371
2372           if (comp)
2373             comp = comp->next;
2374
2375           if (parent && !comp)
2376             break;
2377         }
2378
2379       while (gfc_match_char (',') == MATCH_YES);
2380
2381       if (!parent && gfc_match_char (')') != MATCH_YES)
2382         goto syntax;
2383     }
2384
2385   if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2386     goto cleanup;
2387
2388   /* No component should be left, as this should have caused an error in the
2389      loop constructing the component-list (name that does not correspond to any
2390      component in the structure definition).  */
2391   if (comp_head && sym->attr.extension)
2392     {
2393       for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2394         {
2395           gfc_error ("component '%s' at %L has already been set by a "
2396                      "parent derived type constructor", comp_iter->name,
2397                      &comp_iter->where);
2398         }
2399       goto cleanup;
2400     }
2401   else
2402     gcc_assert (!comp_head);
2403
2404   e = gfc_get_expr ();
2405
2406   e->expr_type = EXPR_STRUCTURE;
2407
2408   e->ts.type = BT_DERIVED;
2409   e->ts.u.derived = sym;
2410   e->where = where;
2411
2412   e->value.constructor = ctor_head;
2413
2414   *result = e;
2415   return MATCH_YES;
2416
2417 syntax:
2418   gfc_error ("Syntax error in structure constructor at %C");
2419
2420 cleanup:
2421   for (comp_iter = comp_head; comp_iter; )
2422     {
2423       gfc_structure_ctor_component *next = comp_iter->next;
2424       gfc_free_structure_ctor_component (comp_iter);
2425       comp_iter = next;
2426     }
2427   gfc_free_constructor (ctor_head);
2428   return MATCH_ERROR;
2429 }
2430
2431
2432 /* If the symbol is an implicit do loop index and implicitly typed,
2433    it should not be host associated.  Provide a symtree from the
2434    current namespace.  */
2435 static match
2436 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2437 {
2438   if ((*sym)->attr.flavor == FL_VARIABLE
2439       && (*sym)->ns != gfc_current_ns
2440       && (*sym)->attr.implied_index
2441       && (*sym)->attr.implicit_type
2442       && !(*sym)->attr.use_assoc)
2443     {
2444       int i;
2445       i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
2446       if (i)
2447         return MATCH_ERROR;
2448       *sym = (*st)->n.sym;
2449     }
2450   return MATCH_YES;
2451 }
2452
2453
2454 /* Procedure pointer as function result: Replace the function symbol by the
2455    auto-generated hidden result variable named "ppr@".  */
2456
2457 static gfc_try
2458 replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
2459 {
2460   /* Check for procedure pointer result variable.  */
2461   if ((*sym)->attr.function && !(*sym)->attr.external
2462       && (*sym)->result && (*sym)->result != *sym
2463       && (*sym)->result->attr.proc_pointer
2464       && (*sym) == gfc_current_ns->proc_name
2465       && (*sym) == (*sym)->result->ns->proc_name
2466       && strcmp ("ppr@", (*sym)->result->name) == 0)
2467     {
2468       /* Automatic replacement with "hidden" result variable.  */
2469       (*sym)->result->attr.referenced = (*sym)->attr.referenced;
2470       *sym = (*sym)->result;
2471       *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
2472       return SUCCESS;
2473     }
2474   return FAILURE;
2475 }
2476
2477
2478 /* Matches a variable name followed by anything that might follow it--
2479    array reference, argument list of a function, etc.  */
2480
2481 match
2482 gfc_match_rvalue (gfc_expr **result)
2483 {
2484   gfc_actual_arglist *actual_arglist;
2485   char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2486   gfc_state_data *st;
2487   gfc_symbol *sym;
2488   gfc_symtree *symtree;
2489   locus where, old_loc;
2490   gfc_expr *e;
2491   match m, m2;
2492   int i;
2493   gfc_typespec *ts;
2494   bool implicit_char;
2495   gfc_ref *ref;
2496
2497   m = gfc_match_name (name);
2498   if (m != MATCH_YES)
2499     return m;
2500
2501   if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2502       && !gfc_current_ns->has_import_set)
2503     i = gfc_get_sym_tree (name, NULL, &symtree, false);
2504   else
2505     i = gfc_get_ha_sym_tree (name, &symtree);
2506
2507   if (i)
2508     return MATCH_ERROR;
2509
2510   sym = symtree->n.sym;
2511   e = NULL;
2512   where = gfc_current_locus;
2513
2514   replace_hidden_procptr_result (&sym, &symtree);
2515
2516   /* If this is an implicit do loop index and implicitly typed,
2517      it should not be host associated.  */
2518   m = check_for_implicit_index (&symtree, &sym);
2519   if (m != MATCH_YES)
2520     return m;
2521
2522   gfc_set_sym_referenced (sym);
2523   sym->attr.implied_index = 0;
2524
2525   if (sym->attr.function && sym->result == sym)
2526     {
2527       /* See if this is a directly recursive function call.  */
2528       gfc_gobble_whitespace ();
2529       if (sym->attr.recursive
2530           && gfc_peek_ascii_char () == '('
2531           && gfc_current_ns->proc_name == sym
2532           && !sym->attr.dimension)
2533         {
2534           gfc_error ("'%s' at %C is the name of a recursive function "
2535                      "and so refers to the result variable. Use an "
2536                      "explicit RESULT variable for direct recursion "
2537                      "(12.5.2.1)", sym->name);
2538           return MATCH_ERROR;
2539         }
2540
2541       if (gfc_is_function_return_value (sym, gfc_current_ns))
2542         goto variable;
2543
2544       if (sym->attr.entry
2545           && (sym->ns == gfc_current_ns
2546               || sym->ns == gfc_current_ns->parent))
2547         {
2548           gfc_entry_list *el = NULL;
2549
2550           for (el = sym->ns->entries; el; el = el->next)
2551             if (sym == el->sym)
2552               goto variable;
2553         }
2554     }
2555
2556   if (gfc_matching_procptr_assignment)
2557     goto procptr0;
2558
2559   if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2560     goto function0;
2561
2562   if (sym->attr.generic)
2563     goto generic_function;
2564
2565   switch (sym->attr.flavor)
2566     {
2567     case FL_VARIABLE:
2568     variable:
2569       e = gfc_get_expr ();
2570
2571       e->expr_type = EXPR_VARIABLE;
2572       e->symtree = symtree;
2573
2574       m = gfc_match_varspec (e, 0, false, true);
2575       break;
2576
2577     case FL_PARAMETER:
2578       /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2579          end up here.  Unfortunately, sym->value->expr_type is set to
2580          EXPR_CONSTANT, and so the if () branch would be followed without
2581          the !sym->as check.  */
2582       if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2583         e = gfc_copy_expr (sym->value);
2584       else
2585         {
2586           e = gfc_get_expr ();
2587           e->expr_type = EXPR_VARIABLE;
2588         }
2589
2590       e->symtree = symtree;
2591       m = gfc_match_varspec (e, 0, false, true);
2592
2593       if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2594         break;
2595
2596       /* Variable array references to derived type parameters cause
2597          all sorts of headaches in simplification. Treating such
2598          expressions as variable works just fine for all array
2599          references.  */
2600       if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2601         {
2602           for (ref = e->ref; ref; ref = ref->next)
2603             if (ref->type == REF_ARRAY)
2604               break;
2605
2606           if (ref == NULL || ref->u.ar.type == AR_FULL)
2607             break;
2608
2609           ref = e->ref;
2610           e->ref = NULL;
2611           gfc_free_expr (e);
2612           e = gfc_get_expr ();
2613           e->expr_type = EXPR_VARIABLE;
2614           e->symtree = symtree;
2615           e->ref = ref;
2616         }
2617
2618       break;
2619
2620     case FL_DERIVED:
2621       sym = gfc_use_derived (sym);
2622       if (sym == NULL)
2623         m = MATCH_ERROR;
2624       else
2625         m = gfc_match_structure_constructor (sym, &e, false);
2626       break;
2627
2628     /* If we're here, then the name is known to be the name of a
2629        procedure, yet it is not sure to be the name of a function.  */
2630     case FL_PROCEDURE:
2631
2632     /* Procedure Pointer Assignments. */
2633     procptr0:
2634       if (gfc_matching_procptr_assignment)
2635         {
2636           gfc_gobble_whitespace ();
2637           if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
2638             /* Parse functions returning a procptr.  */
2639             goto function0;
2640
2641           if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
2642               || gfc_is_intrinsic (sym, 1, gfc_current_locus))
2643             sym->attr.intrinsic = 1;
2644           e = gfc_get_expr ();
2645           e->expr_type = EXPR_VARIABLE;
2646           e->symtree = symtree;
2647           m = gfc_match_varspec (e, 0, false, true);
2648           break;
2649         }
2650
2651       if (sym->attr.subroutine)
2652         {
2653           gfc_error ("Unexpected use of subroutine name '%s' at %C",
2654                      sym->name);
2655           m = MATCH_ERROR;
2656           break;
2657         }
2658
2659       /* At this point, the name has to be a non-statement function.
2660          If the name is the same as the current function being
2661          compiled, then we have a variable reference (to the function
2662          result) if the name is non-recursive.  */
2663
2664       st = gfc_enclosing_unit (NULL);
2665
2666       if (st != NULL && st->state == COMP_FUNCTION
2667           && st->sym == sym
2668           && !sym->attr.recursive)
2669         {
2670           e = gfc_get_expr ();
2671           e->symtree = symtree;
2672           e->expr_type = EXPR_VARIABLE;
2673
2674           m = gfc_match_varspec (e, 0, false, true);
2675           break;
2676         }
2677
2678     /* Match a function reference.  */
2679     function0:
2680       m = gfc_match_actual_arglist (0, &actual_arglist);
2681       if (m == MATCH_NO)
2682         {
2683           if (sym->attr.proc == PROC_ST_FUNCTION)
2684             gfc_error ("Statement function '%s' requires argument list at %C",
2685                        sym->name);
2686           else
2687             gfc_error ("Function '%s' requires an argument list at %C",
2688                        sym->name);
2689
2690           m = MATCH_ERROR;
2691           break;
2692         }
2693
2694       if (m != MATCH_YES)
2695         {
2696           m = MATCH_ERROR;
2697           break;
2698         }
2699
2700       gfc_get_ha_sym_tree (name, &symtree);     /* Can't fail */
2701       sym = symtree->n.sym;
2702
2703       replace_hidden_procptr_result (&sym, &symtree);
2704
2705       e = gfc_get_expr ();
2706       e->symtree = symtree;
2707       e->expr_type = EXPR_FUNCTION;
2708       e->value.function.actual = actual_arglist;
2709       e->where = gfc_current_locus;
2710
2711       if (sym->as != NULL)
2712         e->rank = sym->as->rank;
2713
2714       if (!sym->attr.function
2715           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2716         {
2717           m = MATCH_ERROR;
2718           break;
2719         }
2720
2721       /* Check here for the existence of at least one argument for the
2722          iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED.  The
2723          argument(s) given will be checked in gfc_iso_c_func_interface,
2724          during resolution of the function call.  */
2725       if (sym->attr.is_iso_c == 1
2726           && (sym->from_intmod == INTMOD_ISO_C_BINDING
2727               && (sym->intmod_sym_id == ISOCBINDING_LOC
2728                   || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2729                   || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2730         {
2731           /* make sure we were given a param */
2732           if (actual_arglist == NULL)
2733             {
2734               gfc_error ("Missing argument to '%s' at %C", sym->name);
2735               m = MATCH_ERROR;
2736               break;
2737             }
2738         }
2739
2740       if (sym->result == NULL)
2741         sym->result = sym;
2742
2743       m = MATCH_YES;
2744       break;
2745
2746     case FL_UNKNOWN:
2747
2748       /* Special case for derived type variables that get their types
2749          via an IMPLICIT statement.  This can't wait for the
2750          resolution phase.  */
2751
2752       if (gfc_peek_ascii_char () == '%'
2753           && sym->ts.type == BT_UNKNOWN
2754           && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2755         gfc_set_default_type (sym, 0, sym->ns);
2756
2757       /* If the symbol has a dimension attribute, the expression is a
2758          variable.  */
2759
2760       if (sym->attr.dimension)
2761         {
2762           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2763                               sym->name, NULL) == FAILURE)
2764             {
2765               m = MATCH_ERROR;
2766               break;
2767             }
2768
2769           e = gfc_get_expr ();
2770           e->symtree = symtree;
2771           e->expr_type = EXPR_VARIABLE;
2772           m = gfc_match_varspec (e, 0, false, true);
2773           break;
2774         }
2775
2776       /* Name is not an array, so we peek to see if a '(' implies a
2777          function call or a substring reference.  Otherwise the
2778          variable is just a scalar.  */
2779
2780       gfc_gobble_whitespace ();
2781       if (gfc_peek_ascii_char () != '(')
2782         {
2783           /* Assume a scalar variable */
2784           e = gfc_get_expr ();
2785           e->symtree = symtree;
2786           e->expr_type = EXPR_VARIABLE;
2787
2788           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2789                               sym->name, NULL) == FAILURE)
2790             {
2791               m = MATCH_ERROR;
2792               break;
2793             }
2794
2795           /*FIXME:??? gfc_match_varspec does set this for us: */
2796           e->ts = sym->ts;
2797           m = gfc_match_varspec (e, 0, false, true);
2798           break;
2799         }
2800
2801       /* See if this is a function reference with a keyword argument
2802          as first argument. We do this because otherwise a spurious
2803          symbol would end up in the symbol table.  */
2804
2805       old_loc = gfc_current_locus;
2806       m2 = gfc_match (" ( %n =", argname);
2807       gfc_current_locus = old_loc;
2808
2809       e = gfc_get_expr ();
2810       e->symtree = symtree;
2811
2812       if (m2 != MATCH_YES)
2813         {
2814           /* Try to figure out whether we're dealing with a character type.
2815              We're peeking ahead here, because we don't want to call
2816              match_substring if we're dealing with an implicitly typed
2817              non-character variable.  */
2818           implicit_char = false;
2819           if (sym->ts.type == BT_UNKNOWN)
2820             {
2821               ts = gfc_get_default_type (sym->name, NULL);
2822               if (ts->type == BT_CHARACTER)
2823                 implicit_char = true;
2824             }
2825
2826           /* See if this could possibly be a substring reference of a name
2827              that we're not sure is a variable yet.  */
2828
2829           if ((implicit_char || sym->ts.type == BT_CHARACTER)
2830               && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
2831             {
2832
2833               e->expr_type = EXPR_VARIABLE;
2834
2835               if (sym->attr.flavor != FL_VARIABLE
2836                   && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2837                                      sym->name, NULL) == FAILURE)
2838                 {
2839                   m = MATCH_ERROR;
2840                   break;
2841                 }
2842
2843               if (sym->ts.type == BT_UNKNOWN
2844                   && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2845                 {
2846                   m = MATCH_ERROR;
2847                   break;
2848                 }
2849
2850               e->ts = sym->ts;
2851               if (e->ref)
2852                 e->ts.u.cl = NULL;
2853               m = MATCH_YES;
2854               break;
2855             }
2856         }
2857
2858       /* Give up, assume we have a function.  */
2859
2860       gfc_get_sym_tree (name, NULL, &symtree, false);   /* Can't fail */
2861       sym = symtree->n.sym;
2862       e->expr_type = EXPR_FUNCTION;
2863
2864       if (!sym->attr.function
2865           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2866         {
2867           m = MATCH_ERROR;
2868           break;
2869         }
2870
2871       sym->result = sym;
2872
2873       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2874       if (m == MATCH_NO)
2875         gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2876
2877       if (m != MATCH_YES)
2878         {
2879           m = MATCH_ERROR;
2880           break;
2881         }
2882
2883       /* If our new function returns a character, array or structure
2884          type, it might have subsequent references.  */
2885
2886       m = gfc_match_varspec (e, 0, false, true);
2887       if (m == MATCH_NO)
2888         m = MATCH_YES;
2889
2890       break;
2891
2892     generic_function:
2893       gfc_get_sym_tree (name, NULL, &symtree, false);   /* Can't fail */
2894
2895       e = gfc_get_expr ();
2896       e->symtree = symtree;
2897       e->expr_type = EXPR_FUNCTION;
2898
2899       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2900       break;
2901
2902     default:
2903       gfc_error ("Symbol at %C is not appropriate for an expression");
2904       return MATCH_ERROR;
2905     }
2906
2907   if (m == MATCH_YES)
2908     {
2909       e->where = where;
2910       *result = e;
2911     }
2912   else
2913     gfc_free_expr (e);
2914
2915   return m;
2916 }
2917
2918
2919 /* Match a variable, i.e. something that can be assigned to.  This
2920    starts as a symbol, can be a structure component or an array
2921    reference.  It can be a function if the function doesn't have a
2922    separate RESULT variable.  If the symbol has not been previously
2923    seen, we assume it is a variable.
2924
2925    This function is called by two interface functions:
2926    gfc_match_variable, which has host_flag = 1, and
2927    gfc_match_equiv_variable, with host_flag = 0, to restrict the
2928    match of the symbol to the local scope.  */
2929
2930 static match
2931 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2932 {
2933   gfc_symbol *sym;
2934   gfc_symtree *st;
2935   gfc_expr *expr;
2936   locus where;
2937   match m;
2938
2939   /* Since nothing has any business being an lvalue in a module
2940      specification block, an interface block or a contains section,
2941      we force the changed_symbols mechanism to work by setting
2942      host_flag to 0. This prevents valid symbols that have the name
2943      of keywords, such as 'end', being turned into variables by
2944      failed matching to assignments for, e.g., END INTERFACE.  */
2945   if (gfc_current_state () == COMP_MODULE
2946       || gfc_current_state () == COMP_INTERFACE
2947       || gfc_current_state () == COMP_CONTAINS)
2948     host_flag = 0;
2949
2950   where = gfc_current_locus;
2951   m = gfc_match_sym_tree (&st, host_flag);
2952   if (m != MATCH_YES)
2953     return m;
2954
2955   sym = st->n.sym;
2956
2957   /* If this is an implicit do loop index and implicitly typed,
2958      it should not be host associated.  */
2959   m = check_for_implicit_index (&st, &sym);
2960   if (m != MATCH_YES)
2961     return m;
2962
2963   sym->attr.implied_index = 0;
2964
2965   gfc_set_sym_referenced (sym);
2966   switch (sym->attr.flavor)
2967     {
2968     case FL_VARIABLE:
2969       if (sym->attr.is_protected && sym->attr.use_assoc)
2970         {
2971           gfc_error ("Assigning to PROTECTED variable at %C");
2972           return MATCH_ERROR;
2973         }
2974       break;
2975
2976     case FL_UNKNOWN:
2977       {
2978         sym_flavor flavor = FL_UNKNOWN;
2979
2980         gfc_gobble_whitespace ();
2981
2982         if (sym->attr.external || sym->attr.procedure
2983             || sym->attr.function || sym->attr.subroutine)
2984           flavor = FL_PROCEDURE;
2985
2986         /* If it is not a procedure, is not typed and is host associated,
2987            we cannot give it a flavor yet.  */
2988         else if (sym->ns == gfc_current_ns->parent
2989                    && sym->ts.type == BT_UNKNOWN)
2990           break;
2991
2992         /* These are definitive indicators that this is a variable.  */
2993         else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
2994                  || sym->attr.pointer || sym->as != NULL)
2995           flavor = FL_VARIABLE;
2996
2997         if (flavor != FL_UNKNOWN
2998             && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
2999           return MATCH_ERROR;
3000       }
3001       break;
3002
3003     case FL_PARAMETER:
3004       if (equiv_flag)
3005         gfc_error ("Named constant at %C in an EQUIVALENCE");
3006       else
3007         gfc_error ("Cannot assign to a named constant at %C");
3008       return MATCH_ERROR;
3009       break;
3010
3011     case FL_PROCEDURE:
3012       /* Check for a nonrecursive function result variable.  */
3013       if (sym->attr.function
3014           && !sym->attr.external
3015           && sym->result == sym
3016           && (gfc_is_function_return_value (sym, gfc_current_ns)
3017               || (sym->attr.entry
3018                   && sym->ns == gfc_current_ns)
3019               || (sym->attr.entry
3020                   && sym->ns == gfc_current_ns->parent)))
3021         {
3022           /* If a function result is a derived type, then the derived
3023              type may still have to be resolved.  */
3024
3025           if (sym->ts.type == BT_DERIVED
3026               && gfc_use_derived (sym->ts.u.derived) == NULL)
3027             return MATCH_ERROR;
3028           break;
3029         }
3030
3031       if (sym->attr.proc_pointer
3032           || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
3033         break;
3034
3035       /* Fall through to error */
3036
3037     default:
3038       gfc_error ("'%s' at %C is not a variable", sym->name);
3039       return MATCH_ERROR;
3040     }
3041
3042   /* Special case for derived type variables that get their types
3043      via an IMPLICIT statement.  This can't wait for the
3044      resolution phase.  */
3045
3046     {
3047       gfc_namespace * implicit_ns;
3048
3049       if (gfc_current_ns->proc_name == sym)
3050         implicit_ns = gfc_current_ns;
3051       else
3052         implicit_ns = sym->ns;
3053
3054       if (gfc_peek_ascii_char () == '%'
3055           && sym->ts.type == BT_UNKNOWN
3056           && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
3057         gfc_set_default_type (sym, 0, implicit_ns);
3058     }
3059
3060   expr = gfc_get_expr ();
3061
3062   expr->expr_type = EXPR_VARIABLE;
3063   expr->symtree = st;
3064   expr->ts = sym->ts;
3065   expr->where = where;
3066
3067   /* Now see if we have to do more.  */
3068   m = gfc_match_varspec (expr, equiv_flag, false, false);
3069   if (m != MATCH_YES)
3070     {
3071       gfc_free_expr (expr);
3072       return m;
3073     }
3074
3075   *result = expr;
3076   return MATCH_YES;
3077 }
3078
3079
3080 match
3081 gfc_match_variable (gfc_expr **result, int equiv_flag)
3082 {
3083   return match_variable (result, equiv_flag, 1);
3084 }
3085
3086
3087 match
3088 gfc_match_equiv_variable (gfc_expr **result)
3089 {
3090   return match_variable (result, 1, 0);
3091 }
3092