gcc/fortran/primary.c

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