gcc/fortran/primary.c

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