gcc/fortran/primary.cc

/* Primary expression subroutines
   Copyright (C) 2000-2022 Free Software Foundation, Inc.
   Contributed by Andy Vaught

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3.  If not see
<http://www.gnu.org/licenses/>.  */

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "options.h"
#include "gfortran.h"
#include "arith.h"
#include "match.h"
#include "parse.h"
#include "constructor.h"

int matching_actual_arglist = 0;

/* Matches a kind-parameter expression, which is either a named
   symbolic constant or a nonnegative integer constant.  If
   successful, sets the kind value to the correct integer.
   The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
   symbol like e.g. 'c_int'.  */

static match
match_kind_param (int *kind, int *is_iso_c)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symbol *sym;
  match m;

  *is_iso_c = 0;

  m = gfc_match_small_literal_int (kind, NULL);
  if (m != MATCH_NO)
    return m;

  m = gfc_match_name (name);
  if (m != MATCH_YES)
    return m;

  if (gfc_find_symbol (name, NULL, 1, &sym))
    return MATCH_ERROR;

  if (sym == NULL)
    return MATCH_NO;

  *is_iso_c = sym->attr.is_iso_c;

  if (sym->attr.flavor != FL_PARAMETER)
    return MATCH_NO;

  if (sym->value == NULL)
    return MATCH_NO;

  if (gfc_extract_int (sym->value, kind))
    return MATCH_NO;

  gfc_set_sym_referenced (sym);

  if (*kind < 0)
    return MATCH_NO;

  return MATCH_YES;
}


/* Get a trailing kind-specification for non-character variables.
   Returns:
     * the integer kind value or
     * -1 if an error was generated,
     * -2 if no kind was found.
   The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
   symbol like e.g. 'c_int'.  */

static int
get_kind (int *is_iso_c)
{
  int kind;
  match m;

  *is_iso_c = 0;

  if (gfc_match_char ('_') != MATCH_YES)
    return -2;

  m = match_kind_param (&kind, is_iso_c);
  if (m == MATCH_NO)
    gfc_error ("Missing kind-parameter at %C");

  return (m == MATCH_YES) ? kind : -1;
}


/* Given a character and a radix, see if the character is a valid
   digit in that radix.  */

int
gfc_check_digit (char c, int radix)
{
  int r;

  switch (radix)
    {
    case 2:
      r = ('0' <= c && c <= '1');
      break;

    case 8:
      r = ('0' <= c && c <= '7');
      break;

    case 10:
      r = ('0' <= c && c <= '9');
      break;

    case 16:
      r = ISXDIGIT (c);
      break;

    default:
      gfc_internal_error ("gfc_check_digit(): bad radix");
    }

  return r;
}


/* Match the digit string part of an integer if signflag is not set,
   the signed digit string part if signflag is set.  If the buffer
   is NULL, we just count characters for the resolution pass.  Returns
   the number of characters matched, -1 for no match.  */

static int
match_digits (int signflag, int radix, char *buffer)
{
  locus old_loc;
  int length;
  char c;

  length = 0;
  c = gfc_next_ascii_char ();

  if (signflag && (c == '+' || c == '-'))
    {
      if (buffer != NULL)
	*buffer++ = c;
      gfc_gobble_whitespace ();
      c = gfc_next_ascii_char ();
      length++;
    }

  if (!gfc_check_digit (c, radix))
    return -1;

  length++;
  if (buffer != NULL)
    *buffer++ = c;

  for (;;)
    {
      old_loc = gfc_current_locus;
      c = gfc_next_ascii_char ();

      if (!gfc_check_digit (c, radix))
	break;

      if (buffer != NULL)
	*buffer++ = c;
      length++;
    }

  gfc_current_locus = old_loc;

  return length;
}

/* Convert an integer string to an expression node.  */

static gfc_expr *
convert_integer (const char *buffer, int kind, int radix, locus *where)
{
  gfc_expr *e;
  const char *t;

  e = gfc_get_constant_expr (BT_INTEGER, kind, where);
  /* A leading plus is allowed, but not by mpz_set_str.  */
  if (buffer[0] == '+')
    t = buffer + 1;
  else
    t = buffer;
  mpz_set_str (e->value.integer, t, radix);

  return e;
}


/* Convert a real string to an expression node.  */

static gfc_expr *
convert_real (const char *buffer, int kind, locus *where)
{
  gfc_expr *e;

  e = gfc_get_constant_expr (BT_REAL, kind, where);
  mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);

  return e;
}


/* Convert a pair of real, constant expression nodes to a single
   complex expression node.  */

static gfc_expr *
convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
{
  gfc_expr *e;

  e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where);
  mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
		 GFC_MPC_RND_MODE);

  return e;
}


/* Match an integer (digit string and optional kind).
   A sign will be accepted if signflag is set.  */

static match
match_integer_constant (gfc_expr **result, int signflag)
{
  int length, kind, is_iso_c;
  locus old_loc;
  char *buffer;
  gfc_expr *e;

  old_loc = gfc_current_locus;
  gfc_gobble_whitespace ();

  length = match_digits (signflag, 10, NULL);
  gfc_current_locus = old_loc;
  if (length == -1)
    return MATCH_NO;

  buffer = (char *) alloca (length + 1);
  memset (buffer, '\0', length + 1);

  gfc_gobble_whitespace ();

  match_digits (signflag, 10, buffer);

  kind = get_kind (&is_iso_c);
  if (kind == -2)
    kind = gfc_default_integer_kind;
  if (kind == -1)
    return MATCH_ERROR;

  if (kind == 4 && flag_integer4_kind == 8)
    kind = 8;

  if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
    {
      gfc_error ("Integer kind %d at %C not available", kind);
      return MATCH_ERROR;
    }

  e = convert_integer (buffer, kind, 10, &gfc_current_locus);
  e->ts.is_c_interop = is_iso_c;

  if (gfc_range_check (e) != ARITH_OK)
    {
      gfc_error ("Integer too big for its kind at %C. This check can be "
		 "disabled with the option %<-fno-range-check%>");

      gfc_free_expr (e);
      return MATCH_ERROR;
    }

  *result = e;
  return MATCH_YES;
}


/* Match a Hollerith constant.  */

static match
match_hollerith_constant (gfc_expr **result)
{
  locus old_loc;
  gfc_expr *e = NULL;
  int num, pad;
  int i;

  old_loc = gfc_current_locus;
  gfc_gobble_whitespace ();

  if (match_integer_constant (&e, 0) == MATCH_YES
      && gfc_match_char ('h') == MATCH_YES)
    {
      if (!gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant at %C"))
	goto cleanup;

      if (gfc_extract_int (e, &num, 1))
	goto cleanup;
      if (num == 0)
	{
	  gfc_error ("Invalid Hollerith constant: %L must contain at least "
		     "one character", &old_loc);
	  goto cleanup;
	}
      if (e->ts.kind != gfc_default_integer_kind)
	{
	  gfc_error ("Invalid Hollerith constant: Integer kind at %L "
		     "should be default", &old_loc);
	  goto cleanup;
	}
      else
	{
	  gfc_free_expr (e);
	  e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
				     &gfc_current_locus);

	  /* Calculate padding needed to fit default integer memory.  */
	  pad = gfc_default_integer_kind - (num % gfc_default_integer_kind);

	  e->representation.string = XCNEWVEC (char, num + pad + 1);

	  for (i = 0; i < num; i++)
	    {
	      gfc_char_t c = gfc_next_char_literal (INSTRING_WARN);
	      if (! gfc_wide_fits_in_byte (c))
		{
		  gfc_error ("Invalid Hollerith constant at %L contains a "
			     "wide character", &old_loc);
		  goto cleanup;
		}

	      e->representation.string[i] = (unsigned char) c;
	    }

	  /* Now pad with blanks and end with a null char.  */
	  for (i = 0; i < pad; i++)
	    e->representation.string[num + i] = ' ';

	  e->representation.string[num + i] = '\0';
	  e->representation.length = num + pad;
	  e->ts.u.pad = pad;

	  *result = e;
	  return MATCH_YES;
	}
    }

  gfc_free_expr (e);
  gfc_current_locus = old_loc;
  return MATCH_NO;

cleanup:
  gfc_free_expr (e);
  return MATCH_ERROR;
}


/* Match a binary, octal or hexadecimal constant that can be found in
   a DATA statement.  The standard permits b'010...', o'73...', and
   z'a1...' where b, o, and z can be capital letters.  This function
   also accepts postfixed forms of the constants: '01...'b, '73...'o,
   and 'a1...'z.  An additional extension is the use of x for z.  */

static match
match_boz_constant (gfc_expr **result)
{
  int radix, length, x_hex;
  locus old_loc, start_loc;
  char *buffer, post, delim;
  gfc_expr *e;

  start_loc = old_loc = gfc_current_locus;
  gfc_gobble_whitespace ();

  x_hex = 0;
  switch (post = gfc_next_ascii_char ())
    {
    case 'b':
      radix = 2;
      post = 0;
      break;
    case 'o':
      radix = 8;
      post = 0;
      break;
    case 'x':
      x_hex = 1;
      /* Fall through.  */
    case 'z':
      radix = 16;
      post = 0;
      break;
    case '\'':
      /* Fall through.  */
    case '\"':
      delim = post;
      post = 1;
      radix = 16;  /* Set to accept any valid digit string.  */
      break;
    default:
      goto backup;
    }

  /* No whitespace allowed here.  */

  if (post == 0)
    delim = gfc_next_ascii_char ();

  if (delim != '\'' && delim != '\"')
    goto backup;

  if (x_hex
      && gfc_invalid_boz (G_("Hexadecimal constant at %L uses "
			  "nonstandard X instead of Z"), &gfc_current_locus))
    return MATCH_ERROR;

  old_loc = gfc_current_locus;

  length = match_digits (0, radix, NULL);
  if (length == -1)
    {
      gfc_error ("Empty set of digits in BOZ constant at %C");
      return MATCH_ERROR;
    }

  if (gfc_next_ascii_char () != delim)
    {
      gfc_error ("Illegal character in BOZ constant at %C");
      return MATCH_ERROR;
    }

  if (post == 1)
    {
      switch (gfc_next_ascii_char ())
	{
	case 'b':
	  radix = 2;
	  break;
	case 'o':
	  radix = 8;
	  break;
	case 'x':
	  /* Fall through.  */
	case 'z':
	  radix = 16;
	  break;
	default:
	  goto backup;
	}

      if (gfc_invalid_boz (G_("BOZ constant at %C uses nonstandard postfix "
			   "syntax"), &gfc_current_locus))
	return MATCH_ERROR;
    }

  gfc_current_locus = old_loc;

  buffer = (char *) alloca (length + 1);
  memset (buffer, '\0', length + 1);

  match_digits (0, radix, buffer);
  gfc_next_ascii_char ();    /* Eat delimiter.  */
  if (post == 1)
    gfc_next_ascii_char ();  /* Eat postfixed b, o, z, or x.  */

  e = gfc_get_expr ();
  e->expr_type = EXPR_CONSTANT;
  e->ts.type = BT_BOZ;
  e->where = gfc_current_locus;
  e->boz.rdx = radix;
  e->boz.len = length;
  e->boz.str = XCNEWVEC (char, length + 1);
  strncpy (e->boz.str, buffer, length);

  if (!gfc_in_match_data ()
      && (!gfc_notify_std(GFC_STD_F2003, "BOZ used outside a DATA "
			  "statement at %L", &e->where)))
    return MATCH_ERROR;

  *result = e;
  return MATCH_YES;

backup:
  gfc_current_locus = start_loc;
  return MATCH_NO;
}


/* Match a real constant of some sort.  Allow a signed constant if signflag
   is nonzero.  */

static match
match_real_constant (gfc_expr **result, int signflag)
{
  int kind, count, seen_dp, seen_digits, is_iso_c, default_exponent;
  locus old_loc, temp_loc;
  char *p, *buffer, c, exp_char;
  gfc_expr *e;
  bool negate;

  old_loc = gfc_current_locus;
  gfc_gobble_whitespace ();

  e = NULL;

  default_exponent = 0;
  count = 0;
  seen_dp = 0;
  seen_digits = 0;
  exp_char = ' ';
  negate = FALSE;

  c = gfc_next_ascii_char ();
  if (signflag && (c == '+' || c == '-'))
    {
      if (c == '-')
	negate = TRUE;

      gfc_gobble_whitespace ();
      c = gfc_next_ascii_char ();
    }

  /* Scan significand.  */
  for (;; c = gfc_next_ascii_char (), count++)
    {
      if (c == '.')
	{
	  if (seen_dp)
	    goto done;

	  /* Check to see if "." goes with a following operator like
	     ".eq.".  */
	  temp_loc = gfc_current_locus;
	  c = gfc_next_ascii_char ();

	  if (c == 'e' || c == 'd' || c == 'q')
	    {
	      c = gfc_next_ascii_char ();
	      if (c == '.')
		goto done;	/* Operator named .e. or .d.  */
	    }

	  if (ISALPHA (c))
	    goto done;		/* Distinguish 1.e9 from 1.eq.2 */

	  gfc_current_locus = temp_loc;
	  seen_dp = 1;
	  continue;
	}

      if (ISDIGIT (c))
	{
	  seen_digits = 1;
	  continue;
	}

      break;
    }

  if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
    goto done;
  exp_char = c;


  if (c == 'q')
    {
      if (!gfc_notify_std (GFC_STD_GNU, "exponent-letter 'q' in "
			   "real-literal-constant at %C"))
	return MATCH_ERROR;
      else if (warn_real_q_constant)
	gfc_warning (OPT_Wreal_q_constant,
		     "Extension: exponent-letter %<q%> in real-literal-constant "
		     "at %C");
    }

  /* Scan exponent.  */
  c = gfc_next_ascii_char ();
  count++;

  if (c == '+' || c == '-')
    {				/* optional sign */
      c = gfc_next_ascii_char ();
      count++;
    }

  if (!ISDIGIT (c))
    {
      /* With -fdec, default exponent to 0 instead of complaining.  */
      if (flag_dec)
	default_exponent = 1;
      else
	{
	  gfc_error ("Missing exponent in real number at %C");
	  return MATCH_ERROR;
	}
    }

  while (ISDIGIT (c))
    {
      c = gfc_next_ascii_char ();
      count++;
    }

done:
  /* Check that we have a numeric constant.  */
  if (!seen_digits || (!seen_dp && exp_char == ' '))
    {
      gfc_current_locus = old_loc;
      return MATCH_NO;
    }

  /* Convert the number.  */
  gfc_current_locus = old_loc;
  gfc_gobble_whitespace ();

  buffer = (char *) alloca (count + default_exponent + 1);
  memset (buffer, '\0', count + default_exponent + 1);

  p = buffer;
  c = gfc_next_ascii_char ();
  if (c == '+' || c == '-')
    {
      gfc_gobble_whitespace ();
      c = gfc_next_ascii_char ();
    }

  /* Hack for mpfr_set_str().  */
  for (;;)
    {
      if (c == 'd' || c == 'q')
	*p = 'e';
      else
	*p = c;
      p++;
      if (--count == 0)
	break;

      c = gfc_next_ascii_char ();
    }
  if (default_exponent)
    *p++ = '0';

  kind = get_kind (&is_iso_c);
  if (kind == -1)
    goto cleanup;

  if (kind == 4)
    {
      if (flag_real4_kind == 8)
	kind = 8;
      if (flag_real4_kind == 10)
	kind = 10;
      if (flag_real4_kind == 16)
	kind = 16;
    }
  else if (kind == 8)
    {
      if (flag_real8_kind == 4)
	kind = 4;
      if (flag_real8_kind == 10)
	kind = 10;
      if (flag_real8_kind == 16)
	kind = 16;
    }

  switch (exp_char)
    {
    case 'd':
      if (kind != -2)
	{
	  gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
		     "kind");
	  goto cleanup;
	}
      kind = gfc_default_double_kind;
      break;

    case 'q':
      if (kind != -2)
	{
	  gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
		     "kind");
	  goto cleanup;
	}

      /* The maximum possible real kind type parameter is 16.  First, try
	 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
	 extended precision.  If neither value works, just given up.  */
      kind = 16;
      if (gfc_validate_kind (BT_REAL, kind, true) < 0)
	{
	  kind = 10;
          if (gfc_validate_kind (BT_REAL, kind, true) < 0)
	    {
	      gfc_error ("Invalid exponent-letter %<q%> in "
			 "real-literal-constant at %C");
	      goto cleanup;
	    }
	}
      break;

    default:
      if (kind == -2)
	kind = gfc_default_real_kind;

      if (gfc_validate_kind (BT_REAL, kind, true) < 0)
	{
	  gfc_error ("Invalid real kind %d at %C", kind);
	  goto cleanup;
	}
    }

  e = convert_real (buffer, kind, &gfc_current_locus);
  if (negate)
    mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
  e->ts.is_c_interop = is_iso_c;

  switch (gfc_range_check (e))
    {
    case ARITH_OK:
      break;
    case ARITH_OVERFLOW:
      gfc_error ("Real constant overflows its kind at %C");
      goto cleanup;

    case ARITH_UNDERFLOW:
      if (warn_underflow)
	gfc_warning (OPT_Wunderflow, "Real constant underflows its kind at %C");
      mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
      break;

    default:
      gfc_internal_error ("gfc_range_check() returned bad value");
    }

  /* Warn about trailing digits which suggest the user added too many
     trailing digits, which may cause the appearance of higher pecision
     than the kind kan support.

     This is done by replacing the rightmost non-zero digit with zero
     and comparing with the original value.  If these are equal, we
     assume the user supplied more digits than intended (or forgot to
     convert to the correct kind).
  */

  if (warn_conversion_extra)
    {
      mpfr_t r;
      char *c1;
      bool did_break;

      c1 = strchr (buffer, 'e');
      if (c1 == NULL)
	c1 = buffer + strlen(buffer);

      did_break = false;
      for (p = c1; p > buffer;)
	{
	  p--;
	  if (*p == '.')
	    continue;

	  if (*p != '0')
	    {
	      *p = '0';
	      did_break = true;
	      break;
	    }
	}

      if (did_break)
	{
	  mpfr_init (r);
	  mpfr_set_str (r, buffer, 10, GFC_RND_MODE);
	  if (negate)
	    mpfr_neg (r, r, GFC_RND_MODE);

	  mpfr_sub (r, r, e->value.real, GFC_RND_MODE);

	  if (mpfr_cmp_ui (r, 0) == 0)
	    gfc_warning (OPT_Wconversion_extra, "Non-significant digits "
			 "in %qs number at %C, maybe incorrect KIND",
			 gfc_typename (&e->ts));

	  mpfr_clear (r);
	}
    }

  *result = e;
  return MATCH_YES;

cleanup:
  gfc_free_expr (e);
  return MATCH_ERROR;
}


/* Match a substring reference.  */

static match
match_substring (gfc_charlen *cl, int init, gfc_ref **result, bool deferred)
{
  gfc_expr *start, *end;
  locus old_loc;
  gfc_ref *ref;
  match m;

  start = NULL;
  end = NULL;

  old_loc = gfc_current_locus;

  m = gfc_match_char ('(');
  if (m != MATCH_YES)
    return MATCH_NO;

  if (gfc_match_char (':') != MATCH_YES)
    {
      if (init)
	m = gfc_match_init_expr (&start);
      else
	m = gfc_match_expr (&start);

      if (m != MATCH_YES)
	{
	  m = MATCH_NO;
	  goto cleanup;
	}

      m = gfc_match_char (':');
      if (m != MATCH_YES)
	goto cleanup;
    }

  if (gfc_match_char (')') != MATCH_YES)
    {
      if (init)
	m = gfc_match_init_expr (&end);
      else
	m = gfc_match_expr (&end);

      if (m == MATCH_NO)
	goto syntax;
      if (m == MATCH_ERROR)
	goto cleanup;

      m = gfc_match_char (')');
      if (m == MATCH_NO)
	goto syntax;
    }

  /* Optimize away the (:) reference.  */
  if (start == NULL && end == NULL && !deferred)
    ref = NULL;
  else
    {
      ref = gfc_get_ref ();

      ref->type = REF_SUBSTRING;
      if (start == NULL)
	start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
      ref->u.ss.start = start;
      if (end == NULL && cl)
	end = gfc_copy_expr (cl->length);
      ref->u.ss.end = end;
      ref->u.ss.length = cl;
    }

  *result = ref;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in SUBSTRING specification at %C");
  m = MATCH_ERROR;

cleanup:
  gfc_free_expr (start);
  gfc_free_expr (end);

  gfc_current_locus = old_loc;
  return m;
}


/* Reads the next character of a string constant, taking care to
   return doubled delimiters on the input as a single instance of
   the delimiter.

   Special return values for "ret" argument are:
     -1   End of the string, as determined by the delimiter
     -2   Unterminated string detected

   Backslash codes are also expanded at this time.  */

static gfc_char_t
next_string_char (gfc_char_t delimiter, int *ret)
{
  locus old_locus;
  gfc_char_t c;

  c = gfc_next_char_literal (INSTRING_WARN);
  *ret = 0;

  if (c == '\n')
    {
      *ret = -2;
      return 0;
    }

  if (flag_backslash && c == '\\')
    {
      old_locus = gfc_current_locus;

      if (gfc_match_special_char (&c) == MATCH_NO)
	gfc_current_locus = old_locus;

      if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
	gfc_warning (0, "Extension: backslash character at %C");
    }

  if (c != delimiter)
    return c;

  old_locus = gfc_current_locus;
  c = gfc_next_char_literal (NONSTRING);

  if (c == delimiter)
    return c;
  gfc_current_locus = old_locus;

  *ret = -1;
  return 0;
}


/* Special case of gfc_match_name() that matches a parameter kind name
   before a string constant.  This takes case of the weird but legal
   case of:

     kind_____'string'

   where kind____ is a parameter. gfc_match_name() will happily slurp
   up all the underscores, which leads to problems.  If we return
   MATCH_YES, the parse pointer points to the final underscore, which
   is not part of the name.  We never return MATCH_ERROR-- errors in
   the name will be detected later.  */

static match
match_charkind_name (char *name)
{
  locus old_loc;
  char c, peek;
  int len;

  gfc_gobble_whitespace ();
  c = gfc_next_ascii_char ();
  if (!ISALPHA (c))
    return MATCH_NO;

  *name++ = c;
  len = 1;

  for (;;)
    {
      old_loc = gfc_current_locus;
      c = gfc_next_ascii_char ();

      if (c == '_')
	{
	  peek = gfc_peek_ascii_char ();

	  if (peek == '\'' || peek == '\"')
	    {
	      gfc_current_locus = old_loc;
	      *name = '\0';
	      return MATCH_YES;
	    }
	}

      if (!ISALNUM (c)
	  && c != '_'
	  && (c != '$' || !flag_dollar_ok))
	break;

      *name++ = c;
      if (++len > GFC_MAX_SYMBOL_LEN)
	break;
    }

  return MATCH_NO;
}


/* See if the current input matches a character constant.  Lots of
   contortions have to be done to match the kind parameter which comes
   before the actual string.  The main consideration is that we don't
   want to error out too quickly.  For example, we don't actually do
   any validation of the kinds until we have actually seen a legal
   delimiter.  Using match_kind_param() generates errors too quickly.  */

static match
match_string_constant (gfc_expr **result)
{
  char name[GFC_MAX_SYMBOL_LEN + 1], peek;
  size_t length;
  int kind,save_warn_ampersand, ret;
  locus old_locus, start_locus;
  gfc_symbol *sym;
  gfc_expr *e;
  match m;
  gfc_char_t c, delimiter, *p;

  old_locus = gfc_current_locus;

  gfc_gobble_whitespace ();

  c = gfc_next_char ();
  if (c == '\'' || c == '"')
    {
      kind = gfc_default_character_kind;
      start_locus = gfc_current_locus;
      goto got_delim;
    }

  if (gfc_wide_is_digit (c))
    {
      kind = 0;

      while (gfc_wide_is_digit (c))
	{
	  kind = kind * 10 + c - '0';
	  if (kind > 9999999)
	    goto no_match;
	  c = gfc_next_char ();
	}

    }
  else
    {
      gfc_current_locus = old_locus;

      m = match_charkind_name (name);
      if (m != MATCH_YES)
	goto no_match;

      if (gfc_find_symbol (name, NULL, 1, &sym)
	  || sym == NULL
	  || sym->attr.flavor != FL_PARAMETER)
	goto no_match;

      kind = -1;
      c = gfc_next_char ();
    }

  if (c == ' ')
    {
      gfc_gobble_whitespace ();
      c = gfc_next_char ();
    }

  if (c != '_')
    goto no_match;

  gfc_gobble_whitespace ();

  c = gfc_next_char ();
  if (c != '\'' && c != '"')
    goto no_match;

  start_locus = gfc_current_locus;

  if (kind == -1)
    {
      if (gfc_extract_int (sym->value, &kind, 1))
	return MATCH_ERROR;
      gfc_set_sym_referenced (sym);
    }

  if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
    {
      gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
      return MATCH_ERROR;
    }

got_delim:
  /* Scan the string into a block of memory by first figuring out how
     long it is, allocating the structure, then re-reading it.  This
     isn't particularly efficient, but string constants aren't that
     common in most code.  TODO: Use obstacks?  */

  delimiter = c;
  length = 0;

  for (;;)
    {
      c = next_string_char (delimiter, &ret);
      if (ret == -1)
	break;
      if (ret == -2)
	{
	  gfc_current_locus = start_locus;
	  gfc_error ("Unterminated character constant beginning at %C");
	  return MATCH_ERROR;
	}

      length++;
    }

  /* Peek at the next character to see if it is a b, o, z, or x for the
     postfixed BOZ literal constants.  */
  peek = gfc_peek_ascii_char ();
  if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
    goto no_match;

  e = gfc_get_character_expr (kind, &start_locus, NULL, length);

  gfc_current_locus = start_locus;

  /* We disable the warning for the following loop as the warning has already
     been printed in the loop above.  */
  save_warn_ampersand = warn_ampersand;
  warn_ampersand = false;

  p = e->value.character.string;
  for (size_t i = 0; i < length; i++)
    {
      c = next_string_char (delimiter, &ret);

      if (!gfc_check_character_range (c, kind))
	{
	  gfc_free_expr (e);
	  gfc_error ("Character %qs in string at %C is not representable "
		     "in character kind %d", gfc_print_wide_char (c), kind);
	  return MATCH_ERROR;
	}

      *p++ = c;
    }

  *p = '\0';	/* TODO: C-style string is for development/debug purposes.  */
  warn_ampersand = save_warn_ampersand;

  next_string_char (delimiter, &ret);
  if (ret != -1)
    gfc_internal_error ("match_string_constant(): Delimiter not found");

  if (match_substring (NULL, 0, &e->ref, false) != MATCH_NO)
    e->expr_type = EXPR_SUBSTRING;

  /* Substrings with constant starting and ending points are eligible as
     designators (F2018, section 9.1).  Simplify substrings to make them usable
     e.g. in data statements.  */
  if (e->expr_type == EXPR_SUBSTRING
      && e->ref && e->ref->type == REF_SUBSTRING
      && e->ref->u.ss.start->expr_type == EXPR_CONSTANT
      && (e->ref->u.ss.end == NULL
	  || e->ref->u.ss.end->expr_type == EXPR_CONSTANT))
    {
      gfc_expr *res;
      ptrdiff_t istart, iend;
      size_t length;
      bool equal_length = false;

      /* Basic checks on substring starting and ending indices.  */
      if (!gfc_resolve_substring (e->ref, &equal_length))
	return MATCH_ERROR;

      length = e->value.character.length;
      istart = gfc_mpz_get_hwi (e->ref->u.ss.start->value.integer);
      if (e->ref->u.ss.end == NULL)
	iend = length;
      else
	iend = gfc_mpz_get_hwi (e->ref->u.ss.end->value.integer);

      if (istart <= iend)
	{
	  if (istart < 1)
	    {
	      gfc_error ("Substring start index (%ld) at %L below 1",
			 (long) istart, &e->ref->u.ss.start->where);
	      return MATCH_ERROR;
	    }
	  if (iend > (ssize_t) length)
	    {
	      gfc_error ("Substring end index (%ld) at %L exceeds string "
			 "length", (long) iend, &e->ref->u.ss.end->where);
	      return MATCH_ERROR;
	    }
	  length = iend - istart + 1;
	}
      else
	length = 0;

      res = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
      res->value.character.string = gfc_get_wide_string (length + 1);
      res->value.character.length = length;
      if (length > 0)
	memcpy (res->value.character.string,
		&e->value.character.string[istart - 1],
		length * sizeof (gfc_char_t));
      res->value.character.string[length] = '\0';
      e = res;
    }

  *result = e;

  return MATCH_YES;

no_match:
  gfc_current_locus = old_locus;
  return MATCH_NO;
}


/* Match a .true. or .false.  Returns 1 if a .true. was found,
   0 if a .false. was found, and -1 otherwise.  */
static int
match_logical_constant_string (void)
{
  locus orig_loc = gfc_current_locus;

  gfc_gobble_whitespace ();
  if (gfc_next_ascii_char () == '.')
    {
      char ch = gfc_next_ascii_char ();
      if (ch == 'f')
	{
	  if (gfc_next_ascii_char () == 'a'
	      && gfc_next_ascii_char () == 'l'
	      && gfc_next_ascii_char () == 's'
	      && gfc_next_ascii_char () == 'e'
	      && gfc_next_ascii_char () == '.')
	    /* Matched ".false.".  */
	    return 0;
	}
      else if (ch == 't')
	{
	  if (gfc_next_ascii_char () == 'r'
	      && gfc_next_ascii_char () == 'u'
	      && gfc_next_ascii_char () == 'e'
	      && gfc_next_ascii_char () == '.')
	    /* Matched ".true.".  */
	    return 1;
	}
    }
  gfc_current_locus = orig_loc;
  return -1;
}

/* Match a .true. or .false.  */

static match
match_logical_constant (gfc_expr **result)
{
  gfc_expr *e;
  int i, kind, is_iso_c;

  i = match_logical_constant_string ();
  if (i == -1)
    return MATCH_NO;

  kind = get_kind (&is_iso_c);
  if (kind == -1)
    return MATCH_ERROR;
  if (kind == -2)
    kind = gfc_default_logical_kind;

  if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
    {
      gfc_error ("Bad kind for logical constant at %C");
      return MATCH_ERROR;
    }

  e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
  e->ts.is_c_interop = is_iso_c;

  *result = e;
  return MATCH_YES;
}


/* Match a real or imaginary part of a complex constant that is a
   symbolic constant.  */

static match
match_sym_complex_part (gfc_expr **result)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symbol *sym;
  gfc_expr *e;
  match m;

  m = gfc_match_name (name);
  if (m != MATCH_YES)
    return m;

  if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
    return MATCH_NO;

  if (sym->attr.flavor != FL_PARAMETER)
    {
      /* Give the matcher for implied do-loops a chance to run.  This yields
	 a much saner error message for "write(*,*) (i, i=1, 6" where the
	 right parenthesis is missing.  */
      char c;
      gfc_gobble_whitespace ();
      c = gfc_peek_ascii_char ();
      if (c == '=' || c == ',')
	{
	  m = MATCH_NO;
	}
      else
	{
	  gfc_error ("Expected PARAMETER symbol in complex constant at %C");
	  m = MATCH_ERROR;
	}
      return m;
    }

  if (!sym->value)
    goto error;

  if (!gfc_numeric_ts (&sym->value->ts))
    {
      gfc_error ("Numeric PARAMETER required in complex constant at %C");
      return MATCH_ERROR;
    }

  if (sym->value->rank != 0)
    {
      gfc_error ("Scalar PARAMETER required in complex constant at %C");
      return MATCH_ERROR;
    }

  if (!gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in "
		       "complex constant at %C"))
    return MATCH_ERROR;

  switch (sym->value->ts.type)
    {
    case BT_REAL:
      e = gfc_copy_expr (sym->value);
      break;

    case BT_COMPLEX:
      e = gfc_complex2real (sym->value, sym->value->ts.kind);
      if (e == NULL)
	goto error;
      break;

    case BT_INTEGER:
      e = gfc_int2real (sym->value, gfc_default_real_kind);
      if (e == NULL)
	goto error;
      break;

    default:
      gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
    }

  *result = e;		/* e is a scalar, real, constant expression.  */
  return MATCH_YES;

error:
  gfc_error ("Error converting PARAMETER constant in complex constant at %C");
  return MATCH_ERROR;
}


/* Match a real or imaginary part of a complex number.  */

static match
match_complex_part (gfc_expr **result)
{
  match m;

  m = match_sym_complex_part (result);
  if (m != MATCH_NO)
    return m;

  m = match_real_constant (result, 1);
  if (m != MATCH_NO)
    return m;

  return match_integer_constant (result, 1);
}


/* Try to match a complex constant.  */

static match
match_complex_constant (gfc_expr **result)
{
  gfc_expr *e, *real, *imag;
  gfc_error_buffer old_error;
  gfc_typespec target;
  locus old_loc;
  int kind;
  match m;

  old_loc = gfc_current_locus;
  real = imag = e = NULL;

  m = gfc_match_char ('(');
  if (m != MATCH_YES)
    return m;

  gfc_push_error (&old_error);

  m = match_complex_part (&real);
  if (m == MATCH_NO)
    {
      gfc_free_error (&old_error);
      goto cleanup;
    }

  if (gfc_match_char (',') == MATCH_NO)
    {
      /* It is possible that gfc_int2real issued a warning when
	 converting an integer to real.  Throw this away here.  */

      gfc_clear_warning ();
      gfc_pop_error (&old_error);
      m = MATCH_NO;
      goto cleanup;
    }

  /* If m is error, then something was wrong with the real part and we
     assume we have a complex constant because we've seen the ','.  An
     ambiguous case here is the start of an iterator list of some
     sort. These sort of lists are matched prior to coming here.  */

  if (m == MATCH_ERROR)
    {
      gfc_free_error (&old_error);
      goto cleanup;
    }
  gfc_pop_error (&old_error);

  m = match_complex_part (&imag);
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto cleanup;

  m = gfc_match_char (')');
  if (m == MATCH_NO)
    {
      /* Give the matcher for implied do-loops a chance to run.  This
	 yields a much saner error message for (/ (i, 4=i, 6) /).  */
      if (gfc_peek_ascii_char () == '=')
	{
	  m = MATCH_ERROR;
	  goto cleanup;
	}
      else
    goto syntax;
    }

  if (m == MATCH_ERROR)
    goto cleanup;

  /* Decide on the kind of this complex number.  */
  if (real->ts.type == BT_REAL)
    {
      if (imag->ts.type == BT_REAL)
	kind = gfc_kind_max (real, imag);
      else
	kind = real->ts.kind;
    }
  else
    {
      if (imag->ts.type == BT_REAL)
	kind = imag->ts.kind;
      else
	kind = gfc_default_real_kind;
    }
  gfc_clear_ts (&target);
  target.type = BT_REAL;
  target.kind = kind;

  if (real->ts.type != BT_REAL || kind != real->ts.kind)
    gfc_convert_type (real, &target, 2);
  if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
    gfc_convert_type (imag, &target, 2);

  e = convert_complex (real, imag, kind);
  e->where = gfc_current_locus;

  gfc_free_expr (real);
  gfc_free_expr (imag);

  *result = e;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in COMPLEX constant at %C");
  m = MATCH_ERROR;

cleanup:
  gfc_free_expr (e);
  gfc_free_expr (real);
  gfc_free_expr (imag);
  gfc_current_locus = old_loc;

  return m;
}


/* Match constants in any of several forms.  Returns nonzero for a
   match, zero for no match.  */

match
gfc_match_literal_constant (gfc_expr **result, int signflag)
{
  match m;

  m = match_complex_constant (result);
  if (m != MATCH_NO)
    return m;

  m = match_string_constant (result);
  if (m != MATCH_NO)
    return m;

  m = match_boz_constant (result);
  if (m != MATCH_NO)
    return m;

  m = match_real_constant (result, signflag);
  if (m != MATCH_NO)
    return m;

  m = match_hollerith_constant (result);
  if (m != MATCH_NO)
    return m;

  m = match_integer_constant (result, signflag);
  if (m != MATCH_NO)
    return m;

  m = match_logical_constant (result);
  if (m != MATCH_NO)
    return m;

  return MATCH_NO;
}


/* This checks if a symbol is the return value of an encompassing function.
   Function nesting can be maximally two levels deep, but we may have
   additional local namespaces like BLOCK etc.  */

bool
gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
{
  if (!sym->attr.function || (sym->result != sym))
    return false;
  while (ns)
    {
      if (ns->proc_name == sym)
	return true;
      ns = ns->parent;
    }
  return false;
}


/* Match a single actual argument value.  An actual argument is
   usually an expression, but can also be a procedure name.  If the
   argument is a single name, it is not always possible to tell
   whether the name is a dummy procedure or not.  We treat these cases
   by creating an argument that looks like a dummy procedure and
   fixing things later during resolution.  */

static match
match_actual_arg (gfc_expr **result)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symtree *symtree;
  locus where, w;
  gfc_expr *e;
  char c;

  gfc_gobble_whitespace ();
  where = gfc_current_locus;

  switch (gfc_match_name (name))
    {
    case MATCH_ERROR:
      return MATCH_ERROR;

    case MATCH_NO:
      break;

    case MATCH_YES:
      w = gfc_current_locus;
      gfc_gobble_whitespace ();
      c = gfc_next_ascii_char ();
      gfc_current_locus = w;

      if (c != ',' && c != ')')
	break;

      if (gfc_find_sym_tree (name, NULL, 1, &symtree))
	break;
      /* Handle error elsewhere.  */

      /* Eliminate a couple of common cases where we know we don't
	 have a function argument.  */
      if (symtree == NULL)
	{
	  gfc_get_sym_tree (name, NULL, &symtree, false);
	  gfc_set_sym_referenced (symtree->n.sym);
	}
      else
	{
	  gfc_symbol *sym;

	  sym = symtree->n.sym;
	  gfc_set_sym_referenced (sym);
	  if (sym->attr.flavor == FL_NAMELIST)
	    {
	      gfc_error ("Namelist %qs cannot be an argument at %L",
	      sym->name, &where);
	      break;
	    }
	  if (sym->attr.flavor != FL_PROCEDURE
	      && sym->attr.flavor != FL_UNKNOWN)
	    break;

	  if (sym->attr.in_common && !sym->attr.proc_pointer)
	    {
	      if (!gfc_add_flavor (&sym->attr, FL_VARIABLE,
				   sym->name, &sym->declared_at))
		return MATCH_ERROR;
	      break;
	    }

	  /* If the symbol is a function with itself as the result and
	     is being defined, then we have a variable.  */
	  if (sym->attr.function && sym->result == sym)
	    {
	      if (gfc_is_function_return_value (sym, gfc_current_ns))
		break;

	      if (sym->attr.entry
		  && (sym->ns == gfc_current_ns
		      || sym->ns == gfc_current_ns->parent))
		{
		  gfc_entry_list *el = NULL;

		  for (el = sym->ns->entries; el; el = el->next)
		    if (sym == el->sym)
		      break;

		  if (el)
		    break;
		}
	    }
	}

      e = gfc_get_expr ();	/* Leave it unknown for now */
      e->symtree = symtree;
      e->expr_type = EXPR_VARIABLE;
      e->ts.type = BT_PROCEDURE;
      e->where = where;

      *result = e;
      return MATCH_YES;
    }

  gfc_current_locus = where;
  return gfc_match_expr (result);
}


/* Match a keyword argument or type parameter spec list..  */

static match
match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_actual_arglist *a;
  locus name_locus;
  match m;

  name_locus = gfc_current_locus;
  m = gfc_match_name (name);

  if (m != MATCH_YES)
    goto cleanup;
  if (gfc_match_char ('=') != MATCH_YES)
    {
      m = MATCH_NO;
      goto cleanup;
    }

  if (pdt)
    {
      if (gfc_match_char ('*') == MATCH_YES)
	{
	  actual->spec_type = SPEC_ASSUMED;
	  goto add_name;
	}
      else if (gfc_match_char (':') == MATCH_YES)
	{
	  actual->spec_type = SPEC_DEFERRED;
	  goto add_name;
	}
      else
	actual->spec_type = SPEC_EXPLICIT;
    }

  m = match_actual_arg (&actual->expr);
  if (m != MATCH_YES)
    goto cleanup;

  /* Make sure this name has not appeared yet.  */
add_name:
  if (name[0] != '\0')
    {
      for (a = base; a; a = a->next)
	if (a->name != NULL && strcmp (a->name, name) == 0)
	  {
	    gfc_error ("Keyword %qs at %C has already appeared in the "
		       "current argument list", name);
	    return MATCH_ERROR;
	  }
    }

  actual->name = gfc_get_string ("%s", name);
  return MATCH_YES;

cleanup:
  gfc_current_locus = name_locus;
  return m;
}


/* Match an argument list function, such as %VAL.  */

static match
match_arg_list_function (gfc_actual_arglist *result)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  locus old_locus;
  match m;

  old_locus = gfc_current_locus;

  if (gfc_match_char ('%') != MATCH_YES)
    {
      m = MATCH_NO;
      goto cleanup;
    }

  m = gfc_match ("%n (", name);
  if (m != MATCH_YES)
    goto cleanup;

  if (name[0] != '\0')
    {
      switch (name[0])
	{
	case 'l':
	  if (startswith (name, "loc"))
	    {
	      result->name = "%LOC";
	      break;
	    }
	  /* FALLTHRU */
	case 'r':
	  if (startswith (name, "ref"))
	    {
	      result->name = "%REF";
	      break;
	    }
	  /* FALLTHRU */
	case 'v':
	  if (startswith (name, "val"))
	    {
	      result->name = "%VAL";
	      break;
	    }
	  /* FALLTHRU */
	default:
	  m = MATCH_ERROR;
	  goto cleanup;
	}
    }

  if (!gfc_notify_std (GFC_STD_GNU, "argument list function at %C"))
    {
      m = MATCH_ERROR;
      goto cleanup;
    }

  m = match_actual_arg (&result->expr);
  if (m != MATCH_YES)
    goto cleanup;

  if (gfc_match_char (')') != MATCH_YES)
    {
      m = MATCH_NO;
      goto cleanup;
    }

  return MATCH_YES;

cleanup:
  gfc_current_locus = old_locus;
  return m;
}


/* Matches an actual argument list of a function or subroutine, from
   the opening parenthesis to the closing parenthesis.  The argument
   list is assumed to allow keyword arguments because we don't know if
   the symbol associated with the procedure has an implicit interface
   or not.  We make sure keywords are unique. If sub_flag is set,
   we're matching the argument list of a subroutine.

   NOTE: An alternative use for this function is to match type parameter
   spec lists, which are so similar to actual argument lists that the
   machinery can be reused. This use is flagged by the optional argument
   'pdt'.  */

match
gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt)
{
  gfc_actual_arglist *head, *tail;
  int seen_keyword;
  gfc_st_label *label;
  locus old_loc;
  match m;

  *argp = tail = NULL;
  old_loc = gfc_current_locus;

  seen_keyword = 0;

  if (gfc_match_char ('(') == MATCH_NO)
    return (sub_flag) ? MATCH_YES : MATCH_NO;

  if (gfc_match_char (')') == MATCH_YES)
    return MATCH_YES;

  head = NULL;

  matching_actual_arglist++;

  for (;;)
    {
      if (head == NULL)
	head = tail = gfc_get_actual_arglist ();
      else
	{
	  tail->next = gfc_get_actual_arglist ();
	  tail = tail->next;
	}

      if (sub_flag && !pdt && gfc_match_char ('*') == MATCH_YES)
	{
	  m = gfc_match_st_label (&label);
	  if (m == MATCH_NO)
	    gfc_error ("Expected alternate return label at %C");
	  if (m != MATCH_YES)
	    goto cleanup;

	  if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
			       "at %C"))
	    goto cleanup;

	  tail->label = label;
	  goto next;
	}

      if (pdt && !seen_keyword)
	{
	  if (gfc_match_char (':') == MATCH_YES)
	    {
	      tail->spec_type = SPEC_DEFERRED;
	      goto next;
	    }
	  else if (gfc_match_char ('*') == MATCH_YES)
	    {
	      tail->spec_type = SPEC_ASSUMED;
	      goto next;
	    }
	  else
	    tail->spec_type = SPEC_EXPLICIT;

	  m = match_keyword_arg (tail, head, pdt);
	  if (m == MATCH_YES)
	    {
	      seen_keyword = 1;
	      goto next;
	    }
	  if (m == MATCH_ERROR)
	    goto cleanup;
	}

      /* After the first keyword argument is seen, the following
	 arguments must also have keywords.  */
      if (seen_keyword)
	{
	  m = match_keyword_arg (tail, head, pdt);

	  if (m == MATCH_ERROR)
	    goto cleanup;
	  if (m == MATCH_NO)
	    {
	      gfc_error ("Missing keyword name in actual argument list at %C");
	      goto cleanup;
	    }

	}
      else
	{
	  /* Try an argument list function, like %VAL.  */
	  m = match_arg_list_function (tail);
	  if (m == MATCH_ERROR)
	    goto cleanup;

	  /* See if we have the first keyword argument.  */
	  if (m == MATCH_NO)
	    {
	      m = match_keyword_arg (tail, head, false);
	      if (m == MATCH_YES)
		seen_keyword = 1;
	      if (m == MATCH_ERROR)
		goto cleanup;
	    }

	  if (m == MATCH_NO)
	    {
	      /* Try for a non-keyword argument.  */
	      m = match_actual_arg (&tail->expr);
	      if (m == MATCH_ERROR)
		goto cleanup;
	      if (m == MATCH_NO)
		goto syntax;
	    }
	}


    next:
      if (gfc_match_char (')') == MATCH_YES)
	break;
      if (gfc_match_char (',') != MATCH_YES)
	goto syntax;
    }

  *argp = head;
  matching_actual_arglist--;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in argument list at %C");

cleanup:
  gfc_free_actual_arglist (head);
  gfc_current_locus = old_loc;
  matching_actual_arglist--;
  return MATCH_ERROR;
}


/* Used by gfc_match_varspec() to extend the reference list by one
   element.  */

static gfc_ref *
extend_ref (gfc_expr *primary, gfc_ref *tail)
{
  if (primary->ref == NULL)
    primary->ref = tail = gfc_get_ref ();
  else
    {
      if (tail == NULL)
	gfc_internal_error ("extend_ref(): Bad tail");
      tail->next = gfc_get_ref ();
      tail = tail->next;
    }

  return tail;
}


/* Used by gfc_match_varspec() to match an inquiry reference.  */

static bool
is_inquiry_ref (const char *name, gfc_ref **ref)
{
  inquiry_type type;

  if (name == NULL)
    return false;

  if (ref) *ref = NULL;

  if (strcmp (name, "re") == 0)
    type = INQUIRY_RE;
  else if (strcmp (name, "im") == 0)
    type = INQUIRY_IM;
  else if (strcmp (name, "kind") == 0)
    type = INQUIRY_KIND;
  else if (strcmp (name, "len") == 0)
    type = INQUIRY_LEN;
  else
    return false;

  if (ref)
    {
      *ref = gfc_get_ref ();
      (*ref)->type = REF_INQUIRY;
      (*ref)->u.i = type;
    }

  return true;
}


/* Match any additional specifications associated with the current
   variable like member references or substrings.  If equiv_flag is
   set we only match stuff that is allowed inside an EQUIVALENCE
   statement.  sub_flag tells whether we expect a type-bound procedure found
   to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
   components, 'ppc_arg' determines whether the PPC may be called (with an
   argument list), or whether it may just be referred to as a pointer.  */

match
gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
		   bool ppc_arg)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_ref *substring, *tail, *tmp;
  gfc_component *component = NULL;
  gfc_component *previous = NULL;
  gfc_symbol *sym = primary->symtree->n.sym;
  gfc_expr *tgt_expr = NULL;
  match m;
  bool unknown;
  bool inquiry;
  bool intrinsic;
  locus old_loc;
  char sep;

  tail = NULL;

  gfc_gobble_whitespace ();

  if (gfc_peek_ascii_char () == '[')
    {
      if ((sym->ts.type != BT_CLASS && sym->attr.dimension)
	  || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
	      && CLASS_DATA (sym)->attr.dimension))
	{
	  gfc_error ("Array section designator, e.g. '(:)', is required "
		     "besides the coarray designator '[...]' at %C");
	  return MATCH_ERROR;
	}
      if ((sym->ts.type != BT_CLASS && !sym->attr.codimension)
	  || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
	      && !CLASS_DATA (sym)->attr.codimension))
	{
	  gfc_error ("Coarray designator at %C but %qs is not a coarray",
		     sym->name);
	  return MATCH_ERROR;
	}
    }

  if (sym->assoc && sym->assoc->target)
    tgt_expr = sym->assoc->target;

  /* For associate names, we may not yet know whether they are arrays or not.
     If the selector expression is unambiguously an array; eg. a full array
     or an array section, then the associate name must be an array and we can
     fix it now. Otherwise, if parentheses follow and it is not a character
     type, we have to assume that it actually is one for now.  The final
     decision will be made at resolution, of course.  */
  if (sym->assoc
      && gfc_peek_ascii_char () == '('
      && sym->ts.type != BT_CLASS
      && !sym->attr.dimension)
    {
      gfc_ref *ref = NULL;

      if (!sym->assoc->dangling && tgt_expr)
	{
	   if (tgt_expr->expr_type == EXPR_VARIABLE)
	     gfc_resolve_expr (tgt_expr);

	   ref = tgt_expr->ref;
	   for (; ref; ref = ref->next)
	      if (ref->type == REF_ARRAY
		  && (ref->u.ar.type == AR_FULL
		      || ref->u.ar.type == AR_SECTION))
		break;
	}

      if (ref || (!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER)
		  && sym->assoc->st
		  && sym->assoc->st->n.sym
		  && sym->assoc->st->n.sym->attr.dimension == 0))
	{
	  sym->attr.dimension = 1;
	  if (sym->as == NULL
	      && sym->assoc->st
	      && sym->assoc->st->n.sym
	      && sym->assoc->st->n.sym->as)
	    sym->as = gfc_copy_array_spec (sym->assoc->st->n.sym->as);
	}
    }
  else if (sym->ts.type == BT_CLASS
	   && tgt_expr
	   && tgt_expr->expr_type == EXPR_VARIABLE
	   && sym->ts.u.derived != tgt_expr->ts.u.derived)
    {
      gfc_resolve_expr (tgt_expr);
      if (tgt_expr->rank)
	sym->ts.u.derived = tgt_expr->ts.u.derived;
    }

  if ((equiv_flag && gfc_peek_ascii_char () == '(')
      || gfc_peek_ascii_char () == '[' || sym->attr.codimension
      || (sym->attr.dimension && sym->ts.type != BT_CLASS
	  && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
	  && !(gfc_matching_procptr_assignment
	       && sym->attr.flavor == FL_PROCEDURE))
      || (sym->ts.type == BT_CLASS && sym->attr.class_ok
	  && sym->ts.u.derived && CLASS_DATA (sym)
	  && (CLASS_DATA (sym)->attr.dimension
	      || CLASS_DATA (sym)->attr.codimension)))
    {
      gfc_array_spec *as;

      tail = extend_ref (primary, tail);
      tail->type = REF_ARRAY;

      /* In EQUIVALENCE, we don't know yet whether we are seeing
	 an array, character variable or array of character
	 variables.  We'll leave the decision till resolve time.  */

      if (equiv_flag)
	as = NULL;
      else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
	as = CLASS_DATA (sym)->as;
      else
	as = sym->as;

      m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag,
			       as ? as->corank : 0);
      if (m != MATCH_YES)
	return m;

      gfc_gobble_whitespace ();
      if (equiv_flag && gfc_peek_ascii_char () == '(')
	{
	  tail = extend_ref (primary, tail);
	  tail->type = REF_ARRAY;

	  m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
	  if (m != MATCH_YES)
	    return m;
	}
    }

  primary->ts = sym->ts;

  if (equiv_flag)
    return MATCH_YES;

  /* With DEC extensions, member separator may be '.' or '%'.  */
  sep = gfc_peek_ascii_char ();
  m = gfc_match_member_sep (sym);
  if (m == MATCH_ERROR)
    return MATCH_ERROR;

  inquiry = false;
  if (m == MATCH_YES && sep == '%'
      && primary->ts.type != BT_CLASS
      && primary->ts.type != BT_DERIVED)
    {
      match mm;
      old_loc = gfc_current_locus;
      mm = gfc_match_name (name);
      if (mm == MATCH_YES && is_inquiry_ref (name, &tmp))
	inquiry = true;
      gfc_current_locus = old_loc;
    }

  if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES
      && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
    gfc_set_default_type (sym, 0, sym->ns);

  /* See if there is a usable typespec in the "no IMPLICIT type" error.  */
  if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
    {
      bool permissible;

      /* These target expressions can be resolved at any time.  */
      permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym
		    && (tgt_expr->symtree->n.sym->attr.use_assoc
			|| tgt_expr->symtree->n.sym->attr.host_assoc
			|| tgt_expr->symtree->n.sym->attr.if_source
								== IFSRC_DECL);
      permissible = permissible
		    || (tgt_expr && tgt_expr->expr_type == EXPR_OP);

      if (permissible)
	{
	  gfc_resolve_expr (tgt_expr);
	  sym->ts = tgt_expr->ts;
	}

      if (sym->ts.type == BT_UNKNOWN)
	{
	  gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
	  return MATCH_ERROR;
	}
    }
  else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
           && m == MATCH_YES && !inquiry)
    {
      gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
		 sep, sym->name);
      return MATCH_ERROR;
    }

  if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS && !inquiry)
      || m != MATCH_YES)
    goto check_substring;

  if (!inquiry)
    sym = sym->ts.u.derived;
  else
    sym = NULL;

  for (;;)
    {
      bool t;
      gfc_symtree *tbp;

      m = gfc_match_name (name);
      if (m == MATCH_NO)
	gfc_error ("Expected structure component name at %C");
      if (m != MATCH_YES)
	return MATCH_ERROR;

      intrinsic = false;
      if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED)
	{
	  inquiry = is_inquiry_ref (name, &tmp);
	  if (inquiry)
	    sym = NULL;

	  if (sep == '%')
	    {
	      if (tmp)
		{
		  switch (tmp->u.i)
		    {
		    case INQUIRY_RE:
		    case INQUIRY_IM:
		      if (!gfc_notify_std (GFC_STD_F2008,
					   "RE or IM part_ref at %C"))
			return MATCH_ERROR;
		      break;

		    case INQUIRY_KIND:
		      if (!gfc_notify_std (GFC_STD_F2003,
					   "KIND part_ref at %C"))
			return MATCH_ERROR;
		      break;

		    case INQUIRY_LEN:
		      if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
			return MATCH_ERROR;
		      break;
		    }

		  if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
		      && primary->ts.type != BT_COMPLEX)
		    {
			gfc_error ("The RE or IM part_ref at %C must be "
				   "applied to a COMPLEX expression");
			return MATCH_ERROR;
		    }
		  else if (tmp->u.i == INQUIRY_LEN
			   && primary->ts.type != BT_CHARACTER)
		    {
			gfc_error ("The LEN part_ref at %C must be applied "
				   "to a CHARACTER expression");
			return MATCH_ERROR;
		    }
		}
	      if (primary->ts.type != BT_UNKNOWN)
		intrinsic = true;
	    }
	}
      else
	inquiry = false;

      if (sym && sym->f2k_derived)
	tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
      else
	tbp = NULL;

      if (tbp)
	{
	  gfc_symbol* tbp_sym;

	  if (!t)
	    return MATCH_ERROR;

	  gcc_assert (!tail || !tail->next);

	  if (!(primary->expr_type == EXPR_VARIABLE
		|| (primary->expr_type == EXPR_STRUCTURE
		    && primary->symtree && primary->symtree->n.sym
		    && primary->symtree->n.sym->attr.flavor)))
	    return MATCH_ERROR;

	  if (tbp->n.tb->is_generic)
	    tbp_sym = NULL;
	  else
	    tbp_sym = tbp->n.tb->u.specific->n.sym;

	  primary->expr_type = EXPR_COMPCALL;
	  primary->value.compcall.tbp = tbp->n.tb;
	  primary->value.compcall.name = tbp->name;
	  primary->value.compcall.ignore_pass = 0;
	  primary->value.compcall.assign = 0;
	  primary->value.compcall.base_object = NULL;
	  gcc_assert (primary->symtree->n.sym->attr.referenced);
	  if (tbp_sym)
	    primary->ts = tbp_sym->ts;
	  else
	    gfc_clear_ts (&primary->ts);

	  m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
					&primary->value.compcall.actual);
	  if (m == MATCH_ERROR)
	    return MATCH_ERROR;
	  if (m == MATCH_NO)
	    {
	      if (sub_flag)
		primary->value.compcall.actual = NULL;
	      else
		{
		  gfc_error ("Expected argument list at %C");
		  return MATCH_ERROR;
		}
	    }

	  break;
	}

      previous = component;

      if (!inquiry && !intrinsic)
	component = gfc_find_component (sym, name, false, false, &tmp);
      else
	component = NULL;

      if (intrinsic && !inquiry)
	{
	  if (previous)
	    gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
			"type component %qs", name, previous->name);
	  else
	    gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
			"type component", name);
	  return MATCH_ERROR;
	}
      else if (component == NULL && !inquiry)
	return MATCH_ERROR;

      /* Extend the reference chain determined by gfc_find_component or
	 is_inquiry_ref.  */
      if (primary->ref == NULL)
	primary->ref = tmp;
      else
	{
	  /* Set by the for loop below for the last component ref.  */
	  gcc_assert (tail != NULL);
	  tail->next = tmp;
	}

      /* The reference chain may be longer than one hop for union
	 subcomponents; find the new tail.  */
      for (tail = tmp; tail->next; tail = tail->next)
	;

      if (tmp && tmp->type == REF_INQUIRY)
	{
	  if (!primary->where.lb || !primary->where.nextc)
	    primary->where = gfc_current_locus;
	  gfc_simplify_expr (primary, 0);

	  if (primary->expr_type == EXPR_CONSTANT)
	    goto check_done;

	  switch (tmp->u.i)
	    {
	    case INQUIRY_RE:
	    case INQUIRY_IM:
	      if (!gfc_notify_std (GFC_STD_F2008, "RE or IM part_ref at %C"))
		return MATCH_ERROR;

	      if (primary->ts.type != BT_COMPLEX)
		{
		  gfc_error ("The RE or IM part_ref at %C must be "
			     "applied to a COMPLEX expression");
		  return MATCH_ERROR;
		}
	      primary->ts.type = BT_REAL;
	      break;

	    case INQUIRY_LEN:
	      if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
		return MATCH_ERROR;

	      if (primary->ts.type != BT_CHARACTER)
		{
		  gfc_error ("The LEN part_ref at %C must be applied "
			     "to a CHARACTER expression");
		  return MATCH_ERROR;
		}
	      primary->ts.u.cl = NULL;
	      primary->ts.type = BT_INTEGER;
	      primary->ts.kind = gfc_default_integer_kind;
	      break;

	    case INQUIRY_KIND:
	      if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C"))
		return MATCH_ERROR;

	      if (primary->ts.type == BT_CLASS
		  || primary->ts.type == BT_DERIVED)
		{
		  gfc_error ("The KIND part_ref at %C must be applied "
			     "to an expression of intrinsic type");
		  return MATCH_ERROR;
		}
	      primary->ts.type = BT_INTEGER;
	      primary->ts.kind = gfc_default_integer_kind;
	      break;

	    default:
	      gcc_unreachable ();
	    }

	  goto check_done;
	}

      primary->ts = component->ts;

      if (component->attr.proc_pointer && ppc_arg)
	{
	  /* Procedure pointer component call: Look for argument list.  */
	  m = gfc_match_actual_arglist (sub_flag,
					&primary->value.compcall.actual);
	  if (m == MATCH_ERROR)
	    return MATCH_ERROR;

	  if (m == MATCH_NO && !gfc_matching_ptr_assignment
	      && !gfc_matching_procptr_assignment && !matching_actual_arglist)
	    {
	      gfc_error ("Procedure pointer component %qs requires an "
			 "argument list at %C", component->name);
	      return MATCH_ERROR;
	    }

	  if (m == MATCH_YES)
	    primary->expr_type = EXPR_PPC;

          break;
	}

      if (component->as != NULL && !component->attr.proc_pointer)
	{
	  tail = extend_ref (primary, tail);
	  tail->type = REF_ARRAY;

	  m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
			  component->as->corank);
	  if (m != MATCH_YES)
	    return m;
	}
      else if (component->ts.type == BT_CLASS && component->attr.class_ok
	       && CLASS_DATA (component)->as && !component->attr.proc_pointer)
	{
	  tail = extend_ref (primary, tail);
	  tail->type = REF_ARRAY;

	  m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
				   equiv_flag,
				   CLASS_DATA (component)->as->corank);
	  if (m != MATCH_YES)
	    return m;
	}

check_done:
      /* In principle, we could have eg. expr%re%kind so we must allow for
	 this possibility.  */
      if (gfc_match_char ('%') == MATCH_YES)
	{
	  if (component && (component->ts.type == BT_DERIVED
			    || component->ts.type == BT_CLASS))
	    sym = component->ts.u.derived;
	  continue;
	}
      else if (inquiry)
	break;

      if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
  	  || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES)
	break;

      if (component->ts.type == BT_DERIVED || component->ts.type == BT_CLASS)
	sym = component->ts.u.derived;
    }

check_substring:
  unknown = false;
  if (primary->ts.type == BT_UNKNOWN && !gfc_fl_struct (sym->attr.flavor))
    {
      if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
       {
	 gfc_set_default_type (sym, 0, sym->ns);
	 primary->ts = sym->ts;
	 unknown = true;
       }
    }

  if (primary->ts.type == BT_CHARACTER)
    {
      bool def = primary->ts.deferred == 1;
      switch (match_substring (primary->ts.u.cl, equiv_flag, &substring, def))
	{
	case MATCH_YES:
	  if (tail == NULL)
	    primary->ref = substring;
	  else
	    tail->next = substring;

	  if (primary->expr_type == EXPR_CONSTANT)
	    primary->expr_type = EXPR_SUBSTRING;

	  if (substring)
	    primary->ts.u.cl = NULL;

	  break;

	case MATCH_NO:
	  if (unknown)
	    {
	      gfc_clear_ts (&primary->ts);
	      gfc_clear_ts (&sym->ts);
	    }
	  break;

	case MATCH_ERROR:
	  return MATCH_ERROR;
	}
    }

  /* F08:C611.  */
  if (primary->ts.type == BT_DERIVED && primary->ref
      && primary->ts.u.derived && primary->ts.u.derived->attr.abstract)
    {
      gfc_error ("Nonpolymorphic reference to abstract type at %C");
      return MATCH_ERROR;
    }

  /* F08:C727.  */
  if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
    {
      gfc_error ("Coindexed procedure-pointer component at %C");
      return MATCH_ERROR;
    }

  return MATCH_YES;
}


/* Given an expression that is a variable, figure out what the
   ultimate variable's type and attribute is, traversing the reference
   structures if necessary.

   This subroutine is trickier than it looks.  We start at the base
   symbol and store the attribute.  Component references load a
   completely new attribute.

   A couple of rules come into play.  Subobjects of targets are always
   targets themselves.  If we see a component that goes through a
   pointer, then the expression must also be a target, since the
   pointer is associated with something (if it isn't core will soon be
   dumped).  If we see a full part or section of an array, the
   expression is also an array.

   We can have at most one full array reference.  */

symbol_attribute
gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
{
  int dimension, codimension, pointer, allocatable, target, optional;
  symbol_attribute attr;
  gfc_ref *ref;
  gfc_symbol *sym;
  gfc_component *comp;
  bool has_inquiry_part;

  if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
    gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");

  sym = expr->symtree->n.sym;
  attr = sym->attr;

  optional = attr.optional;
  if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
    {
      dimension = CLASS_DATA (sym)->attr.dimension;
      codimension = CLASS_DATA (sym)->attr.codimension;
      pointer = CLASS_DATA (sym)->attr.class_pointer;
      allocatable = CLASS_DATA (sym)->attr.allocatable;
      optional |= CLASS_DATA (sym)->attr.optional;
    }
  else
    {
      dimension = attr.dimension;
      codimension = attr.codimension;
      pointer = attr.pointer;
      allocatable = attr.allocatable;
    }

  target = attr.target;
  if (pointer || attr.proc_pointer)
    target = 1;

  if (ts != NULL && expr->ts.type == BT_UNKNOWN)
    *ts = sym->ts;

  has_inquiry_part = false;
  for (ref = expr->ref; ref; ref = ref->next)
    if (ref->type == REF_INQUIRY)
      {
	has_inquiry_part = true;
	optional = false;
	break;
      }

  for (ref = expr->ref; ref; ref = ref->next)
    switch (ref->type)
      {
      case REF_ARRAY:

	switch (ref->u.ar.type)
	  {
	  case AR_FULL:
	    dimension = 1;
	    break;

	  case AR_SECTION:
	    allocatable = pointer = 0;
	    dimension = 1;
	    optional = false;
	    break;

	  case AR_ELEMENT:
	    /* Handle coarrays.  */
	    if (ref->u.ar.dimen > 0)
	      allocatable = pointer = optional = false;
	    break;

	  case AR_UNKNOWN:
	    /* For standard conforming code, AR_UNKNOWN should not happen.
	       For nonconforming code, gfortran can end up here.  Treat it
	       as a no-op.  */
	    break;
	  }

	break;

      case REF_COMPONENT:
	optional = false;
	comp = ref->u.c.component;
	attr = comp->attr;
	if (ts != NULL && !has_inquiry_part)
	  {
	    *ts = comp->ts;
	    /* Don't set the string length if a substring reference
	       follows.  */
	    if (ts->type == BT_CHARACTER
		&& ref->next && ref->next->type == REF_SUBSTRING)
		ts->u.cl = NULL;
	  }

	if (comp->ts.type == BT_CLASS)
	  {
	    codimension = CLASS_DATA (comp)->attr.codimension;
	    pointer = CLASS_DATA (comp)->attr.class_pointer;
	    allocatable = CLASS_DATA (comp)->attr.allocatable;
	  }
	else
	  {
	    codimension = comp->attr.codimension;
	    if (expr->ts.type == BT_CLASS && strcmp (comp->name, "_data") == 0)
	      pointer = comp->attr.class_pointer;
	    else
	      pointer = comp->attr.pointer;
	    allocatable = comp->attr.allocatable;
	  }
	if (pointer || attr.proc_pointer)
	  target = 1;

	break;

      case REF_INQUIRY:
      case REF_SUBSTRING:
	allocatable = pointer = optional = false;
	break;
      }

  attr.dimension = dimension;
  attr.codimension = codimension;
  attr.pointer = pointer;
  attr.allocatable = allocatable;
  attr.target = target;
  attr.save = sym->attr.save;
  attr.optional = optional;

  return attr;
}


/* Return the attribute from a general expression.  */

symbol_attribute
gfc_expr_attr (gfc_expr *e)
{
  symbol_attribute attr;

  switch (e->expr_type)
    {
    case EXPR_VARIABLE:
      attr = gfc_variable_attr (e, NULL);
      break;

    case EXPR_FUNCTION:
      gfc_clear_attr (&attr);

      if (e->value.function.esym && e->value.function.esym->result)
	{
	  gfc_symbol *sym = e->value.function.esym->result;
	  attr = sym->attr;
	  if (sym->ts.type == BT_CLASS)
	    {
	      attr.dimension = CLASS_DATA (sym)->attr.dimension;
	      attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
	      attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
	    }
	}
      else if (e->value.function.isym
	       && e->value.function.isym->transformational
	       && e->ts.type == BT_CLASS)
	attr = CLASS_DATA (e)->attr;
      else if (e->symtree)
	attr = gfc_variable_attr (e, NULL);

      /* TODO: NULL() returns pointers.  May have to take care of this
	 here.  */

      break;

    default:
      gfc_clear_attr (&attr);
      break;
    }

  return attr;
}


/* Given an expression, figure out what the ultimate expression
   attribute is.  This routine is similar to gfc_variable_attr with
   parts of gfc_expr_attr, but focuses more on the needs of
   coarrays.  For coarrays a codimension attribute is kind of
   "infectious" being propagated once set and never cleared.
   The coarray_comp is only set, when the expression refs a coarray
   component.  REFS_COMP is set when present to true only, when this EXPR
   refs a (non-_data) component.  To check whether EXPR refs an allocatable
   component in a derived type coarray *refs_comp needs to be set and
   coarray_comp has to false.  */

static symbol_attribute
caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
{
  int dimension, codimension, pointer, allocatable, target, coarray_comp;
  symbol_attribute attr;
  gfc_ref *ref;
  gfc_symbol *sym;
  gfc_component *comp;

  if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
    gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");

  sym = expr->symtree->n.sym;
  gfc_clear_attr (&attr);

  if (refs_comp)
    *refs_comp = false;

  if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
    {
      dimension = CLASS_DATA (sym)->attr.dimension;
      codimension = CLASS_DATA (sym)->attr.codimension;
      pointer = CLASS_DATA (sym)->attr.class_pointer;
      allocatable = CLASS_DATA (sym)->attr.allocatable;
      attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
      attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp;
    }
  else
    {
      dimension = sym->attr.dimension;
      codimension = sym->attr.codimension;
      pointer = sym->attr.pointer;
      allocatable = sym->attr.allocatable;
      attr.alloc_comp = sym->ts.type == BT_DERIVED
	  ? sym->ts.u.derived->attr.alloc_comp : 0;
      attr.pointer_comp = sym->ts.type == BT_DERIVED
	  ? sym->ts.u.derived->attr.pointer_comp : 0;
    }

  target = coarray_comp = 0;
  if (pointer || attr.proc_pointer)
    target = 1;

  for (ref = expr->ref; ref; ref = ref->next)
    switch (ref->type)
      {
      case REF_ARRAY:

	switch (ref->u.ar.type)
	  {
	  case AR_FULL:
	  case AR_SECTION:
	    dimension = 1;
	    break;

	  case AR_ELEMENT:
	    /* Handle coarrays.  */
	    if (ref->u.ar.dimen > 0 && !in_allocate)
	      allocatable = pointer = 0;
	    break;

	  case AR_UNKNOWN:
	    /* If any of start, end or stride is not integer, there will
	       already have been an error issued.  */
	    int errors;
	    gfc_get_errors (NULL, &errors);
	    if (errors == 0)
	      gfc_internal_error ("gfc_caf_attr(): Bad array reference");
	  }

	break;

      case REF_COMPONENT:
	comp = ref->u.c.component;

	if (comp->ts.type == BT_CLASS)
	  {
	    /* Set coarray_comp only, when this component introduces the
	       coarray.  */
	    coarray_comp = !codimension && CLASS_DATA (comp)->attr.codimension;
	    codimension |= CLASS_DATA (comp)->attr.codimension;
	    pointer = CLASS_DATA (comp)->attr.class_pointer;
	    allocatable = CLASS_DATA (comp)->attr.allocatable;
	  }
	else
	  {
	    /* Set coarray_comp only, when this component introduces the
	       coarray.  */
	    coarray_comp = !codimension && comp->attr.codimension;
	    codimension |= comp->attr.codimension;
	    pointer = comp->attr.pointer;
	    allocatable = comp->attr.allocatable;
	  }

	if (refs_comp && strcmp (comp->name, "_data") != 0
	    && (ref->next == NULL
		|| (ref->next->type == REF_ARRAY && ref->next->next == NULL)))
	  *refs_comp = true;

	if (pointer || attr.proc_pointer)
	  target = 1;

	break;

      case REF_SUBSTRING:
      case REF_INQUIRY:
	allocatable = pointer = 0;
	break;
      }

  attr.dimension = dimension;
  attr.codimension = codimension;
  attr.pointer = pointer;
  attr.allocatable = allocatable;
  attr.target = target;
  attr.save = sym->attr.save;
  attr.coarray_comp = coarray_comp;

  return attr;
}


symbol_attribute
gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp)
{
  symbol_attribute attr;

  switch (e->expr_type)
    {
    case EXPR_VARIABLE:
      attr = caf_variable_attr (e, in_allocate, refs_comp);
      break;

    case EXPR_FUNCTION:
      gfc_clear_attr (&attr);

      if (e->value.function.esym && e->value.function.esym->result)
	{
	  gfc_symbol *sym = e->value.function.esym->result;
	  attr = sym->attr;
	  if (sym->ts.type == BT_CLASS)
	    {
	      attr.dimension = CLASS_DATA (sym)->attr.dimension;
	      attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
	      attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
	      attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
	      attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived
		  ->attr.pointer_comp;
	    }
	}
      else if (e->symtree)
	attr = caf_variable_attr (e, in_allocate, refs_comp);
      else
	gfc_clear_attr (&attr);
      break;

    default:
      gfc_clear_attr (&attr);
      break;
    }

  return attr;
}


/* Match a structure constructor.  The initial symbol has already been
   seen.  */

typedef struct gfc_structure_ctor_component
{
  char* name;
  gfc_expr* val;
  locus where;
  struct gfc_structure_ctor_component* next;
}
gfc_structure_ctor_component;

#define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)

static void
gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
{
  free (comp->name);
  gfc_free_expr (comp->val);
  free (comp);
}


/* Translate the component list into the actual constructor by sorting it in
   the order required; this also checks along the way that each and every
   component actually has an initializer and handles default initializers
   for components without explicit value given.  */
static bool
build_actual_constructor (gfc_structure_ctor_component **comp_head,
			  gfc_constructor_base *ctor_head, gfc_symbol *sym)
{
  gfc_structure_ctor_component *comp_iter;
  gfc_component *comp;

  for (comp = sym->components; comp; comp = comp->next)
    {
      gfc_structure_ctor_component **next_ptr;
      gfc_expr *value = NULL;

      /* Try to find the initializer for the current component by name.  */
      next_ptr = comp_head;
      for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
	{
	  if (!strcmp (comp_iter->name, comp->name))
	    break;
	  next_ptr = &comp_iter->next;
	}

      /* If an extension, try building the parent derived type by building
	 a value expression for the parent derived type and calling self.  */
      if (!comp_iter && comp == sym->components && sym->attr.extension)
	{
	  value = gfc_get_structure_constructor_expr (comp->ts.type,
						      comp->ts.kind,
						      &gfc_current_locus);
	  value->ts = comp->ts;

	  if (!build_actual_constructor (comp_head,
					 &value->value.constructor,
					 comp->ts.u.derived))
	    {
	      gfc_free_expr (value);
	      return false;
	    }

	  gfc_constructor_append_expr (ctor_head, value, NULL);
	  continue;
	}

      /* If it was not found, apply NULL expression to set the component as
	 unallocated. Then try the default initializer if there's any;
	 otherwise, it's an error unless this is a deferred parameter.  */
      if (!comp_iter)
	{
	  /* F2018 7.5.10: If an allocatable component has no corresponding
	     component-data-source, then that component has an allocation
	     status of unallocated....  */
	  if (comp->attr.allocatable
	      || (comp->ts.type == BT_CLASS
		  && CLASS_DATA (comp)->attr.allocatable))
	    {
	      if (!gfc_notify_std (GFC_STD_F2008, "No initializer for "
				   "allocatable component %qs given in the "
				   "structure constructor at %C", comp->name))
		return false;
	      value = gfc_get_null_expr (&gfc_current_locus);
	    }
	  /* ....(Preceeding sentence) If a component with default
	     initialization has no corresponding component-data-source, then
	     the default initialization is applied to that component.  */
	  else if (comp->initializer)
	    {
	      if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor "
				   "with missing optional arguments at %C"))
		return false;
	      value = gfc_copy_expr (comp->initializer);
	    }
	  /* Do not trap components such as the string length for deferred
	     length character components.  */
	  else if (!comp->attr.artificial)
	    {
	      gfc_error ("No initializer for component %qs given in the"
			 " structure constructor at %C", comp->name);
	      return false;
	    }
	}
      else
	value = comp_iter->val;

      /* Add the value to the constructor chain built.  */
      gfc_constructor_append_expr (ctor_head, value, NULL);

      /* Remove the entry from the component list.  We don't want the expression
	 value to be free'd, so set it to NULL.  */
      if (comp_iter)
	{
	  *next_ptr = comp_iter->next;
	  comp_iter->val = NULL;
	  gfc_free_structure_ctor_component (comp_iter);
	}
    }
  return true;
}


bool
gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
				      gfc_actual_arglist **arglist,
				      bool parent)
{
  gfc_actual_arglist *actual;
  gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
  gfc_constructor_base ctor_head = NULL;
  gfc_component *comp; /* Is set NULL when named component is first seen */
  const char* last_name = NULL;
  locus old_locus;
  gfc_expr *expr;

  expr = parent ? *cexpr : e;
  old_locus = gfc_current_locus;
  if (parent)
    ; /* gfc_current_locus = *arglist->expr ? ->where;*/
  else
    gfc_current_locus = expr->where;

  comp_tail = comp_head = NULL;

  if (!parent && sym->attr.abstract)
    {
      gfc_error ("Cannot construct ABSTRACT type %qs at %L",
		 sym->name, &expr->where);
      goto cleanup;
    }

  comp = sym->components;
  actual = parent ? *arglist : expr->value.function.actual;
  for ( ; actual; )
    {
      gfc_component *this_comp = NULL;

      if (!comp_head)
	comp_tail = comp_head = gfc_get_structure_ctor_component ();
      else
	{
	  comp_tail->next = gfc_get_structure_ctor_component ();
	  comp_tail = comp_tail->next;
       	}
      if (actual->name)
	{
	  if (!gfc_notify_std (GFC_STD_F2003, "Structure"
			       " constructor with named arguments at %C"))
	    goto cleanup;

	  comp_tail->name = xstrdup (actual->name);
	  last_name = comp_tail->name;
	  comp = NULL;
	}
      else
	{
	  /* Components without name are not allowed after the first named
	     component initializer!  */
	  if (!comp || comp->attr.artificial)
	    {
	      if (last_name)
		gfc_error ("Component initializer without name after component"
			   " named %s at %L", last_name,
			   actual->expr ? &actual->expr->where
					: &gfc_current_locus);
	      else
		gfc_error ("Too many components in structure constructor at "
			   "%L", actual->expr ? &actual->expr->where
					      : &gfc_current_locus);
	      goto cleanup;
	    }

	  comp_tail->name = xstrdup (comp->name);
	}

      /* Find the current component in the structure definition and check
	     its access is not private.  */
      if (comp)
	this_comp = gfc_find_component (sym, comp->name, false, false, NULL);
      else
	{
	  this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
					  false, false, NULL);
	  comp = NULL; /* Reset needed!  */
	}

      /* Here we can check if a component name is given which does not
	 correspond to any component of the defined structure.  */
      if (!this_comp)
	goto cleanup;

      /* For a constant string constructor, make sure the length is
	 correct; truncate of fill with blanks if needed.  */
      if (this_comp->ts.type == BT_CHARACTER && !this_comp->attr.allocatable
	  && this_comp->ts.u.cl && this_comp->ts.u.cl->length
	  && this_comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
	  && actual->expr->ts.type == BT_CHARACTER
	  && actual->expr->expr_type == EXPR_CONSTANT)
	{
	  ptrdiff_t c, e1;
	  c = gfc_mpz_get_hwi (this_comp->ts.u.cl->length->value.integer);
	  e1 = actual->expr->value.character.length;

	  if (c != e1)