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