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 (INSTRING_WARN);
 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 (INSTRING_WARN);
 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 (NONSTRING);
 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 && sym->attr.class_ok
1778           && CLASS_DATA (sym)->attr.dimension))
1779     {
1780       /* In EQUIVALENCE, we don't know yet whether we are seeing
1781          an array, character variable or array of character
1782          variables.  We'll leave the decision till resolve time.  */
1783       tail = extend_ref (primary, tail);
1784       tail->type = REF_ARRAY;
1785
1786       m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1787                                equiv_flag,
1788                                sym->ts.type == BT_CLASS
1789                                ? (CLASS_DATA (sym)->as
1790                                   ? CLASS_DATA (sym)->as->corank : 0)
1791                                : (sym->as ? sym->as->corank : 0));
1792       if (m != MATCH_YES)
1793         return m;
1794
1795       gfc_gobble_whitespace ();
1796       if (equiv_flag && gfc_peek_ascii_char () == '(')
1797         {
1798           tail = extend_ref (primary, tail);
1799           tail->type = REF_ARRAY;
1800
1801           m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
1802           if (m != MATCH_YES)
1803             return m;
1804         }
1805     }
1806
1807   primary->ts = sym->ts;
1808
1809   if (equiv_flag)
1810     return MATCH_YES;
1811
1812   if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
1813       && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
1814     gfc_set_default_type (sym, 0, sym->ns);
1815
1816   if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
1817       || gfc_match_char ('%') != MATCH_YES)
1818     goto check_substring;
1819
1820   sym = sym->ts.u.derived;
1821
1822   for (;;)
1823     {
1824       gfc_try t;
1825       gfc_symtree *tbp;
1826
1827       m = gfc_match_name (name);
1828       if (m == MATCH_NO)
1829         gfc_error ("Expected structure component name at %C");
1830       if (m != MATCH_YES)
1831         return MATCH_ERROR;
1832
1833       if (sym->f2k_derived)
1834         tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
1835       else
1836         tbp = NULL;
1837
1838       if (tbp)
1839         {
1840           gfc_symbol* tbp_sym;
1841
1842           if (t == FAILURE)
1843             return MATCH_ERROR;
1844
1845           gcc_assert (!tail || !tail->next);
1846           gcc_assert (primary->expr_type == EXPR_VARIABLE);
1847
1848           if (tbp->n.tb->is_generic)
1849             tbp_sym = NULL;
1850           else
1851             tbp_sym = tbp->n.tb->u.specific->n.sym;
1852
1853           primary->expr_type = EXPR_COMPCALL;
1854           primary->value.compcall.tbp = tbp->n.tb;
1855           primary->value.compcall.name = tbp->name;
1856           primary->value.compcall.ignore_pass = 0;
1857           primary->value.compcall.assign = 0;
1858           primary->value.compcall.base_object = NULL;
1859           gcc_assert (primary->symtree->n.sym->attr.referenced);
1860           if (tbp_sym)
1861             primary->ts = tbp_sym->ts;
1862
1863           m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
1864                                         &primary->value.compcall.actual);
1865           if (m == MATCH_ERROR)
1866             return MATCH_ERROR;
1867           if (m == MATCH_NO)
1868             {
1869               if (sub_flag)
1870                 primary->value.compcall.actual = NULL;
1871               else
1872                 {
1873                   gfc_error ("Expected argument list at %C");
1874                   return MATCH_ERROR;
1875                 }
1876             }
1877
1878           break;
1879         }
1880
1881       component = gfc_find_component (sym, name, false, false);
1882       if (component == NULL)
1883         return MATCH_ERROR;
1884
1885       tail = extend_ref (primary, tail);
1886       tail->type = REF_COMPONENT;
1887
1888       tail->u.c.component = component;
1889       tail->u.c.sym = sym;
1890
1891       primary->ts = component->ts;
1892
1893       if (component->attr.proc_pointer && ppc_arg
1894           && !gfc_matching_procptr_assignment)
1895         {
1896           /* Procedure pointer component call: Look for argument list.  */
1897           m = gfc_match_actual_arglist (sub_flag,
1898                                         &primary->value.compcall.actual);
1899           if (m == MATCH_ERROR)
1900             return MATCH_ERROR;
1901
1902           if (m == MATCH_NO && !gfc_matching_ptr_assignment
1903               && !matching_actual_arglist)
1904             {
1905               gfc_error ("Procedure pointer component '%s' requires an "
1906                          "argument list at %C", component->name);
1907               return MATCH_ERROR;
1908             }
1909
1910           if (m == MATCH_YES)
1911             primary->expr_type = EXPR_PPC;
1912
1913           break;
1914         }
1915
1916       if (component->as != NULL && !component->attr.proc_pointer)
1917         {
1918           tail = extend_ref (primary, tail);
1919           tail->type = REF_ARRAY;
1920
1921           m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
1922                           component->as->corank);
1923           if (m != MATCH_YES)
1924             return m;
1925         }
1926       else if (component->ts.type == BT_CLASS
1927                && CLASS_DATA (component)->as != NULL
1928                && !component->attr.proc_pointer)
1929         {
1930           tail = extend_ref (primary, tail);
1931           tail->type = REF_ARRAY;
1932
1933           m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
1934                                    equiv_flag,
1935                                    CLASS_DATA (component)->as->corank);
1936           if (m != MATCH_YES)
1937             return m;
1938         }
1939
1940       if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
1941           || gfc_match_char ('%') != MATCH_YES)
1942         break;
1943
1944       sym = component->ts.u.derived;
1945     }
1946
1947 check_substring:
1948   unknown = false;
1949   if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
1950     {
1951       if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
1952        {
1953          gfc_set_default_type (sym, 0, sym->ns);
1954          primary->ts = sym->ts;
1955          unknown = true;
1956        }
1957     }
1958
1959   if (primary->ts.type == BT_CHARACTER)
1960     {
1961       switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
1962         {
1963         case MATCH_YES:
1964           if (tail == NULL)
1965             primary->ref = substring;
1966           else
1967             tail->next = substring;
1968
1969           if (primary->expr_type == EXPR_CONSTANT)
1970             primary->expr_type = EXPR_SUBSTRING;
1971
1972           if (substring)
1973             primary->ts.u.cl = NULL;
1974
1975           break;
1976
1977         case MATCH_NO:
1978           if (unknown)
1979             {
1980               gfc_clear_ts (&primary->ts);
1981               gfc_clear_ts (&sym->ts);
1982             }
1983           break;
1984
1985         case MATCH_ERROR:
1986           return MATCH_ERROR;
1987         }
1988     }
1989
1990   /* F2008, C727.  */
1991   if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
1992     {
1993       gfc_error ("Coindexed procedure-pointer component at %C");
1994       return MATCH_ERROR;
1995     }
1996
1997   return MATCH_YES;
1998 }
1999
2000
2001 /* Given an expression that is a variable, figure out what the
2002    ultimate variable's type and attribute is, traversing the reference
2003    structures if necessary.
2004
2005    This subroutine is trickier than it looks.  We start at the base
2006    symbol and store the attribute.  Component references load a
2007    completely new attribute.
2008
2009    A couple of rules come into play.  Subobjects of targets are always
2010    targets themselves.  If we see a component that goes through a
2011    pointer, then the expression must also be a target, since the
2012    pointer is associated with something (if it isn't core will soon be
2013    dumped).  If we see a full part or section of an array, the
2014    expression is also an array.
2015
2016    We can have at most one full array reference.  */
2017
2018 symbol_attribute
2019 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
2020 {
2021   int dimension, pointer, allocatable, target;
2022   symbol_attribute attr;
2023   gfc_ref *ref;
2024   gfc_symbol *sym;
2025   gfc_component *comp;
2026
2027   if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
2028     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2029
2030   sym = expr->symtree->n.sym;
2031   attr = sym->attr;
2032
2033   if (sym->ts.type == BT_CLASS)
2034     {
2035       dimension = CLASS_DATA (sym)->attr.dimension;
2036       pointer = CLASS_DATA (sym)->attr.class_pointer;
2037       allocatable = CLASS_DATA (sym)->attr.allocatable;
2038     }
2039   else
2040     {
2041       dimension = attr.dimension;
2042       pointer = attr.pointer;
2043       allocatable = attr.allocatable;
2044     }
2045
2046   target = attr.target;
2047   if (pointer || attr.proc_pointer)
2048     target = 1;
2049
2050   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2051     *ts = sym->ts;
2052
2053   for (ref = expr->ref; ref; ref = ref->next)
2054     switch (ref->type)
2055       {
2056       case REF_ARRAY:
2057
2058         switch (ref->u.ar.type)
2059           {
2060           case AR_FULL:
2061             dimension = 1;
2062             break;
2063
2064           case AR_SECTION:
2065             allocatable = pointer = 0;
2066             dimension = 1;
2067             break;
2068
2069           case AR_ELEMENT:
2070             /* Handle coarrays.  */
2071             if (ref->u.ar.dimen > 0)
2072               allocatable = pointer = 0;
2073             break;
2074
2075           case AR_UNKNOWN:
2076             gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2077           }
2078
2079         break;
2080
2081       case REF_COMPONENT:
2082         comp = ref->u.c.component;
2083         attr = comp->attr;
2084         if (ts != NULL)
2085           {
2086             *ts = comp->ts;
2087             /* Don't set the string length if a substring reference
2088                follows.  */
2089             if (ts->type == BT_CHARACTER
2090                 && ref->next && ref->next->type == REF_SUBSTRING)
2091                 ts->u.cl = NULL;
2092           }
2093
2094         if (comp->ts.type == BT_CLASS)
2095           {
2096             pointer = CLASS_DATA (comp)->attr.class_pointer;
2097             allocatable = CLASS_DATA (comp)->attr.allocatable;
2098           }
2099         else
2100           {
2101             pointer = comp->attr.pointer;
2102             allocatable = comp->attr.allocatable;
2103           }
2104         if (pointer || attr.proc_pointer)
2105           target = 1;
2106
2107         break;
2108
2109       case REF_SUBSTRING:
2110         allocatable = pointer = 0;
2111         break;
2112       }
2113
2114   attr.dimension = dimension;
2115   attr.pointer = pointer;
2116   attr.allocatable = allocatable;
2117   attr.target = target;
2118   attr.save = sym->attr.save;
2119
2120   return attr;
2121 }
2122
2123
2124 /* Return the attribute from a general expression.  */
2125
2126 symbol_attribute
2127 gfc_expr_attr (gfc_expr *e)
2128 {
2129   symbol_attribute attr;
2130
2131   switch (e->expr_type)
2132     {
2133     case EXPR_VARIABLE:
2134       attr = gfc_variable_attr (e, NULL);
2135       break;
2136
2137     case EXPR_FUNCTION:
2138       gfc_clear_attr (&attr);
2139
2140       if (e->value.function.esym != NULL)
2141         {
2142           gfc_symbol *sym = e->value.function.esym->result;
2143           attr = sym->attr;
2144           if (sym->ts.type == BT_CLASS)
2145             {
2146               attr.dimension = CLASS_DATA (sym)->attr.dimension;
2147               attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
2148               attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
2149             }
2150         }
2151       else
2152         attr = gfc_variable_attr (e, NULL);
2153
2154       /* TODO: NULL() returns pointers.  May have to take care of this
2155          here.  */
2156
2157       break;
2158
2159     default:
2160       gfc_clear_attr (&attr);
2161       break;
2162     }
2163
2164   return attr;
2165 }
2166
2167
2168 /* Match a structure constructor.  The initial symbol has already been
2169    seen.  */
2170
2171 typedef struct gfc_structure_ctor_component
2172 {
2173   char* name;
2174   gfc_expr* val;
2175   locus where;
2176   struct gfc_structure_ctor_component* next;
2177 }
2178 gfc_structure_ctor_component;
2179
2180 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2181
2182 static void
2183 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
2184 {
2185   gfc_free (comp->name);
2186   gfc_free_expr (comp->val);
2187   gfc_free (comp);
2188 }
2189
2190
2191 /* Translate the component list into the actual constructor by sorting it in
2192    the order required; this also checks along the way that each and every
2193    component actually has an initializer and handles default initializers
2194    for components without explicit value given.  */
2195 static gfc_try
2196 build_actual_constructor (gfc_structure_ctor_component **comp_head,
2197                           gfc_constructor_base *ctor_head, gfc_symbol *sym)
2198 {
2199   gfc_structure_ctor_component *comp_iter;
2200   gfc_component *comp;
2201
2202   for (comp = sym->components; comp; comp = comp->next)
2203     {
2204       gfc_structure_ctor_component **next_ptr;
2205       gfc_expr *value = NULL;
2206
2207       /* Try to find the initializer for the current component by name.  */
2208       next_ptr = comp_head;
2209       for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
2210         {
2211           if (!strcmp (comp_iter->name, comp->name))
2212             break;
2213           next_ptr = &comp_iter->next;
2214         }
2215
2216       /* If an extension, try building the parent derived type by building
2217          a value expression for the parent derived type and calling self.  */
2218       if (!comp_iter && comp == sym->components && sym->attr.extension)
2219         {
2220           value = gfc_get_structure_constructor_expr (comp->ts.type,
2221                                                       comp->ts.kind,
2222                                                       &gfc_current_locus);
2223           value->ts = comp->ts;
2224
2225           if (build_actual_constructor (comp_head, &value->value.constructor,
2226                                         comp->ts.u.derived) == FAILURE)
2227             {
2228               gfc_free_expr (value);
2229               return FAILURE;
2230             }
2231
2232           gfc_constructor_append_expr (ctor_head, value, NULL);
2233           continue;
2234         }
2235
2236       /* If it was not found, try the default initializer if there's any;
2237          otherwise, it's an error.  */
2238       if (!comp_iter)
2239         {
2240           if (comp->initializer)
2241             {
2242               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2243                                   " constructor with missing optional arguments"
2244                                   " at %C") == FAILURE)
2245                 return FAILURE;
2246               value = gfc_copy_expr (comp->initializer);
2247             }
2248           else
2249             {
2250               gfc_error ("No initializer for component '%s' given in the"
2251                          " structure constructor at %C!", comp->name);
2252               return FAILURE;
2253             }
2254         }
2255       else
2256         value = comp_iter->val;
2257
2258       /* Add the value to the constructor chain built.  */
2259       gfc_constructor_append_expr (ctor_head, value, NULL);
2260
2261       /* Remove the entry from the component list.  We don't want the expression
2262          value to be free'd, so set it to NULL.  */
2263       if (comp_iter)
2264         {
2265           *next_ptr = comp_iter->next;
2266           comp_iter->val = NULL;
2267           gfc_free_structure_ctor_component (comp_iter);
2268         }
2269     }
2270   return SUCCESS;
2271 }
2272
2273 match
2274 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2275                                  bool parent)
2276 {
2277   gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2278   gfc_constructor_base ctor_head = NULL;
2279   gfc_component *comp; /* Is set NULL when named component is first seen */
2280   gfc_expr *e;
2281   locus where;
2282   match m;
2283   const char* last_name = NULL;
2284
2285   comp_tail = comp_head = NULL;
2286
2287   if (!parent && gfc_match_char ('(') != MATCH_YES)
2288     goto syntax;
2289
2290   where = gfc_current_locus;
2291
2292   gfc_find_component (sym, NULL, false, true);
2293
2294   /* Check that we're not about to construct an ABSTRACT type.  */
2295   if (!parent && sym->attr.abstract)
2296     {
2297       gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
2298       return MATCH_ERROR;
2299     }
2300
2301   /* Match the component list and store it in a list together with the
2302      corresponding component names.  Check for empty argument list first.  */
2303   if (gfc_match_char (')') != MATCH_YES)
2304     {
2305       comp = sym->components;
2306       do
2307         {
2308           gfc_component *this_comp = NULL;
2309
2310           if (!comp_head)
2311             comp_tail = comp_head = gfc_get_structure_ctor_component ();
2312           else
2313             {
2314               comp_tail->next = gfc_get_structure_ctor_component ();
2315               comp_tail = comp_tail->next;
2316             }
2317           comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
2318           comp_tail->val = NULL;
2319           comp_tail->where = gfc_current_locus;
2320
2321           /* Try matching a component name.  */
2322           if (gfc_match_name (comp_tail->name) == MATCH_YES
2323               && gfc_match_char ('=') == MATCH_YES)
2324             {
2325               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2326                                   " constructor with named arguments at %C")
2327                   == FAILURE)
2328                 goto cleanup;
2329
2330               last_name = comp_tail->name;
2331               comp = NULL;
2332             }
2333           else
2334             {
2335               /* Components without name are not allowed after the first named
2336                  component initializer!  */
2337               if (!comp)
2338                 {
2339                   if (last_name)
2340                     gfc_error ("Component initializer without name after"
2341                                " component named %s at %C!", last_name);
2342                   else if (!parent)
2343                     gfc_error ("Too many components in structure constructor at"
2344                                " %C!");
2345                   goto cleanup;
2346                 }
2347
2348               gfc_current_locus = comp_tail->where;
2349               strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
2350             }
2351
2352           /* Find the current component in the structure definition and check
2353              its access is not private.  */
2354           if (comp)
2355             this_comp = gfc_find_component (sym, comp->name, false, false);
2356           else
2357             {
2358               this_comp = gfc_find_component (sym,
2359                                               (const char *)comp_tail->name,
2360                                               false, false);
2361               comp = NULL; /* Reset needed!  */
2362             }
2363
2364           /* Here we can check if a component name is given which does not
2365              correspond to any component of the defined structure.  */
2366           if (!this_comp)
2367             goto cleanup;
2368
2369           /* Check if this component is already given a value.  */
2370           for (comp_iter = comp_head; comp_iter != comp_tail;
2371                comp_iter = comp_iter->next)
2372             {
2373               gcc_assert (comp_iter);
2374               if (!strcmp (comp_iter->name, comp_tail->name))
2375                 {
2376                   gfc_error ("Component '%s' is initialized twice in the"
2377                              " structure constructor at %C!", comp_tail->name);
2378                   goto cleanup;
2379                 }
2380             }
2381
2382           /* Match the current initializer expression.  */
2383           m = gfc_match_expr (&comp_tail->val);
2384           if (m == MATCH_NO)
2385             goto syntax;
2386           if (m == MATCH_ERROR)
2387             goto cleanup;
2388
2389           /* F2008, R457/C725, for PURE C1283.  */
2390           if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
2391             {
2392               gfc_error ("Coindexed expression to pointer component '%s' in "
2393                          "structure constructor at %C!", comp_tail->name);
2394               goto cleanup;
2395             }
2396
2397
2398           /* If not explicitly a parent constructor, gather up the components
2399              and build one.  */
2400           if (comp && comp == sym->components
2401                 && sym->attr.extension
2402                 && (comp_tail->val->ts.type != BT_DERIVED
2403                       ||
2404                     comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
2405             {
2406               gfc_current_locus = where;
2407               gfc_free_expr (comp_tail->val);
2408               comp_tail->val = NULL;
2409
2410               m = gfc_match_structure_constructor (comp->ts.u.derived,
2411                                                    &comp_tail->val, true);
2412               if (m == MATCH_NO)
2413                 goto syntax;
2414               if (m == MATCH_ERROR)
2415                 goto cleanup;
2416             }
2417
2418           if (comp)
2419             comp = comp->next;
2420
2421           if (parent && !comp)
2422             break;
2423         }
2424
2425       while (gfc_match_char (',') == MATCH_YES);
2426
2427       if (!parent && gfc_match_char (')') != MATCH_YES)
2428         goto syntax;
2429     }
2430
2431   if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2432     goto cleanup;
2433
2434   /* No component should be left, as this should have caused an error in the
2435      loop constructing the component-list (name that does not correspond to any
2436      component in the structure definition).  */
2437   if (comp_head)
2438     {
2439       gcc_assert (sym->attr.extension);
2440       for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2441         {
2442           gfc_error ("component '%s' at %L has already been set by a "
2443                      "parent derived type constructor", comp_iter->name,
2444                      &comp_iter->where);
2445         }
2446       goto cleanup;
2447     }
2448
2449   e = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &where);
2450   e->ts.u.derived = sym;
2451   e->value.constructor = ctor_head;
2452
2453   *result = e;
2454   return MATCH_YES;
2455
2456 syntax:
2457   gfc_error ("Syntax error in structure constructor at %C");
2458
2459 cleanup:
2460   for (comp_iter = comp_head; comp_iter; )
2461     {
2462       gfc_structure_ctor_component *next = comp_iter->next;
2463       gfc_free_structure_ctor_component (comp_iter);
2464       comp_iter = next;
2465     }
2466   gfc_constructor_free (ctor_head);
2467   return MATCH_ERROR;
2468 }
2469
2470
2471 /* If the symbol is an implicit do loop index and implicitly typed,
2472    it should not be host associated.  Provide a symtree from the
2473    current namespace.  */
2474 static match
2475 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2476 {
2477   if ((*sym)->attr.flavor == FL_VARIABLE
2478       && (*sym)->ns != gfc_current_ns
2479       && (*sym)->attr.implied_index
2480       && (*sym)->attr.implicit_type
2481       && !(*sym)->attr.use_assoc)
2482     {
2483       int i;
2484       i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
2485       if (i)
2486         return MATCH_ERROR;
2487       *sym = (*st)->n.sym;
2488     }
2489   return MATCH_YES;
2490 }
2491
2492
2493 /* Procedure pointer as function result: Replace the function symbol by the
2494    auto-generated hidden result variable named "ppr@".  */
2495
2496 static gfc_try
2497 replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
2498 {
2499   /* Check for procedure pointer result variable.  */
2500   if ((*sym)->attr.function && !(*sym)->attr.external
2501       && (*sym)->result && (*sym)->result != *sym
2502       && (*sym)->result->attr.proc_pointer
2503       && (*sym) == gfc_current_ns->proc_name
2504       && (*sym) == (*sym)->result->ns->proc_name
2505       && strcmp ("ppr@", (*sym)->result->name) == 0)
2506     {
2507       /* Automatic replacement with "hidden" result variable.  */
2508       (*sym)->result->attr.referenced = (*sym)->attr.referenced;
2509       *sym = (*sym)->result;
2510       *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
2511       return SUCCESS;
2512     }
2513   return FAILURE;
2514 }
2515
2516
2517 /* Matches a variable name followed by anything that might follow it--
2518    array reference, argument list of a function, etc.  */
2519
2520 match
2521 gfc_match_rvalue (gfc_expr **result)
2522 {
2523   gfc_actual_arglist *actual_arglist;
2524   char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2525   gfc_state_data *st;
2526   gfc_symbol *sym;
2527   gfc_symtree *symtree;
2528   locus where, old_loc;
2529   gfc_expr *e;
2530   match m, m2;
2531   int i;
2532   gfc_typespec *ts;
2533   bool implicit_char;
2534   gfc_ref *ref;
2535
2536   m = gfc_match_name (name);
2537   if (m != MATCH_YES)
2538     return m;
2539
2540   if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2541       && !gfc_current_ns->has_import_set)
2542     i = gfc_get_sym_tree (name, NULL, &symtree, false);
2543   else
2544     i = gfc_get_ha_sym_tree (name, &symtree);
2545
2546   if (i)
2547     return MATCH_ERROR;
2548
2549   sym = symtree->n.sym;
2550   e = NULL;
2551   where = gfc_current_locus;
2552
2553   replace_hidden_procptr_result (&sym, &symtree);
2554
2555   /* If this is an implicit do loop index and implicitly typed,
2556      it should not be host associated.  */
2557   m = check_for_implicit_index (&symtree, &sym);
2558   if (m != MATCH_YES)
2559     return m;
2560
2561   gfc_set_sym_referenced (sym);
2562   sym->attr.implied_index = 0;
2563
2564   if (sym->attr.function && sym->result == sym)
2565     {
2566       /* See if this is a directly recursive function call.  */
2567       gfc_gobble_whitespace ();
2568       if (sym->attr.recursive
2569           && gfc_peek_ascii_char () == '('
2570           && gfc_current_ns->proc_name == sym
2571           && !sym->attr.dimension)
2572         {
2573           gfc_error ("'%s' at %C is the name of a recursive function "
2574                      "and so refers to the result variable. Use an "
2575                      "explicit RESULT variable for direct recursion "
2576                      "(12.5.2.1)", sym->name);
2577           return MATCH_ERROR;
2578         }
2579
2580       if (gfc_is_function_return_value (sym, gfc_current_ns))
2581         goto variable;
2582
2583       if (sym->attr.entry
2584           && (sym->ns == gfc_current_ns
2585               || sym->ns == gfc_current_ns->parent))
2586         {
2587           gfc_entry_list *el = NULL;
2588
2589           for (el = sym->ns->entries; el; el = el->next)
2590             if (sym == el->sym)
2591               goto variable;
2592         }
2593     }
2594
2595   if (gfc_matching_procptr_assignment)
2596     goto procptr0;
2597
2598   if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2599     goto function0;
2600
2601   if (sym->attr.generic)
2602     goto generic_function;
2603
2604   switch (sym->attr.flavor)
2605     {
2606     case FL_VARIABLE:
2607     variable:
2608       e = gfc_get_expr ();
2609
2610       e->expr_type = EXPR_VARIABLE;
2611       e->symtree = symtree;
2612
2613       m = gfc_match_varspec (e, 0, false, true);
2614       break;
2615
2616     case FL_PARAMETER:
2617       /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2618          end up here.  Unfortunately, sym->value->expr_type is set to
2619          EXPR_CONSTANT, and so the if () branch would be followed without
2620          the !sym->as check.  */
2621       if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2622         e = gfc_copy_expr (sym->value);
2623       else
2624         {
2625           e = gfc_get_expr ();
2626           e->expr_type = EXPR_VARIABLE;
2627         }
2628
2629       e->symtree = symtree;
2630       m = gfc_match_varspec (e, 0, false, true);
2631
2632       if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2633         break;
2634
2635       /* Variable array references to derived type parameters cause
2636          all sorts of headaches in simplification. Treating such
2637          expressions as variable works just fine for all array
2638          references.  */
2639       if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2640         {
2641           for (ref = e->ref; ref; ref = ref->next)
2642             if (ref->type == REF_ARRAY)
2643               break;
2644
2645           if (ref == NULL || ref->u.ar.type == AR_FULL)
2646             break;
2647
2648           ref = e->ref;
2649           e->ref = NULL;
2650           gfc_free_expr (e);
2651           e = gfc_get_expr ();
2652           e->expr_type = EXPR_VARIABLE;
2653           e->symtree = symtree;
2654           e->ref = ref;
2655         }
2656
2657       break;
2658
2659     case FL_DERIVED:
2660       sym = gfc_use_derived (sym);
2661       if (sym == NULL)
2662         m = MATCH_ERROR;
2663       else
2664         m = gfc_match_structure_constructor (sym, &e, false);
2665       break;
2666
2667     /* If we're here, then the name is known to be the name of a
2668        procedure, yet it is not sure to be the name of a function.  */
2669     case FL_PROCEDURE:
2670
2671     /* Procedure Pointer Assignments. */
2672     procptr0:
2673       if (gfc_matching_procptr_assignment)
2674         {
2675           gfc_gobble_whitespace ();
2676           if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
2677             /* Parse functions returning a procptr.  */
2678             goto function0;
2679
2680           if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
2681               || gfc_is_intrinsic (sym, 1, gfc_current_locus))
2682             sym->attr.intrinsic = 1;
2683           e = gfc_get_expr ();
2684           e->expr_type = EXPR_VARIABLE;
2685           e->symtree = symtree;
2686           m = gfc_match_varspec (e, 0, false, true);
2687           break;
2688         }
2689
2690       if (sym->attr.subroutine)
2691         {
2692           gfc_error ("Unexpected use of subroutine name '%s' at %C",
2693                      sym->name);
2694           m = MATCH_ERROR;
2695           break;
2696         }
2697
2698       /* At this point, the name has to be a non-statement function.
2699          If the name is the same as the current function being
2700          compiled, then we have a variable reference (to the function
2701          result) if the name is non-recursive.  */
2702
2703       st = gfc_enclosing_unit (NULL);
2704
2705       if (st != NULL && st->state == COMP_FUNCTION
2706           && st->sym == sym
2707           && !sym->attr.recursive)
2708         {
2709           e = gfc_get_expr ();
2710           e->symtree = symtree;
2711           e->expr_type = EXPR_VARIABLE;
2712
2713           m = gfc_match_varspec (e, 0, false, true);
2714           break;
2715         }
2716
2717     /* Match a function reference.  */
2718     function0:
2719       m = gfc_match_actual_arglist (0, &actual_arglist);
2720       if (m == MATCH_NO)
2721         {
2722           if (sym->attr.proc == PROC_ST_FUNCTION)
2723             gfc_error ("Statement function '%s' requires argument list at %C",
2724                        sym->name);
2725           else
2726             gfc_error ("Function '%s' requires an argument list at %C",
2727                        sym->name);
2728
2729           m = MATCH_ERROR;
2730           break;
2731         }
2732
2733       if (m != MATCH_YES)
2734         {
2735           m = MATCH_ERROR;
2736           break;
2737         }
2738
2739       gfc_get_ha_sym_tree (name, &symtree);     /* Can't fail */
2740       sym = symtree->n.sym;
2741
2742       replace_hidden_procptr_result (&sym, &symtree);
2743
2744       e = gfc_get_expr ();
2745       e->symtree = symtree;
2746       e->expr_type = EXPR_FUNCTION;
2747       e->value.function.actual = actual_arglist;
2748       e->where = gfc_current_locus;
2749
2750       if (sym->as != NULL)
2751         e->rank = sym->as->rank;
2752
2753       if (!sym->attr.function
2754           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2755         {
2756           m = MATCH_ERROR;
2757           break;
2758         }
2759
2760       /* Check here for the existence of at least one argument for the
2761          iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED.  The
2762          argument(s) given will be checked in gfc_iso_c_func_interface,
2763          during resolution of the function call.  */
2764       if (sym->attr.is_iso_c == 1
2765           && (sym->from_intmod == INTMOD_ISO_C_BINDING
2766               && (sym->intmod_sym_id == ISOCBINDING_LOC
2767                   || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2768                   || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2769         {
2770           /* make sure we were given a param */
2771           if (actual_arglist == NULL)
2772             {
2773               gfc_error ("Missing argument to '%s' at %C", sym->name);
2774               m = MATCH_ERROR;
2775               break;
2776             }
2777         }
2778
2779       if (sym->result == NULL)
2780         sym->result = sym;
2781
2782       m = MATCH_YES;
2783       break;
2784
2785     case FL_UNKNOWN:
2786
2787       /* Special case for derived type variables that get their types
2788          via an IMPLICIT statement.  This can't wait for the
2789          resolution phase.  */
2790
2791       if (gfc_peek_ascii_char () == '%'
2792           && sym->ts.type == BT_UNKNOWN
2793           && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2794         gfc_set_default_type (sym, 0, sym->ns);
2795
2796       /* If the symbol has a dimension attribute, the expression is a
2797          variable.  */
2798
2799       if (sym->attr.dimension)
2800         {
2801           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2802                               sym->name, NULL) == FAILURE)
2803             {
2804               m = MATCH_ERROR;
2805               break;
2806             }
2807
2808           e = gfc_get_expr ();
2809           e->symtree = symtree;
2810           e->expr_type = EXPR_VARIABLE;
2811           m = gfc_match_varspec (e, 0, false, true);
2812           break;
2813         }
2814
2815       /* Name is not an array, so we peek to see if a '(' implies a
2816          function call or a substring reference.  Otherwise the
2817          variable is just a scalar.  */
2818
2819       gfc_gobble_whitespace ();
2820       if (gfc_peek_ascii_char () != '(')
2821         {
2822           /* Assume a scalar variable */
2823           e = gfc_get_expr ();
2824           e->symtree = symtree;
2825           e->expr_type = EXPR_VARIABLE;
2826
2827           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2828                               sym->name, NULL) == FAILURE)
2829             {
2830               m = MATCH_ERROR;
2831               break;
2832             }
2833
2834           /*FIXME:??? gfc_match_varspec does set this for us: */
2835           e->ts = sym->ts;
2836           m = gfc_match_varspec (e, 0, false, true);
2837           break;
2838         }
2839
2840       /* See if this is a function reference with a keyword argument
2841          as first argument. We do this because otherwise a spurious
2842          symbol would end up in the symbol table.  */
2843
2844       old_loc = gfc_current_locus;
2845       m2 = gfc_match (" ( %n =", argname);
2846       gfc_current_locus = old_loc;
2847
2848       e = gfc_get_expr ();
2849       e->symtree = symtree;
2850
2851       if (m2 != MATCH_YES)
2852         {
2853           /* Try to figure out whether we're dealing with a character type.
2854              We're peeking ahead here, because we don't want to call
2855              match_substring if we're dealing with an implicitly typed
2856              non-character variable.  */
2857           implicit_char = false;
2858           if (sym->ts.type == BT_UNKNOWN)
2859             {
2860               ts = gfc_get_default_type (sym->name, NULL);
2861               if (ts->type == BT_CHARACTER)
2862                 implicit_char = true;
2863             }
2864
2865           /* See if this could possibly be a substring reference of a name
2866              that we're not sure is a variable yet.  */
2867
2868           if ((implicit_char || sym->ts.type == BT_CHARACTER)
2869               && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
2870             {
2871
2872               e->expr_type = EXPR_VARIABLE;
2873
2874               if (sym->attr.flavor != FL_VARIABLE
2875                   && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2876                                      sym->name, NULL) == FAILURE)
2877                 {
2878                   m = MATCH_ERROR;
2879                   break;
2880                 }
2881
2882               if (sym->ts.type == BT_UNKNOWN
2883                   && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2884                 {
2885                   m = MATCH_ERROR;
2886                   break;
2887                 }
2888
2889               e->ts = sym->ts;
2890               if (e->ref)
2891                 e->ts.u.cl = NULL;
2892               m = MATCH_YES;
2893               break;
2894             }
2895         }
2896
2897       /* Give up, assume we have a function.  */
2898
2899       gfc_get_sym_tree (name, NULL, &symtree, false);   /* Can't fail */
2900       sym = symtree->n.sym;
2901       e->expr_type = EXPR_FUNCTION;
2902
2903       if (!sym->attr.function
2904           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2905         {
2906           m = MATCH_ERROR;
2907           break;
2908         }
2909
2910       sym->result = sym;
2911
2912       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2913       if (m == MATCH_NO)
2914         gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2915
2916       if (m != MATCH_YES)
2917         {
2918           m = MATCH_ERROR;
2919           break;
2920         }
2921
2922       /* If our new function returns a character, array or structure
2923          type, it might have subsequent references.  */
2924
2925       m = gfc_match_varspec (e, 0, false, true);
2926       if (m == MATCH_NO)
2927         m = MATCH_YES;
2928
2929       break;
2930
2931     generic_function:
2932       gfc_get_sym_tree (name, NULL, &symtree, false);   /* Can't fail */
2933
2934       e = gfc_get_expr ();
2935       e->symtree = symtree;
2936       e->expr_type = EXPR_FUNCTION;
2937
2938       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2939       break;
2940
2941     default:
2942       gfc_error ("Symbol at %C is not appropriate for an expression");
2943       return MATCH_ERROR;
2944     }
2945
2946   if (m == MATCH_YES)
2947     {
2948       e->where = where;
2949       *result = e;
2950     }
2951   else
2952     gfc_free_expr (e);
2953
2954   return m;
2955 }
2956
2957
2958 /* Match a variable, i.e. something that can be assigned to.  This
2959    starts as a symbol, can be a structure component or an array
2960    reference.  It can be a function if the function doesn't have a
2961    separate RESULT variable.  If the symbol has not been previously
2962    seen, we assume it is a variable.
2963
2964    This function is called by two interface functions:
2965    gfc_match_variable, which has host_flag = 1, and
2966    gfc_match_equiv_variable, with host_flag = 0, to restrict the
2967    match of the symbol to the local scope.  */
2968
2969 static match
2970 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2971 {
2972   gfc_symbol *sym;
2973   gfc_symtree *st;
2974   gfc_expr *expr;
2975   locus where;
2976   match m;
2977
2978   /* Since nothing has any business being an lvalue in a module
2979      specification block, an interface block or a contains section,
2980      we force the changed_symbols mechanism to work by setting
2981      host_flag to 0. This prevents valid symbols that have the name
2982      of keywords, such as 'end', being turned into variables by
2983      failed matching to assignments for, e.g., END INTERFACE.  */
2984   if (gfc_current_state () == COMP_MODULE
2985       || gfc_current_state () == COMP_INTERFACE
2986       || gfc_current_state () == COMP_CONTAINS)
2987     host_flag = 0;
2988
2989   where = gfc_current_locus;
2990   m = gfc_match_sym_tree (&st, host_flag);
2991   if (m != MATCH_YES)
2992     return m;
2993
2994   sym = st->n.sym;
2995
2996   /* If this is an implicit do loop index and implicitly typed,
2997      it should not be host associated.  */
2998   m = check_for_implicit_index (&st, &sym);
2999   if (m != MATCH_YES)
3000     return m;
3001
3002   sym->attr.implied_index = 0;
3003
3004   gfc_set_sym_referenced (sym);
3005   switch (sym->attr.flavor)
3006     {
3007     case FL_VARIABLE:
3008       /* Everything is alright.  */
3009       break;
3010
3011     case FL_UNKNOWN:
3012       {
3013         sym_flavor flavor = FL_UNKNOWN;
3014
3015         gfc_gobble_whitespace ();
3016
3017         if (sym->attr.external || sym->attr.procedure
3018             || sym->attr.function || sym->attr.subroutine)
3019           flavor = FL_PROCEDURE;
3020
3021         /* If it is not a procedure, is not typed and is host associated,
3022            we cannot give it a flavor yet.  */
3023         else if (sym->ns == gfc_current_ns->parent
3024                    && sym->ts.type == BT_UNKNOWN)
3025           break;
3026
3027         /* These are definitive indicators that this is a variable.  */
3028         else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
3029                  || sym->attr.pointer || sym->as != NULL)
3030           flavor = FL_VARIABLE;
3031
3032         if (flavor != FL_UNKNOWN
3033             && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
3034           return MATCH_ERROR;
3035       }
3036       break;
3037
3038     case FL_PARAMETER:
3039       if (equiv_flag)
3040         {
3041           gfc_error ("Named constant at %C in an EQUIVALENCE");
3042           return MATCH_ERROR;
3043         }
3044       /* Otherwise this is checked for and an error given in the
3045          variable definition context checks.  */
3046       break;
3047
3048     case FL_PROCEDURE:
3049       /* Check for a nonrecursive function result variable.  */
3050       if (sym->attr.function
3051           && !sym->attr.external
3052           && sym->result == sym
3053           && (gfc_is_function_return_value (sym, gfc_current_ns)
3054               || (sym->attr.entry
3055                   && sym->ns == gfc_current_ns)
3056               || (sym->attr.entry
3057                   && sym->ns == gfc_current_ns->parent)))
3058         {
3059           /* If a function result is a derived type, then the derived
3060              type may still have to be resolved.  */
3061
3062           if (sym->ts.type == BT_DERIVED
3063               && gfc_use_derived (sym->ts.u.derived) == NULL)
3064             return MATCH_ERROR;
3065           break;
3066         }
3067
3068       if (sym->attr.proc_pointer
3069           || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
3070         break;
3071
3072       /* Fall through to error */
3073
3074     default:
3075       gfc_error ("'%s' at %C is not a variable", sym->name);
3076       return MATCH_ERROR;
3077     }
3078
3079   /* Special case for derived type variables that get their types
3080      via an IMPLICIT statement.  This can't wait for the
3081      resolution phase.  */
3082
3083     {
3084       gfc_namespace * implicit_ns;
3085
3086       if (gfc_current_ns->proc_name == sym)
3087         implicit_ns = gfc_current_ns;
3088       else
3089         implicit_ns = sym->ns;
3090
3091       if (gfc_peek_ascii_char () == '%'
3092           && sym->ts.type == BT_UNKNOWN
3093           && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
3094         gfc_set_default_type (sym, 0, implicit_ns);
3095     }
3096
3097   expr = gfc_get_expr ();
3098
3099   expr->expr_type = EXPR_VARIABLE;
3100   expr->symtree = st;
3101   expr->ts = sym->ts;
3102   expr->where = where;
3103
3104   /* Now see if we have to do more.  */
3105   m = gfc_match_varspec (expr, equiv_flag, false, false);
3106   if (m != MATCH_YES)
3107     {
3108       gfc_free_expr (expr);
3109       return m;
3110     }
3111
3112   *result = expr;
3113   return MATCH_YES;
3114 }
3115
3116
3117 match
3118 gfc_match_variable (gfc_expr **result, int equiv_flag)
3119 {
3120   return match_variable (result, equiv_flag, 1);
3121 }
3122
3123
3124 match
3125 gfc_match_equiv_variable (gfc_expr **result)
3126 {
3127   return match_variable (result, 1, 0);
3128 }
3129