gcc/fortran/expr.c

/* Routines for manipulation of expression nodes.
   Copyright (C) 2000-2019 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 "target-memory.h" /* for gfc_convert_boz */
#include "constructor.h"
#include "tree.h"


/* The following set of functions provide access to gfc_expr* of
   various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.

   There are two functions available elsewhere that provide
   slightly different flavours of variables.  Namely:
     expr.c (gfc_get_variable_expr)
     symbol.c (gfc_lval_expr_from_sym)
   TODO: Merge these functions, if possible.  */

/* Get a new expression node.  */

gfc_expr *
gfc_get_expr (void)
{
  gfc_expr *e;

  e = XCNEW (gfc_expr);
  gfc_clear_ts (&e->ts);
  e->shape = NULL;
  e->ref = NULL;
  e->symtree = NULL;
  return e;
}


/* Get a new expression node that is an array constructor
   of given type and kind.  */

gfc_expr *
gfc_get_array_expr (bt type, int kind, locus *where)
{
  gfc_expr *e;

  e = gfc_get_expr ();
  e->expr_type = EXPR_ARRAY;
  e->value.constructor = NULL;
  e->rank = 1;
  e->shape = NULL;

  e->ts.type = type;
  e->ts.kind = kind;
  if (where)
    e->where = *where;

  return e;
}


/* Get a new expression node that is the NULL expression.  */

gfc_expr *
gfc_get_null_expr (locus *where)
{
  gfc_expr *e;

  e = gfc_get_expr ();
  e->expr_type = EXPR_NULL;
  e->ts.type = BT_UNKNOWN;

  if (where)
    e->where = *where;

  return e;
}


/* Get a new expression node that is an operator expression node.  */

gfc_expr *
gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
                      gfc_expr *op1, gfc_expr *op2)
{
  gfc_expr *e;

  e = gfc_get_expr ();
  e->expr_type = EXPR_OP;
  e->value.op.op = op;
  e->value.op.op1 = op1;
  e->value.op.op2 = op2;

  if (where)
    e->where = *where;

  return e;
}


/* Get a new expression node that is an structure constructor
   of given type and kind.  */

gfc_expr *
gfc_get_structure_constructor_expr (bt type, int kind, locus *where)
{
  gfc_expr *e;

  e = gfc_get_expr ();
  e->expr_type = EXPR_STRUCTURE;
  e->value.constructor = NULL;

  e->ts.type = type;
  e->ts.kind = kind;
  if (where)
    e->where = *where;

  return e;
}


/* Get a new expression node that is an constant of given type and kind.  */

gfc_expr *
gfc_get_constant_expr (bt type, int kind, locus *where)
{
  gfc_expr *e;

  if (!where)
    gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be "
			"NULL");

  e = gfc_get_expr ();

  e->expr_type = EXPR_CONSTANT;
  e->ts.type = type;
  e->ts.kind = kind;
  e->where = *where;

  switch (type)
    {
    case BT_INTEGER:
      mpz_init (e->value.integer);
      break;

    case BT_REAL:
      gfc_set_model_kind (kind);
      mpfr_init (e->value.real);
      break;

    case BT_COMPLEX:
      gfc_set_model_kind (kind);
      mpc_init2 (e->value.complex, mpfr_get_default_prec());
      break;

    default:
      break;
    }

  return e;
}


/* Get a new expression node that is an string constant.
   If no string is passed, a string of len is allocated,
   blanked and null-terminated.  */

gfc_expr *
gfc_get_character_expr (int kind, locus *where, const char *src, gfc_charlen_t len)
{
  gfc_expr *e;
  gfc_char_t *dest;

  if (!src)
    {
      dest = gfc_get_wide_string (len + 1);
      gfc_wide_memset (dest, ' ', len);
      dest[len] = '\0';
    }
  else
    dest = gfc_char_to_widechar (src);

  e = gfc_get_constant_expr (BT_CHARACTER, kind,
                            where ? where : &gfc_current_locus);
  e->value.character.string = dest;
  e->value.character.length = len;

  return e;
}


/* Get a new expression node that is an integer constant.  */

gfc_expr *
gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INT value)
{
  gfc_expr *p;
  p = gfc_get_constant_expr (BT_INTEGER, kind,
			     where ? where : &gfc_current_locus);

  const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT);
  wi::to_mpz (w, p->value.integer, SIGNED);

  return p;
}


/* Get a new expression node that is a logical constant.  */

gfc_expr *
gfc_get_logical_expr (int kind, locus *where, bool value)
{
  gfc_expr *p;
  p = gfc_get_constant_expr (BT_LOGICAL, kind,
			     where ? where : &gfc_current_locus);

  p->value.logical = value;

  return p;
}


gfc_expr *
gfc_get_iokind_expr (locus *where, io_kind k)
{
  gfc_expr *e;

  /* Set the types to something compatible with iokind. This is needed to
     get through gfc_free_expr later since iokind really has no Basic Type,
     BT, of its own.  */

  e = gfc_get_expr ();
  e->expr_type = EXPR_CONSTANT;
  e->ts.type = BT_LOGICAL;
  e->value.iokind = k;
  e->where = *where;

  return e;
}


/* Given an expression pointer, return a copy of the expression.  This
   subroutine is recursive.  */

gfc_expr *
gfc_copy_expr (gfc_expr *p)
{
  gfc_expr *q;
  gfc_char_t *s;
  char *c;

  if (p == NULL)
    return NULL;

  q = gfc_get_expr ();
  *q = *p;

  switch (q->expr_type)
    {
    case EXPR_SUBSTRING:
      s = gfc_get_wide_string (p->value.character.length + 1);
      q->value.character.string = s;
      memcpy (s, p->value.character.string,
	      (p->value.character.length + 1) * sizeof (gfc_char_t));
      break;

    case EXPR_CONSTANT:
      /* Copy target representation, if it exists.  */
      if (p->representation.string)
	{
	  c = XCNEWVEC (char, p->representation.length + 1);
	  q->representation.string = c;
	  memcpy (c, p->representation.string, (p->representation.length + 1));
	}

      /* Copy the values of any pointer components of p->value.  */
      switch (q->ts.type)
	{
	case BT_INTEGER:
	  mpz_init_set (q->value.integer, p->value.integer);
	  break;

	case BT_REAL:
	  gfc_set_model_kind (q->ts.kind);
	  mpfr_init (q->value.real);
	  mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
	  break;

	case BT_COMPLEX:
	  gfc_set_model_kind (q->ts.kind);
	  mpc_init2 (q->value.complex, mpfr_get_default_prec());
	  mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
	  break;

	case BT_CHARACTER:
	  if (p->representation.string)
	    q->value.character.string
	      = gfc_char_to_widechar (q->representation.string);
	  else
	    {
	      s = gfc_get_wide_string (p->value.character.length + 1);
	      q->value.character.string = s;

	      /* This is the case for the C_NULL_CHAR named constant.  */
	      if (p->value.character.length == 0
		  && (p->ts.is_c_interop || p->ts.is_iso_c))
		{
		  *s = '\0';
		  /* Need to set the length to 1 to make sure the NUL
		     terminator is copied.  */
		  q->value.character.length = 1;
		}
	      else
		memcpy (s, p->value.character.string,
			(p->value.character.length + 1) * sizeof (gfc_char_t));
	    }
	  break;

	case BT_HOLLERITH:
	case BT_LOGICAL:
	case_bt_struct:
	case BT_CLASS:
	case BT_ASSUMED:
	  break;		/* Already done.  */

	case BT_PROCEDURE:
        case BT_VOID:
           /* Should never be reached.  */
	case BT_UNKNOWN:
	  gfc_internal_error ("gfc_copy_expr(): Bad expr node");
	  /* Not reached.  */
	}

      break;

    case EXPR_OP:
      switch (q->value.op.op)
	{
	case INTRINSIC_NOT:
	case INTRINSIC_PARENTHESES:
	case INTRINSIC_UPLUS:
	case INTRINSIC_UMINUS:
	  q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
	  break;

	default:		/* Binary operators.  */
	  q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
	  q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
	  break;
	}

      break;

    case EXPR_FUNCTION:
      q->value.function.actual =
	gfc_copy_actual_arglist (p->value.function.actual);
      break;

    case EXPR_COMPCALL:
    case EXPR_PPC:
      q->value.compcall.actual =
	gfc_copy_actual_arglist (p->value.compcall.actual);
      q->value.compcall.tbp = p->value.compcall.tbp;
      break;

    case EXPR_STRUCTURE:
    case EXPR_ARRAY:
      q->value.constructor = gfc_constructor_copy (p->value.constructor);
      break;

    case EXPR_VARIABLE:
    case EXPR_NULL:
      break;

    case EXPR_UNKNOWN:
      gcc_unreachable ();
    }

  q->shape = gfc_copy_shape (p->shape, p->rank);

  q->ref = gfc_copy_ref (p->ref);

  if (p->param_list)
    q->param_list = gfc_copy_actual_arglist (p->param_list);

  return q;
}


void
gfc_clear_shape (mpz_t *shape, int rank)
{
  int i;

  for (i = 0; i < rank; i++)
    mpz_clear (shape[i]);
}


void
gfc_free_shape (mpz_t **shape, int rank)
{
  if (*shape == NULL)
    return;

  gfc_clear_shape (*shape, rank);
  free (*shape);
  *shape = NULL;
}


/* Workhorse function for gfc_free_expr() that frees everything
   beneath an expression node, but not the node itself.  This is
   useful when we want to simplify a node and replace it with
   something else or the expression node belongs to another structure.  */

static void
free_expr0 (gfc_expr *e)
{
  switch (e->expr_type)
    {
    case EXPR_CONSTANT:
      /* Free any parts of the value that need freeing.  */
      switch (e->ts.type)
	{
	case BT_INTEGER:
	  mpz_clear (e->value.integer);
	  break;

	case BT_REAL:
	  mpfr_clear (e->value.real);
	  break;

	case BT_CHARACTER:
	  free (e->value.character.string);
	  break;

	case BT_COMPLEX:
	  mpc_clear (e->value.complex);
	  break;

	default:
	  break;
	}

      /* Free the representation.  */
      free (e->representation.string);

      break;

    case EXPR_OP:
      if (e->value.op.op1 != NULL)
	gfc_free_expr (e->value.op.op1);
      if (e->value.op.op2 != NULL)
	gfc_free_expr (e->value.op.op2);
      break;

    case EXPR_FUNCTION:
      gfc_free_actual_arglist (e->value.function.actual);
      break;

    case EXPR_COMPCALL:
    case EXPR_PPC:
      gfc_free_actual_arglist (e->value.compcall.actual);
      break;

    case EXPR_VARIABLE:
      break;

    case EXPR_ARRAY:
    case EXPR_STRUCTURE:
      gfc_constructor_free (e->value.constructor);
      break;

    case EXPR_SUBSTRING:
      free (e->value.character.string);
      break;

    case EXPR_NULL:
      break;

    default:
      gfc_internal_error ("free_expr0(): Bad expr type");
    }

  /* Free a shape array.  */
  gfc_free_shape (&e->shape, e->rank);

  gfc_free_ref_list (e->ref);

  gfc_free_actual_arglist (e->param_list);

  memset (e, '\0', sizeof (gfc_expr));
}


/* Free an expression node and everything beneath it.  */

void
gfc_free_expr (gfc_expr *e)
{
  if (e == NULL)
    return;
  free_expr0 (e);
  free (e);
}


/* Free an argument list and everything below it.  */

void
gfc_free_actual_arglist (gfc_actual_arglist *a1)
{
  gfc_actual_arglist *a2;

  while (a1)
    {
      a2 = a1->next;
      if (a1->expr)
      gfc_free_expr (a1->expr);
      free (a1);
      a1 = a2;
    }
}


/* Copy an arglist structure and all of the arguments.  */

gfc_actual_arglist *
gfc_copy_actual_arglist (gfc_actual_arglist *p)
{
  gfc_actual_arglist *head, *tail, *new_arg;

  head = tail = NULL;

  for (; p; p = p->next)
    {
      new_arg = gfc_get_actual_arglist ();
      *new_arg = *p;

      new_arg->expr = gfc_copy_expr (p->expr);
      new_arg->next = NULL;

      if (head == NULL)
	head = new_arg;
      else
	tail->next = new_arg;

      tail = new_arg;
    }

  return head;
}


/* Free a list of reference structures.  */

void
gfc_free_ref_list (gfc_ref *p)
{
  gfc_ref *q;
  int i;

  for (; p; p = q)
    {
      q = p->next;

      switch (p->type)
	{
	case REF_ARRAY:
	  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
	    {
	      gfc_free_expr (p->u.ar.start[i]);
	      gfc_free_expr (p->u.ar.end[i]);
	      gfc_free_expr (p->u.ar.stride[i]);
	    }

	  break;

	case REF_SUBSTRING:
	  gfc_free_expr (p->u.ss.start);
	  gfc_free_expr (p->u.ss.end);
	  break;

	case REF_COMPONENT:
	case REF_INQUIRY:
	  break;
	}

      free (p);
    }
}


/* Graft the *src expression onto the *dest subexpression.  */

void
gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
{
  free_expr0 (dest);
  *dest = *src;
  free (src);
}


/* Try to extract an integer constant from the passed expression node.
   Return true if some error occurred, false on success.  If REPORT_ERROR
   is non-zero, emit error, for positive REPORT_ERROR using gfc_error,
   for negative using gfc_error_now.  */

bool
gfc_extract_int (gfc_expr *expr, int *result, int report_error)
{
  gfc_ref *ref;

  /* A KIND component is a parameter too. The expression for it
     is stored in the initializer and should be consistent with
     the tests below.  */
  if (gfc_expr_attr(expr).pdt_kind)
    {
      for (ref = expr->ref; ref; ref = ref->next)
	{
	   if (ref->u.c.component->attr.pdt_kind)
	     expr = ref->u.c.component->initializer;
	}
    }

  if (expr->expr_type != EXPR_CONSTANT)
    {
      if (report_error > 0)
	gfc_error ("Constant expression required at %C");
      else if (report_error < 0)
	gfc_error_now ("Constant expression required at %C");
      return true;
    }

  if (expr->ts.type != BT_INTEGER)
    {
      if (report_error > 0)
	gfc_error ("Integer expression required at %C");
      else if (report_error < 0)
	gfc_error_now ("Integer expression required at %C");
      return true;
    }

  if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
      || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
    {
      if (report_error > 0)
	gfc_error ("Integer value too large in expression at %C");
      else if (report_error < 0)
	gfc_error_now ("Integer value too large in expression at %C");
      return true;
    }

  *result = (int) mpz_get_si (expr->value.integer);

  return false;
}


/* Same as gfc_extract_int, but use a HWI.  */

bool
gfc_extract_hwi (gfc_expr *expr, HOST_WIDE_INT *result, int report_error)
{
  gfc_ref *ref;

  /* A KIND component is a parameter too. The expression for it is
     stored in the initializer and should be consistent with the tests
     below.  */
  if (gfc_expr_attr(expr).pdt_kind)
    {
      for (ref = expr->ref; ref; ref = ref->next)
	{
	  if (ref->u.c.component->attr.pdt_kind)
	    expr = ref->u.c.component->initializer;
	}
    }

  if (expr->expr_type != EXPR_CONSTANT)
    {
      if (report_error > 0)
	gfc_error ("Constant expression required at %C");
      else if (report_error < 0)
	gfc_error_now ("Constant expression required at %C");
      return true;
    }

  if (expr->ts.type != BT_INTEGER)
    {
      if (report_error > 0)
	gfc_error ("Integer expression required at %C");
      else if (report_error < 0)
	gfc_error_now ("Integer expression required at %C");
      return true;
    }

  /* Use long_long_integer_type_node to determine when to saturate.  */
  const wide_int val = wi::from_mpz (long_long_integer_type_node,
				     expr->value.integer, false);

  if (!wi::fits_shwi_p (val))
    {
      if (report_error > 0)
	gfc_error ("Integer value too large in expression at %C");
      else if (report_error < 0)
	gfc_error_now ("Integer value too large in expression at %C");
      return true;
    }

  *result = val.to_shwi ();

  return false;
}


/* Recursively copy a list of reference structures.  */

gfc_ref *
gfc_copy_ref (gfc_ref *src)
{
  gfc_array_ref *ar;
  gfc_ref *dest;

  if (src == NULL)
    return NULL;

  dest = gfc_get_ref ();
  dest->type = src->type;

  switch (src->type)
    {
    case REF_ARRAY:
      ar = gfc_copy_array_ref (&src->u.ar);
      dest->u.ar = *ar;
      free (ar);
      break;

    case REF_COMPONENT:
      dest->u.c = src->u.c;
      break;

    case REF_INQUIRY:
      dest->u.i = src->u.i;
      break;

    case REF_SUBSTRING:
      dest->u.ss = src->u.ss;
      dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
      dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
      break;
    }

  dest->next = gfc_copy_ref (src->next);

  return dest;
}


/* Detect whether an expression has any vector index array references.  */

int
gfc_has_vector_index (gfc_expr *e)
{
  gfc_ref *ref;
  int i;
  for (ref = e->ref; ref; ref = ref->next)
    if (ref->type == REF_ARRAY)
      for (i = 0; i < ref->u.ar.dimen; i++)
	if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
	  return 1;
  return 0;
}


/* Copy a shape array.  */

mpz_t *
gfc_copy_shape (mpz_t *shape, int rank)
{
  mpz_t *new_shape;
  int n;

  if (shape == NULL)
    return NULL;

  new_shape = gfc_get_shape (rank);

  for (n = 0; n < rank; n++)
    mpz_init_set (new_shape[n], shape[n]);

  return new_shape;
}


/* Copy a shape array excluding dimension N, where N is an integer
   constant expression.  Dimensions are numbered in Fortran style --
   starting with ONE.

   So, if the original shape array contains R elements
      { s1 ... sN-1  sN  sN+1 ... sR-1 sR}
   the result contains R-1 elements:
      { s1 ... sN-1  sN+1    ...  sR-1}

   If anything goes wrong -- N is not a constant, its value is out
   of range -- or anything else, just returns NULL.  */

mpz_t *
gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
{
  mpz_t *new_shape, *s;
  int i, n;

  if (shape == NULL
      || rank <= 1
      || dim == NULL
      || dim->expr_type != EXPR_CONSTANT
      || dim->ts.type != BT_INTEGER)
    return NULL;

  n = mpz_get_si (dim->value.integer);
  n--; /* Convert to zero based index.  */
  if (n < 0 || n >= rank)
    return NULL;

  s = new_shape = gfc_get_shape (rank - 1);

  for (i = 0; i < rank; i++)
    {
      if (i == n)
	continue;
      mpz_init_set (*s, shape[i]);
      s++;
    }

  return new_shape;
}


/* Return the maximum kind of two expressions.  In general, higher
   kind numbers mean more precision for numeric types.  */

int
gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
{
  return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
}


/* Returns nonzero if the type is numeric, zero otherwise.  */

static int
numeric_type (bt type)
{
  return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
}


/* Returns nonzero if the typespec is a numeric type, zero otherwise.  */

int
gfc_numeric_ts (gfc_typespec *ts)
{
  return numeric_type (ts->type);
}


/* Return an expression node with an optional argument list attached.
   A variable number of gfc_expr pointers are strung together in an
   argument list with a NULL pointer terminating the list.  */

gfc_expr *
gfc_build_conversion (gfc_expr *e)
{
  gfc_expr *p;

  p = gfc_get_expr ();
  p->expr_type = EXPR_FUNCTION;
  p->symtree = NULL;
  p->value.function.actual = gfc_get_actual_arglist ();
  p->value.function.actual->expr = e;

  return p;
}


/* Given an expression node with some sort of numeric binary
   expression, insert type conversions required to make the operands
   have the same type. Conversion warnings are disabled if wconversion
   is set to 0.

   The exception is that the operands of an exponential don't have to
   have the same type.  If possible, the base is promoted to the type
   of the exponent.  For example, 1**2.3 becomes 1.0**2.3, but
   1.0**2 stays as it is.  */

void
gfc_type_convert_binary (gfc_expr *e, int wconversion)
{
  gfc_expr *op1, *op2;

  op1 = e->value.op.op1;
  op2 = e->value.op.op2;

  if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
    {
      gfc_clear_ts (&e->ts);
      return;
    }

  /* Kind conversions of same type.  */
  if (op1->ts.type == op2->ts.type)
    {
      if (op1->ts.kind == op2->ts.kind)
	{
	  /* No type conversions.  */
	  e->ts = op1->ts;
	  goto done;
	}

      if (op1->ts.kind > op2->ts.kind)
	gfc_convert_type_warn (op2, &op1->ts, 2, wconversion);
      else
	gfc_convert_type_warn (op1, &op2->ts, 2, wconversion);

      e->ts = op1->ts;
      goto done;
    }

  /* Integer combined with real or complex.  */
  if (op2->ts.type == BT_INTEGER)
    {
      e->ts = op1->ts;

      /* Special case for ** operator.  */
      if (e->value.op.op == INTRINSIC_POWER)
	goto done;

      gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
      goto done;
    }

  if (op1->ts.type == BT_INTEGER)
    {
      e->ts = op2->ts;
      gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
      goto done;
    }

  /* Real combined with complex.  */
  e->ts.type = BT_COMPLEX;
  if (op1->ts.kind > op2->ts.kind)
    e->ts.kind = op1->ts.kind;
  else
    e->ts.kind = op2->ts.kind;
  if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
    gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
  if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
    gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);

done:
  return;
}


/* Determine if an expression is constant in the sense of F08:7.1.12.
 * This function expects that the expression has already been simplified.  */

bool
gfc_is_constant_expr (gfc_expr *e)
{
  gfc_constructor *c;
  gfc_actual_arglist *arg;

  if (e == NULL)
    return true;

  switch (e->expr_type)
    {
    case EXPR_OP:
      return (gfc_is_constant_expr (e->value.op.op1)
	      && (e->value.op.op2 == NULL
		  || gfc_is_constant_expr (e->value.op.op2)));

    case EXPR_VARIABLE:
      /* The only context in which this can occur is in a parameterized
	 derived type declaration, so returning true is OK.  */
      if (e->symtree->n.sym->attr.pdt_len
	  || e->symtree->n.sym->attr.pdt_kind)
        return true;
      return false;

    case EXPR_FUNCTION:
    case EXPR_PPC:
    case EXPR_COMPCALL:
      gcc_assert (e->symtree || e->value.function.esym
		  || e->value.function.isym);

      /* Call to intrinsic with at least one argument.  */
      if (e->value.function.isym && e->value.function.actual)
	{
	  for (arg = e->value.function.actual; arg; arg = arg->next)
	    if (!gfc_is_constant_expr (arg->expr))
	      return false;
	}

      if (e->value.function.isym
	  && (e->value.function.isym->elemental
	      || e->value.function.isym->pure
	      || e->value.function.isym->inquiry
	      || e->value.function.isym->transformational))
	return true;

      return false;

    case EXPR_CONSTANT:
    case EXPR_NULL:
      return true;

    case EXPR_SUBSTRING:
      return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
				&& gfc_is_constant_expr (e->ref->u.ss.end));

    case EXPR_ARRAY:
    case EXPR_STRUCTURE:
      c = gfc_constructor_first (e->value.constructor);
      if ((e->expr_type == EXPR_ARRAY) && c && c->iterator)
        return gfc_constant_ac (e);

      for (; c; c = gfc_constructor_next (c))
	if (!gfc_is_constant_expr (c->expr))
	  return false;

      return true;


    default:
      gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
      return false;
    }
}


/* Is true if the expression or symbol is a passed CFI descriptor.  */
bool
is_CFI_desc (gfc_symbol *sym, gfc_expr *e)
{
  if (sym == NULL
      && e && e->expr_type == EXPR_VARIABLE)
    sym = e->symtree->n.sym;

  if (sym && sym->attr.dummy
      && sym->ns->proc_name->attr.is_bind_c
      && sym->attr.dimension
      && (sym->attr.pointer
	  || sym->attr.allocatable
	  || sym->as->type == AS_ASSUMED_SHAPE
	  || sym->as->type == AS_ASSUMED_RANK))
    return true;

return false;
}


/* Is true if an array reference is followed by a component or substring
   reference.  */
bool
is_subref_array (gfc_expr * e)
{
  gfc_ref * ref;
  bool seen_array;
  gfc_symbol *sym;

  if (e->expr_type != EXPR_VARIABLE)
    return false;

  sym = e->symtree->n.sym;

  if (sym->attr.subref_array_pointer)
    return true;

  seen_array = false;

  for (ref = e->ref; ref; ref = ref->next)
    {
      /* If we haven't seen the array reference and this is an intrinsic,
	 what follows cannot be a subreference array, unless there is a
	 substring reference.  */
      if (!seen_array && ref->type == REF_COMPONENT
	  && ref->u.c.component->ts.type != BT_CHARACTER
	  && ref->u.c.component->ts.type != BT_CLASS
	  && !gfc_bt_struct (ref->u.c.component->ts.type))
	return false;

      if (ref->type == REF_ARRAY
	    && ref->u.ar.type != AR_ELEMENT)
	seen_array = true;

      if (seen_array
	    && ref->type != REF_ARRAY)
	return seen_array;
    }

  if (sym->ts.type == BT_CLASS
      && sym->attr.dummy
      && CLASS_DATA (sym)->attr.dimension
      && CLASS_DATA (sym)->attr.class_pointer)
    return true;

  return false;
}


/* Try to collapse intrinsic expressions.  */

static bool
simplify_intrinsic_op (gfc_expr *p, int type)
{
  gfc_intrinsic_op op;
  gfc_expr *op1, *op2, *result;

  if (p->value.op.op == INTRINSIC_USER)
    return true;

  op1 = p->value.op.op1;
  op2 = p->value.op.op2;
  op  = p->value.op.op;

  if (!gfc_simplify_expr (op1, type))
    return false;
  if (!gfc_simplify_expr (op2, type))
    return false;

  if (!gfc_is_constant_expr (op1)
      || (op2 != NULL && !gfc_is_constant_expr (op2)))
    return true;

  /* Rip p apart.  */
  p->value.op.op1 = NULL;
  p->value.op.op2 = NULL;

  switch (op)
    {
    case INTRINSIC_PARENTHESES:
      result = gfc_parentheses (op1);
      break;

    case INTRINSIC_UPLUS:
      result = gfc_uplus (op1);
      break;

    case INTRINSIC_UMINUS:
      result = gfc_uminus (op1);
      break;

    case INTRINSIC_PLUS:
      result = gfc_add (op1, op2);
      break;

    case INTRINSIC_MINUS:
      result = gfc_subtract (op1, op2);
      break;

    case INTRINSIC_TIMES:
      result = gfc_multiply (op1, op2);
      break;

    case INTRINSIC_DIVIDE:
      result = gfc_divide (op1, op2);
      break;

    case INTRINSIC_POWER:
      result = gfc_power (op1, op2);
      break;

    case INTRINSIC_CONCAT:
      result = gfc_concat (op1, op2);
      break;

    case INTRINSIC_EQ:
    case INTRINSIC_EQ_OS:
      result = gfc_eq (op1, op2, op);
      break;

    case INTRINSIC_NE:
    case INTRINSIC_NE_OS:
      result = gfc_ne (op1, op2, op);
      break;

    case INTRINSIC_GT:
    case INTRINSIC_GT_OS:
      result = gfc_gt (op1, op2, op);
      break;

    case INTRINSIC_GE:
    case INTRINSIC_GE_OS:
      result = gfc_ge (op1, op2, op);
      break;

    case INTRINSIC_LT:
    case INTRINSIC_LT_OS:
      result = gfc_lt (op1, op2, op);
      break;

    case INTRINSIC_LE:
    case INTRINSIC_LE_OS:
      result = gfc_le (op1, op2, op);
      break;

    case INTRINSIC_NOT:
      result = gfc_not (op1);
      break;

    case INTRINSIC_AND:
      result = gfc_and (op1, op2);
      break;

    case INTRINSIC_OR:
      result = gfc_or (op1, op2);
      break;

    case INTRINSIC_EQV:
      result = gfc_eqv (op1, op2);
      break;

    case INTRINSIC_NEQV:
      result = gfc_neqv (op1, op2);
      break;

    default:
      gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
    }

  if (result == NULL)
    {
      gfc_free_expr (op1);
      gfc_free_expr (op2);
      return false;
    }

  result->rank = p->rank;
  result->where = p->where;
  gfc_replace_expr (p, result);

  return true;
}


/* Subroutine to simplify constructor expressions.  Mutually recursive
   with gfc_simplify_expr().  */

static bool
simplify_constructor (gfc_constructor_base base, int type)
{
  gfc_constructor *c;
  gfc_expr *p;

  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
    {
      if (c->iterator
	  && (!gfc_simplify_expr(c->iterator->start, type)
	      || !gfc_simplify_expr (c->iterator->end, type)
	      || !gfc_simplify_expr (c->iterator->step, type)))
	return false;

      if (c->expr)
	{
	  /* Try and simplify a copy.  Replace the original if successful
	     but keep going through the constructor at all costs.  Not
	     doing so can make a dog's dinner of complicated things.  */
	  p = gfc_copy_expr (c->expr);

	  if (!gfc_simplify_expr (p, type))
	    {
	      gfc_free_expr (p);
	      continue;
	    }

	  gfc_replace_expr (c->expr, p);
	}
    }

  return true;
}


/* Pull a single array element out of an array constructor.  */

static bool
find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
		    gfc_constructor **rval)
{
  unsigned long nelemen;
  int i;
  mpz_t delta;
  mpz_t offset;
  mpz_t span;
  mpz_t tmp;
  gfc_constructor *cons;
  gfc_expr *e;
  bool t;

  t = true;
  e = NULL;

  mpz_init_set_ui (offset, 0);
  mpz_init (delta);
  mpz_init (tmp);
  mpz_init_set_ui (span, 1);
  for (i = 0; i < ar->dimen; i++)
    {
      if (!gfc_reduce_init_expr (ar->as->lower[i])
	  || !gfc_reduce_init_expr (ar->as->upper[i]))
	{
	  t = false;
	  cons = NULL;
	  goto depart;
	}

      e = ar->start[i];
      if (e->expr_type != EXPR_CONSTANT)
	{
	  cons = NULL;
	  goto depart;
	}

      gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
		  && ar->as->lower[i]->expr_type == EXPR_CONSTANT);

      /* Check the bounds.  */
      if ((ar->as->upper[i]
	   && mpz_cmp (e->value.integer,
		       ar->as->upper[i]->value.integer) > 0)
	  || (mpz_cmp (e->value.integer,
		       ar->as->lower[i]->value.integer) < 0))
	{
	  gfc_error ("Index in dimension %d is out of bounds "
		     "at %L", i + 1, &ar->c_where[i]);
	  cons = NULL;
	  t = false;
	  goto depart;
	}

      mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
      mpz_mul (delta, delta, span);
      mpz_add (offset, offset, delta);

      mpz_set_ui (tmp, 1);
      mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
      mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
      mpz_mul (span, span, tmp);
    }

  for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset);
       cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
    {
      if (cons->iterator)
	{
	  cons = NULL;
	  goto depart;
	}
    }

depart:
  mpz_clear (delta);
  mpz_clear (offset);
  mpz_clear (span);
  mpz_clear (tmp);
  *rval = cons;
  return t;
}


/* Find a component of a structure constructor.  */

static gfc_constructor *
find_component_ref (gfc_constructor_base base, gfc_ref *ref)
{
  gfc_component *pick = ref->u.c.component;
  gfc_constructor *c = gfc_constructor_first (base);

  gfc_symbol *dt = ref->u.c.sym;
  int ext = dt->attr.extension;

  /* For extended types, check if the desired component is in one of the
   * parent types.  */
  while (ext > 0 && gfc_find_component (dt->components->ts.u.derived,
					pick->name, true, true, NULL))
    {
      dt = dt->components->ts.u.derived;
      c = gfc_constructor_first (c->expr->value.constructor);
      ext--;
    }

  gfc_component *comp = dt->components;
  while (comp != pick)
    {
      comp = comp->next;
      c = gfc_constructor_next (c);
    }

  return c;
}


/* Replace an expression with the contents of a constructor, removing
   the subobject reference in the process.  */

static void
remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
{
  gfc_expr *e;

  if (cons)
    {
      e = cons->expr;
      cons->expr = NULL;
    }
  else
    e = gfc_copy_expr (p);
  e->ref = p->ref->next;
  p->ref->next =  NULL;
  gfc_replace_expr (p, e);
}


/* Pull an array section out of an array constructor.  */

static bool
find_array_section (gfc_expr *expr, gfc_ref *ref)
{
  int idx;
  int rank;
  int d;
  int shape_i;
  int limit;
  long unsigned one = 1;
  bool incr_ctr;
  mpz_t start[GFC_MAX_DIMENSIONS];
  mpz_t end[GFC_MAX_DIMENSIONS];
  mpz_t stride[GFC_MAX_DIMENSIONS];
  mpz_t delta[GFC_MAX_DIMENSIONS];
  mpz_t ctr[GFC_MAX_DIMENSIONS];
  mpz_t delta_mpz;
  mpz_t tmp_mpz;
  mpz_t nelts;
  mpz_t ptr;
  gfc_constructor_base base;
  gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS];
  gfc_expr *begin;
  gfc_expr *finish;
  gfc_expr *step;
  gfc_expr *upper;
  gfc_expr *lower;
  bool t;

  t = true;

  base = expr->value.constructor;
  expr->value.constructor = NULL;

  rank = ref->u.ar.as->rank;

  if (expr->shape == NULL)
    expr->shape = gfc_get_shape (rank);

  mpz_init_set_ui (delta_mpz, one);
  mpz_init_set_ui (nelts, one);
  mpz_init (tmp_mpz);

  /* Do the initialization now, so that we can cleanup without
     keeping track of where we were.  */
  for (d = 0; d < rank; d++)
    {
      mpz_init (delta[d]);
      mpz_init (start[d]);
      mpz_init (end[d]);
      mpz_init (ctr[d]);
      mpz_init (stride[d]);
      vecsub[d] = NULL;
    }

  /* Build the counters to clock through the array reference.  */
  shape_i = 0;
  for (d = 0; d < rank; d++)
    {
      /* Make this stretch of code easier on the eye!  */
      begin = ref->u.ar.start[d];
      finish = ref->u.ar.end[d];
      step = ref->u.ar.stride[d];
      lower = ref->u.ar.as->lower[d];
      upper = ref->u.ar.as->upper[d];

      if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR)  /* Vector subscript.  */
	{
	  gfc_constructor *ci;
	  gcc_assert (begin);

	  if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
	    {
	      t = false;
	      goto cleanup;
	    }

	  gcc_assert (begin->rank == 1);
	  /* Zero-sized arrays have no shape and no elements, stop early.  */
	  if (!begin->shape)
	    {
	      mpz_init_set_ui (nelts, 0);
	      break;
	    }

	  vecsub[d] = gfc_constructor_first (begin->value.constructor);
	  mpz_set (ctr[d], vecsub[d]->expr->value.integer);
	  mpz_mul (nelts, nelts, begin->shape[0]);
	  mpz_set (expr->shape[shape_i++], begin->shape[0]);

	  /* Check bounds.  */
	  for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci))
	    {
	      if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
		  || mpz_cmp (ci->expr->value.integer,
			      lower->value.integer) < 0)
		{
		  gfc_error ("index in dimension %d is out of bounds "
			     "at %L", d + 1, &ref->u.ar.c_where[d]);
		  t = false;
		  goto cleanup;
		}
	    }
	}
      else
	{
	  if ((begin && begin->expr_type != EXPR_CONSTANT)
	      || (finish && finish->expr_type != EXPR_CONSTANT)
	      || (step && step->expr_type != EXPR_CONSTANT))
	    {
	      t = false;
	      goto cleanup;
	    }

	  /* Obtain the stride.  */
	  if (step)
	    mpz_set (stride[d], step->value.integer);
	  else
	    mpz_set_ui (stride[d], one);

	  if (mpz_cmp_ui (stride[d], 0) == 0)
	    mpz_set_ui (stride[d], one);

	  /* Obtain the start value for the index.  */
	  if (begin)
	    mpz_set (start[d], begin->value.integer);
	  else
	    mpz_set (start[d], lower->value.integer);

	  mpz_set (ctr[d], start[d]);

	  /* Obtain the end value for the index.  */
	  if (finish)
	    mpz_set (end[d], finish->value.integer);
	  else
	    mpz_set (end[d], upper->value.integer);

	  /* Separate 'if' because elements sometimes arrive with
	     non-null end.  */
	  if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
	    mpz_set (end [d], begin->value.integer);

	  /* Check the bounds.  */
	  if (mpz_cmp (ctr[d], upper->value.integer) > 0
	      || mpz_cmp (end[d], upper->value.integer) > 0
	      || mpz_cmp (ctr[d], lower->value.integer) < 0
	      || mpz_cmp (end[d], lower->value.integer) < 0)
	    {
	      gfc_error ("index in dimension %d is out of bounds "
			 "at %L", d + 1, &ref->u.ar.c_where[d]);
	      t = false;
	      goto cleanup;
	    }

	  /* Calculate the number of elements and the shape.  */
	  mpz_set (tmp_mpz, stride[d]);
	  mpz_add (tmp_mpz, end[d], tmp_mpz);
	  mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
	  mpz_div (tmp_mpz, tmp_mpz, stride[d]);
	  mpz_mul (nelts, nelts, tmp_mpz);

	  /* An element reference reduces the rank of the expression; don't
	     add anything to the shape array.  */
	  if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
	    mpz_set (expr->shape[shape_i++], tmp_mpz);
	}

      /* Calculate the 'stride' (=delta) for conversion of the
	 counter values into the index along the constructor.  */
      mpz_set (delta[d], delta_mpz);
      mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
      mpz_add_ui (tmp_mpz, tmp_mpz, one);
      mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
    }

  mpz_init (ptr);
  cons = gfc_constructor_first (base);

  /* Now clock through the array reference, calculating the index in
     the source constructor and transferring the elements to the new
     constructor.  */
  for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
    {
      mpz_init_set_ui (ptr, 0);

      incr_ctr = true;
      for (d = 0; d < rank; d++)
	{
	  mpz_set (tmp_mpz, ctr[d]);
	  mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
	  mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
	  mpz_add (ptr, ptr, tmp_mpz);

	  if (!incr_ctr) continue;

	  if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript.  */
	    {
	      gcc_assert(vecsub[d]);

	      if (!gfc_constructor_next (vecsub[d]))
		vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor);
	      else
		{
		  vecsub[d] = gfc_constructor_next (vecsub[d]);
		  incr_ctr = false;
		}
	      mpz_set (ctr[d], vecsub[d]->expr->value.integer);
	    }
	  else
	    {
	      mpz_add (ctr[d], ctr[d], stride[d]);

	      if (mpz_cmp_ui (stride[d], 0) > 0
		  ? mpz_cmp (ctr[d], end[d]) > 0
		  : mpz_cmp (ctr[d], end[d]) < 0)
		mpz_set (ctr[d], start[d]);
	      else
		incr_ctr = false;
	    }
	}

      limit = mpz_get_ui (ptr);
      if (limit >= flag_max_array_constructor)
        {
	  gfc_error ("The number of elements in the array constructor "
		     "at %L requires an increase of the allowed %d "
		     "upper limit.  See %<-fmax-array-constructor%> "
		     "option", &expr->where, flag_max_array_constructor);
	  return false;
	}

      cons = gfc_constructor_lookup (base, limit);
      gcc_assert (cons);
      gfc_constructor_append_expr (&expr->value.constructor,
				   gfc_copy_expr (cons->expr), NULL);
    }

  mpz_clear (ptr);

cleanup:

  mpz_clear (delta_mpz);
  mpz_clear (tmp_mpz);
  mpz_clear (nelts);
  for (d = 0; d < rank; d++)
    {
      mpz_clear (delta[d]);
      mpz_clear (start[d]);
      mpz_clear (end[d]);
      mpz_clear (ctr[d]);
      mpz_clear (stride[d]);
    }
  gfc_constructor_free (base);
  return t;
}

/* Pull a substring out of an expression.  */

static bool
find_substring_ref (gfc_expr *p, gfc_expr **newp)
{
  gfc_charlen_t end;
  gfc_charlen_t start;
  gfc_charlen_t length;
  gfc_char_t *chr;

  if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
      || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
    return false;

  *newp = gfc_copy_expr (p);
  free ((*newp)->value.character.string);

  end = (gfc_charlen_t) mpz_get_ui (p->ref->u.ss.end->value.integer);
  start = (gfc_charlen_t) mpz_get_ui (p->ref->u.ss.start->value.integer);
  if (end >= start)
    length = end - start + 1;
  else
    length = 0;

  chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
  (*newp)->value.character.length = length;
  memcpy (chr, &p->value.character.string[start - 1],
	  length * sizeof (gfc_char_t));
  chr[length] = '\0';
  return true;
}


/* Pull an inquiry result out of an expression.  */

static bool
find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
{
  gfc_ref *ref;
  gfc_ref *inquiry = NULL;
  gfc_expr *tmp;

  tmp = gfc_copy_expr (p);

  if (tmp->ref && tmp->ref->type == REF_INQUIRY)
    {
      inquiry = tmp->ref;
      tmp->ref = NULL;
    }
  else
    {
      for (ref = tmp->ref; ref; ref = ref->next)
	if (ref->next && ref->next->type == REF_INQUIRY)
	  {
	    inquiry = ref->next;
	    ref->next = NULL;
	  }
    }

  if (!inquiry)
    {
      gfc_free_expr (tmp);
      return false;
    }

  gfc_resolve_expr (tmp);

  /* In principle there can be more than one inquiry reference.  */
  for (; inquiry; inquiry = inquiry->next)
    {
      switch (inquiry->u.i)
	{
	case INQUIRY_LEN:
	  if (tmp->ts.type != BT_CHARACTER)
	    goto cleanup;

	  if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
	    goto cleanup;

	  if (tmp->ts.u.cl->length
	      && tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT)
	    *newp = gfc_copy_expr (tmp->ts.u.cl->length);
	  else if (tmp->expr_type == EXPR_CONSTANT)
	    *newp = gfc_get_int_expr (gfc_default_integer_kind,
				      NULL, tmp->value.character.length);
	  else
	    goto cleanup;

	  break;

	case INQUIRY_KIND:
	  if (tmp->ts.type == BT_DERIVED || tmp->ts.type == BT_CLASS)
	    goto cleanup;

	  if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C"))
	    goto cleanup;

	  *newp = gfc_get_int_expr (gfc_default_integer_kind,
				    NULL, tmp->ts.kind);
	  break;

	case INQUIRY_RE:
	  if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT)
	    goto cleanup;

	  if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C"))
	    goto cleanup;

	  *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
	  mpfr_set ((*newp)->value.real,
		    mpc_realref (tmp->value.complex), GFC_RND_MODE);
	  break;

	case INQUIRY_IM:
	  if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT)
	    goto cleanup;

	  if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C"))
	    goto cleanup;

	  *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
	  mpfr_set ((*newp)->value.real,
		    mpc_imagref (tmp->value.complex), GFC_RND_MODE);
	  break;
	}
      tmp = gfc_copy_expr (*newp);
    }

  if (!(*newp))
    goto cleanup;
  else if ((*newp)->expr_type != EXPR_CONSTANT)
    {
      gfc_free_expr (*newp);
      goto cleanup;
    }

  gfc_free_expr (tmp);
  return true;

cleanup:
  gfc_free_expr (tmp);
  return false;
}



/* Simplify a subobject reference of a constructor.  This occurs when
   parameter variable values are substituted.  */

static bool
simplify_const_ref (gfc_expr *p)
{
  gfc_constructor *cons, *c;
  gfc_expr *newp = NULL;
  gfc_ref *last_ref;

  while (p->ref)
    {
      switch (p->ref->type)
	{
	case REF_ARRAY:
	  switch (p->ref->u.ar.type)
	    {
	    case AR_ELEMENT:
	      /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
		 will generate this.  */
	      if (p->expr_type != EXPR_ARRAY)
		{
		  remove_subobject_ref (p, NULL);
		  break;
		}
	      if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons))
		return false;

	      if (!cons)
		return true;

	      remove_subobject_ref (p, cons);
	      break;

	    case AR_SECTION:
	      if (!find_array_section (p, p->ref))
		return false;
	      p->ref->u.ar.type = AR_FULL;

	    /* Fall through.  */

	    case AR_FULL:
	      if (p->ref->next != NULL
		  && (p->ts.type == BT_CHARACTER || gfc_bt_struct (p->ts.type)))
		{
		  for (c = gfc_constructor_first (p->value.constructor);
		       c; c = gfc_constructor_next (c))
		    {
		      c->expr->ref = gfc_copy_ref (p->ref->next);
		      if (!simplify_const_ref (c->expr))
			return false;
		    }

		  if (gfc_bt_struct (p->ts.type)
			&& p->ref->next
			&& (c = gfc_constructor_first (p->value.constructor)))
		    {
		      /* There may have been component references.  */
		      p->ts = c->expr->ts;
		    }

		  last_ref = p->ref;
		  for (; last_ref->next; last_ref = last_ref->next) {};

		  if (p->ts.type == BT_CHARACTER
			&& last_ref->type == REF_SUBSTRING)
		    {
		      /* If this is a CHARACTER array and we possibly took
			 a substring out of it, update the type-spec's
			 character length according to the first element
			 (as all should have the same length).  */
		      gfc_charlen_t string_len;
		      if ((c = gfc_constructor_first (p->value.constructor)))
			{
			  const gfc_expr* first = c->expr;
			  gcc_assert (first->expr_type == EXPR_CONSTANT);
			  gcc_assert (first->ts.type == BT_CHARACTER);
			  string_len = first->value.character.length;
			}
		      else
			string_len = 0;

		      if (!p->ts.u.cl)
			{
			  if (p->symtree)
			    p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
							  NULL);
			  else
			    p->ts.u.cl = gfc_new_charlen (gfc_current_ns,
							  NULL);
			}
		      else
			gfc_free_expr (p->ts.u.cl->length);

		      p->ts.u.cl->length
			= gfc_get_int_expr (gfc_charlen_int_kind,
					    NULL, string_len);
		    }
		}
	      gfc_free_ref_list (p->ref);
	      p->ref = NULL;
	      break;

	    default:
	      return true;
	    }

	  break;

	case REF_COMPONENT:
	  cons = find_component_ref (p->value.constructor, p->ref);
	  remove_subobject_ref (p, cons);
	  break;

	case REF_INQUIRY:
	  if (!find_inquiry_ref (p, &newp))
	    return false;

	  gfc_replace_expr (p, newp);
	  gfc_free_ref_list (p->ref);
	  p->ref = NULL;
	  break;

	case REF_SUBSTRING:
	  if (!find_substring_ref (p, &newp))
	    return false;

	  gfc_replace_expr (p, newp);
	  gfc_free_ref_list (p->ref);
	  p->ref = NULL;
	  break;
	}
    }

  return true;
}


/* Simplify a chain of references.  */

static bool
simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p)
{
  int n;
  gfc_expr *newp;

  for (; ref; ref = ref->next)
    {
      switch (ref->type)
	{
	case REF_ARRAY:
	  for (n = 0; n < ref->u.ar.dimen; n++)
	    {
	      if (!gfc_simplify_expr (ref->u.ar.start[n], type))
		return false;
	      if (!gfc_simplify_expr (ref->u.ar.end[n], type))
		return false;
	      if (!gfc_simplify_expr (ref->u.ar.stride[n], type))
		return false;
	    }
	  break;

	case REF_SUBSTRING:
	  if (!gfc_simplify_expr (ref->u.ss.start, type))
	    return false;
	  if (!gfc_simplify_expr (ref->u.ss.end, type))
	    return false;
	  break;

	case REF_INQUIRY:
	  if (!find_inquiry_ref (*p, &newp))
	    return false;

	  gfc_replace_expr (*p, newp);
	  gfc_free_ref_list ((*p)->ref);
	  (*p)->ref = NULL;
	  return true;

	default:
	  break;
	}
    }
  return true;
}


/* Try to substitute the value of a parameter variable.  */

static bool
simplify_parameter_variable (gfc_expr *p, int type)
{
  gfc_expr *e;
  bool t;

  if (gfc_is_size_zero_array (p))
    {
      if (p->expr_type == EXPR_ARRAY)
	return true;

      e = gfc_get_expr ();
      e->expr_type = EXPR_ARRAY;
      e->ts = p->ts;
      e->rank = p->rank;
      e->value.constructor = NULL;
      e->shape = gfc_copy_shape (p->shape, p->rank);
      e->where = p->where;
      gfc_replace_expr (p, e);
      return true;
    }

  e = gfc_copy_expr (p->symtree->n.sym->value);
  if (e == NULL)
    return false;

  e->rank = p->rank;

  /* Do not copy subobject refs for constant.  */
  if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
    e->ref = gfc_copy_ref (p->ref);
  t = gfc_simplify_expr (e, type);

  /* Only use the simplification if it eliminated all subobject references.  */
  if (t && !e->ref)
    gfc_replace_expr (p, e);
  else
    gfc_free_expr (e);

  return t;
}


static bool
scalarize_intrinsic_call (gfc_expr *, bool init_flag);

/* Given an expression, simplify it by collapsing constant
   expressions.  Most simplification takes place when the expression
   tree is being constructed.  If an intrinsic function is simplified
   at some point, we get called again to collapse the result against
   other constants.

   We work by recursively simplifying expression nodes, simplifying
   intrinsic functions where possible, which can lead to further
   constant collapsing.  If an operator has constant operand(s), we
   rip the expression apart, and rebuild it, hoping that it becomes
   something simpler.

   The expression type is defined for:
     0   Basic expression parsing
     1   Simplifying array constructors -- will substitute
	 iterator values.
   Returns false on error, true otherwise.
   NOTE: Will return true even if the expression cannot be simplified.  */

bool
gfc_simplify_expr (gfc_expr *p, int type)
{
  gfc_actual_arglist *ap;
  gfc_intrinsic_sym* isym = NULL;


  if (p == NULL)
    return true;

  switch (p->expr_type)
    {
    case EXPR_CONSTANT:
      if (p->ref && p->ref->type == REF_INQUIRY)
	simplify_ref_chain (p->ref, type, &p);
      break;
    case EXPR_NULL:
      break;

    case EXPR_FUNCTION:
      // For array-bound functions, we don't need to optimize
      // the 'array' argument. In particular, if the argument
      // is a PARAMETER, simplifying might convert an EXPR_VARIABLE
      // into an EXPR_ARRAY; the latter has lbound = 1, the former
      // can have any lbound.
      ap = p->value.function.actual;
      if (p->value.function.isym &&
	  (p->value.function.isym->id == GFC_ISYM_LBOUND
	   || p->value.function.isym->id == GFC_ISYM_UBOUND
	   || p->value.function.isym->id == GFC_ISYM_LCOBOUND
	   || p->value.function.isym->id == GFC_ISYM_UCOBOUND))
	ap = ap->next;

      for ( ; ap; ap = ap->next)
	if (!gfc_simplify_expr (ap->expr, type))
	  return false;

      if (p->value.function.isym != NULL
	  && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
	return false;

      if (p->expr_type == EXPR_FUNCTION)
	{
	  if (p->symtree)
	    isym = gfc_find_function (p->symtree->n.sym->name);
	  if (isym && isym->elemental)
	    scalarize_intrinsic_call (p, false);
	}

      break;

    case EXPR_SUBSTRING:
      if (!simplify_ref_chain (p->ref, type, &p))
	return false;

      if (gfc_is_constant_expr (p))
	{
	  gfc_char_t *s;
	  HOST_WIDE_INT start, end;

	  start = 0;
	  if (p->ref && p->ref->u.ss.start)
	    {
	      gfc_extract_hwi (p->ref->u.ss.start, &start);
	      start--;  /* Convert from one-based to zero-based.  */
	    }

	  end = p->value.character.length;
	  if (p->ref && p->ref->u.ss.end)
	    gfc_extract_hwi (p->ref->u.ss.end, &end);

	  if (end < start)
	    end = start;

	  s = gfc_get_wide_string (end - start + 2);
	  memcpy (s, p->value.character.string + start,
		  (end - start) * sizeof (gfc_char_t));
	  s[end - start + 1] = '\0';  /* TODO: C-style string.  */
	  free (p->value.character.string);
	  p->value.character.string = s;
	  p->value.character.length = end - start;
	  p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
	  p->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
						 NULL,
						 p->value.character.length);
	  gfc_free_ref_list (p->ref);
	  p->ref = NULL;
	  p->expr_type = EXPR_CONSTANT;
	}
      break;

    case EXPR_OP:
      if (!simplify_intrinsic_op (p, type))
	return false;
      break;

    case EXPR_VARIABLE:
      /* Only substitute array parameter variables if we are in an
	 initialization expression, or we want a subsection.  */
      if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
	  && (gfc_init_expr_flag || p->ref
	      || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
	{
	  if (!simplify_parameter_variable (p, type))
	    return false;
	  break;
	}

      if (type == 1)
	{
	  gfc_simplify_iterator_var (p);
	}

      /* Simplify subcomponent references.  */
      if (!simplify_ref_chain (p->ref, type, &p))
	return false;

      break;

    case EXPR_STRUCTURE:
    case EXPR_ARRAY:
      if (!simplify_ref_chain (p->ref, type, &p))
	return false;

      /* If the following conditions hold, we found something like kind type
	 inquiry of the form a(2)%kind while simplify the ref chain.  */
      if (p->expr_type == EXPR_CONSTANT && !p->ref && !p->rank && !p->shape)
	return true;

      if (!simplify_constructor (p->value.constructor, type))
	return false;

      if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
	  && p->ref->u.ar.type == AR_FULL)
	  gfc_expand_constructor (p, false);

      if (!simplify_const_ref (p))
	return false;

      break;

    case EXPR_COMPCALL:
    case EXPR_PPC:
      break;

    case EXPR_UNKNOWN:
      gcc_unreachable ();
    }

  return true;
}


/* Returns the type of an expression with the exception that iterator
   variables are automatically integers no matter what else they may
   be declared as.  */

static bt
et0 (gfc_expr *e)
{
  if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e))
    return BT_INTEGER;

  return e->ts.type;
}


/* Scalarize an expression for an elemental intrinsic call.  */

static bool
scalarize_intrinsic_call (gfc_expr *e, bool init_flag)
{
  gfc_actual_arglist *a, *b;
  gfc_constructor_base ctor;
  gfc_constructor *args[5] = {};  /* Avoid uninitialized warnings.  */
  gfc_constructor *ci, *new_ctor;
  gfc_expr *expr, *old;
  int n, i, rank[5], array_arg;
  int errors = 0;

  if (e == NULL)
    return false;

  a = e->value.function.actual;
  for (; a; a = a->next)
    if (a->expr && !gfc_is_constant_expr (a->expr))
      return false;

  /* Find which, if any, arguments are arrays.  Assume that the old
     expression carries the type information and that the first arg
     that is an array expression carries all the shape information.*/
  n = array_arg = 0;
  a = e->value.function.actual;
  for (; a; a = a->next)
    {
      n++;
      if (!a->expr || a->expr->expr_type != EXPR_ARRAY)
	continue;
      array_arg = n;
      expr = gfc_copy_expr (a->expr);
      break;
    }

  if (!array_arg)
    return false;

  old = gfc_copy_expr (e);

  gfc_constructor_free (expr->value.constructor);
  expr->value.constructor = NULL;
  expr->ts = old->ts;
  expr->where = old->where;
  expr->expr_type = EXPR_ARRAY;

  /* Copy the array argument constructors into an array, with nulls
     for the scalars.  */
  n = 0;
  a = old->value.function.actual;
  for (; a; a = a->next)
    {
      /* Check that this is OK for an initialization expression.  */
      if (a->expr && init_flag && !gfc_check_init_expr (a->expr))
	goto cleanup;

      rank[n] = 0;
      if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
	{
	  rank[n] = a->expr->rank;
	  ctor = a->expr->symtree->n.sym->value->value.constructor;
	  args[n] = gfc_constructor_first (ctor);
	}
      else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
	{
	  if (a->expr->rank)
	    rank[n] = a->expr->rank;
	  else
	    rank[n] = 1;
	  ctor = gfc_constructor_copy (a->expr->value.constructor);
	  args[n] = gfc_constructor_first (ctor);
	}
      else
	args[n] = NULL;

      n++;
    }

  gfc_get_errors (NULL, &errors);

  /* Using the array argument as the master, step through the array
     calling the function for each element and advancing the array
     constructors together.  */
  for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
    {
      new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
					      gfc_copy_expr (old), NULL);

      gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
      a = NULL;
      b = old->value.function.actual;
      for (i = 0; i < n; i++)
	{
	  if (a == NULL)
	    new_ctor->expr->value.function.actual
			= a = gfc_get_actual_arglist ();
	  else
	    {
	      a->next = gfc_get_actual_arglist ();
	      a = a->next;
	    }

	  if (args[i])
	    a->expr = gfc_copy_expr (args[i]->expr);
	  else
	    a->expr = gfc_copy_expr (b->expr);

	  b = b->next;
	}

      /* Simplify the function calls.  If the simplification fails, the
	 error will be flagged up down-stream or the library will deal
	 with it.  */
      if (errors == 0)
	gfc_simplify_expr (new_ctor->expr, 0);

      for (i = 0; i < n; i++)
	if (args[i])
	  args[i] = gfc_constructor_next (args[i]);

      for (i = 1; i < n; i++)
	if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
			|| (args[i] == NULL && args[array_arg - 1] != NULL)))
	  goto compliance;
    }

  free_expr0 (e);
  *e = *expr;
  /* Free "expr" but not the pointers it contains.  */
  free (expr);
  gfc_free_expr (old);
  return true;

compliance:
  gfc_error_now ("elemental function arguments at %C are not compliant");

cleanup:
  gfc_free_expr (expr);
  gfc_free_expr (old);
  return false;
}


static bool
check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *))
{
  gfc_expr *op1 = e->value.op.op1;
  gfc_expr *op2 = e->value.op.op2;

  if (!(*check_function)(op1))
    return false;

  switch (e->value.op.op)
    {
    case INTRINSIC_UPLUS:
    case INTRINSIC_UMINUS:
      if (!numeric_type (et0 (op1)))
	goto not_numeric;
      break;

    case INTRINSIC_EQ:
    case INTRINSIC_EQ_OS:
    case INTRINSIC_NE:
    case INTRINSIC_NE_OS:
    case INTRINSIC_GT:
    case INTRINSIC_GT_OS:
    case INTRINSIC_GE:
    case INTRINSIC_GE_OS:
    case INTRINSIC_LT:
    case INTRINSIC_LT_OS:
    case INTRINSIC_LE:
    case INTRINSIC_LE_OS:
      if (!(*check_function)(op2))
	return false;

      if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
	  && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
	{
	  gfc_error ("Numeric or CHARACTER operands are required in "
		     "expression at %L", &e->where);
	 return false;
	}
      break;

    case INTRINSIC_PLUS:
    case INTRINSIC_MINUS:
    case INTRINSIC_TIMES:
    case INTRINSIC_DIVIDE:
    case INTRINSIC_POWER:
      if (!(*check_function)(op2))
	return false;

      if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
	goto not_numeric;

      break;

    case INTRINSIC_CONCAT:
      if (!(*check_function)(op2))
	return false;

      if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
	{
	  gfc_error ("Concatenation operator in expression at %L "
		     "must have two CHARACTER operands", &op1->where);
	  return false;
	}

      if (op1->ts.kind != op2->ts.kind)
	{
	  gfc_error ("Concat operator at %L must concatenate strings of the "
		     "same kind", &e->where);
	  return false;
	}

      break;

    case INTRINSIC_NOT:
      if (et0 (op1) != BT_LOGICAL)
	{
	  gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
		     "operand", &op1->where);
	  return false;
	}

      break;

    case INTRINSIC_AND:
    case INTRINSIC_OR:
    case INTRINSIC_EQV:
    case INTRINSIC_NEQV:
      if (!(*check_function)(op2))
	return false;

      if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
	{
	  gfc_error ("LOGICAL operands are required in expression at %L",
		     &e->where);
	  return false;
	}

      break;

    case INTRINSIC_PARENTHESES:
      break;

    default:
      gfc_error ("Only intrinsic operators can be used in expression at %L",
		 &e->where);
      return false;
    }

  return true;

not_numeric:
  gfc_error ("Numeric operands are required in expression at %L", &e->where);

  return false;
}

/* F2003, 7.1.7 (3): In init expression, allocatable components
   must not be data-initialized.  */
static bool
check_alloc_comp_init (gfc_expr *e)
{
  gfc_component *comp;
  gfc_constructor *ctor;

  gcc_assert (e->expr_type == EXPR_STRUCTURE);
  gcc_assert (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS);

  for (comp = e->ts.u.derived->components,
       ctor = gfc_constructor_first (e->value.constructor);
       comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
    {
      if (comp->attr.allocatable && ctor->expr
          && ctor->expr->expr_type != EXPR_NULL)
        {
	  gfc_error ("Invalid initialization expression for ALLOCATABLE "
		     "component %qs in structure constructor at %L",
		     comp->name, &ctor->expr->where);
	  return false;
	}
    }

  return true;
}

static match
check_init_expr_arguments (gfc_expr *e)
{
  gfc_actual_arglist *ap;

  for (ap = e->value.function.actual; ap; ap = ap->next)
    if (!gfc_check_init_expr (ap->expr))
      return MATCH_ERROR;

  return MATCH_YES;
}

static bool check_restricted (gfc_expr *);

/* F95, 7.1.6.1, Initialization expressions, (7)
   F2003, 7.1.7 Initialization expression, (8)
   F2008, 7.1.12 Constant expression, (4)  */

static match
check_inquiry (gfc_expr *e, int not_restricted)
{
  const char *name;
  const char *const *functions;

  static const char *const inquiry_func_f95[] = {
    "lbound", "shape", "size", "ubound",
    "bit_size", "len", "kind",
    "digits", "epsilon", "huge", "maxexponent", "minexponent",
    "precision", "radix", "range", "tiny",
    NULL
  };

  static const char *const inquiry_func_f2003[] = {
    "lbound", "shape", "size", "ubound",
    "bit_size", "len", "kind",
    "digits", "epsilon", "huge", "maxexponent", "minexponent",
    "precision", "radix", "range", "tiny",
    "new_line", NULL
  };

  /* std=f2008+ or -std=gnu */
  static const char *const inquiry_func_gnu[] = {
    "lbound", "shape", "size", "ubound",
    "bit_size", "len", "kind",
    "digits", "epsilon", "huge", "maxexponent", "minexponent",
    "precision", "radix", "range", "tiny",
    "new_line", "storage_size", NULL
  };

  int i = 0;
  gfc_actual_arglist *ap;
  gfc_symbol *sym;
  gfc_symbol *asym;

  if (!e->value.function.isym
      || !e->value.function.isym->inquiry)
    return MATCH_NO;

  /* An undeclared parameter will get us here (PR25018).  */
  if (e->symtree == NULL)
    return MATCH_NO;

  sym = e->symtree->n.sym;

  if (sym->from_intmod)
    {
      if (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
	  && sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
	  && sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
	return MATCH_NO;

      if (sym->from_intmod == INTMOD_ISO_C_BINDING
	  && sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
	return MATCH_NO;
    }
  else
    {
      name = sym->name;

      functions = inquiry_func_gnu;
      if (gfc_option.warn_std & GFC_STD_F2003)
	functions = inquiry_func_f2003;
      if (gfc_option.warn_std & GFC_STD_F95)
	functions = inquiry_func_f95;

      for (i = 0; functions[i]; i++)
	if (strcmp (functions[i], name) == 0)
	  break;

      if (functions[i] == NULL)
	return MATCH_ERROR;
    }

  /* At this point we have an inquiry function with a variable argument.  The
     type of the variable might be undefined, but we need it now, because the
     arguments of these functions are not allowed to be undefined.  */

  for (ap = e->value.function.actual; ap; ap = ap->next)
    {
      if (!ap->expr)
	continue;

      asym = ap->expr->symtree ? ap->expr->symtree->n.sym : NULL;

      if (ap->expr->ts.type == BT_UNKNOWN)
	{
	  if (asym && asym->ts.type == BT_UNKNOWN
	      && !gfc_set_default_type (asym, 0, gfc_current_ns))
	    return MATCH_NO;

	  ap->expr->ts = asym->ts;
	}

      if (asym && asym->assoc && asym->assoc->target
	  && asym->assoc->target->expr_type == EXPR_CONSTANT)
	{
	  gfc_free_expr (ap->expr);
	  ap->expr = gfc_copy_expr (asym->assoc->target);
	}

      /* Assumed character length will not reduce to a constant expression
	 with LEN, as required by the standard.  */
      if (i == 5 && not_restricted && asym
	  && asym->ts.type == BT_CHARACTER
	  && ((asym->ts.u.cl && asym->ts.u.cl->length == NULL)
	      || asym->ts.deferred))
	{
	  gfc_error ("Assumed or deferred character length variable %qs "
		     "in constant expression at %L",
		      asym->name, &ap->expr->where);
	  return MATCH_ERROR;
	}
      else if (not_restricted && !gfc_check_init_expr (ap->expr))
	return MATCH_ERROR;

      if (not_restricted == 0
	  && ap->expr->expr_type != EXPR_VARIABLE
	  && !check_restricted (ap->expr))
	return MATCH_ERROR;

      if (not_restricted == 0
	  && ap->expr->expr_type == EXPR_VARIABLE
	  && asym->attr.dummy && asym->attr.optional)
	return MATCH_NO;
    }

  return MATCH_YES;
}


/* F95, 7.1.6.1, Initialization expressions, (5)
   F2003, 7.1.7 Initialization expression, (5)  */

static match
check_transformational (gfc_expr *e)
{
  static const char * const trans_func_f95[] = {
    "repeat", "reshape", "selected_int_kind",
    "selected_real_kind", "transfer", "trim", NULL
  };

  static const char * const trans_func_f2003[] =  {
    "all", "any", "count", "dot_product", "matmul", "null", "pack",
    "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
    "selected_real_kind", "spread", "sum", "transfer", "transpose",
    "trim", "unpack", NULL
  };

  static const char * const trans_func_f2008[] =  {
    "all", "any", "count", "dot_product", "matmul", "null", "pack",
    "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
    "selected_real_kind", "spread", "sum", "transfer", "transpose",
    "trim", "unpack", "findloc", NULL
  };

  int i;
  const char *name;
  const char *const *functions;

  if (!e->value.function.isym
      || !e->value.function.isym->transformational)
    return MATCH_NO;

  name = e->symtree->n.sym->name;

  if (gfc_option.allow_std & GFC_STD_F2008)
    functions = trans_func_f2008;
  else if (gfc_option.allow_std & GFC_STD_F2003)
    functions = trans_func_f2003;
  else
    functions = trans_func_f95;

  /* NULL() is dealt with below.  */
  if (strcmp ("null", name) == 0)
    return MATCH_NO;

  for (i = 0; functions[i]; i++)
    if (strcmp (functions[i], name) == 0)
       break;

  if (functions[i] == NULL)
    {
      gfc_error ("transformational intrinsic %qs at %L is not permitted "
		 "in an initialization expression", name, &e->where);
      return MATCH_ERROR;
    }

  return check_init_expr_arguments (e);
}


/* F95, 7.1.6.1, Initialization expressions, (6)
   F2003, 7.1.7 Initialization expression, (6)  */

static match
check_null (gfc_expr *e)
{
  if (strcmp ("null", e->symtree->n.sym->name) != 0)
    return MATCH_NO;

  return check_init_expr_arguments (e);
}


static match
check_elemental (gfc_expr *e)
{
  if (!e->value.function.isym
      || !e->value.function.isym->elemental)
    return MATCH_NO;

  if (e->ts.type != BT_INTEGER
      && e->ts.type != BT_CHARACTER
      && !gfc_notify_std (GFC_STD_F2003, "Evaluation of nonstandard "
			  "initialization expression at %L", &e->where))
    return MATCH_ERROR;

  return check_init_expr_arguments (e);
}


static match
check_conversion (gfc_expr *e)
{
  if (!e->value.function.isym
      || !e->value.function.isym->conversion)
    return MATCH_NO;

  return check_init_expr_arguments (e);
}


/* Verify that an expression is an initialization expression.  A side
   effect is that the expression tree is reduced to a single constant
   node if all goes well.  This would normally happen when the
   expression is constructed but function references are assumed to be
   intrinsics in the context of initialization expressions.  If
   false is returned an error message has been generated.  */

bool
gfc_check_init_expr (gfc_expr *e)
{
  match m;
  bool t;

  if (e == NULL)
    return true;

  switch (e->expr_type)
    {
    case EXPR_OP:
      t = check_intrinsic_op (e, gfc_check_init_expr);
      if (t)
	t = gfc_simplify_expr (e, 0);

      break;

    case EXPR_FUNCTION:
      t = false;

      {
	bool conversion;
	gfc_intrinsic_sym* isym = NULL;
	gfc_symbol* sym = e->symtree->n.sym;

	/* Simplify here the intrinsics from the IEEE_ARITHMETIC and
	   IEEE_EXCEPTIONS modules.  */
	int mod = sym->from_intmod;
	if (mod == INTMOD_NONE && sym->generic)
	  mod = sym->generic->sym->from_intmod;
	if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS)
	  {
	    gfc_expr *new_expr = gfc_simplify_ieee_functions (e);
	    if (new_expr)
	      {
		gfc_replace_expr (e, new_expr);
		t = true;
		break;
	      }
	  }

	/* If a conversion function, e.g., __convert_i8_i4, was inserted
	   into an array constructor, we need to skip the error check here.
           Conversion errors are  caught below in scalarize_intrinsic_call.  */
	conversion = e->value.function.isym
		   && (e->value.function.isym->conversion == 1);

	if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where)
	    || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES))
	  {
	    gfc_error ("Function %qs in initialization expression at %L "
		       "must be an intrinsic function",
		       e->symtree->n.sym->name, &e->where);
	    break;
	  }

	if ((m = check_conversion (e)) == MATCH_NO
	    && (m = check_inquiry (e, 1)) == MATCH_NO
	    && (m = check_null (e)) == MATCH_NO
	    && (m = check_transformational (e)) == MATCH_NO
	    && (m = check_elemental (e)) == MATCH_NO)
	  {
	    gfc_error ("Intrinsic function %qs at %L is not permitted "
		       "in an initialization expression",
		       e->symtree->n.sym->name, &e->where);
	    m = MATCH_ERROR;
	  }

	if (m == MATCH_ERROR)
	  return false;

	/* Try to scalarize an elemental intrinsic function that has an
	   array argument.  */
	isym = gfc_find_function (e->symtree->n.sym->name);
	if (isym && isym->elemental
	    && (t = scalarize_intrinsic_call (e, true)))
	  break;
      }

      if (m == MATCH_YES)
	t = gfc_simplify_expr (e, 0);

      break;

    case EXPR_VARIABLE:
      t = true;

      /* This occurs when parsing pdt templates.  */
      if (gfc_expr_attr (e).pdt_kind)
	break;

      if (gfc_check_iter_variable (e))
	break;

      if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
	{
	  /* A PARAMETER shall not be used to define itself, i.e.
		REAL, PARAMETER :: x = transfer(0, x)
	     is invalid.  */
	  if (!e->symtree->n.sym->value)
	    {
	      gfc_error ("PARAMETER %qs is used at %L before its definition "
			 "is complete", e->symtree->n.sym->name, &e->where);
	      t = false;
	    }
	  else
	    t = simplify_parameter_variable (e, 0);

	  break;
	}

      if (gfc_in_match_data ())
	break;

      t = false;

      if (e->symtree->n.sym->as)
	{
	  switch (e->symtree->n.sym->as->type)
	    {
	      case AS_ASSUMED_SIZE:
		gfc_error ("Assumed size array %qs at %L is not permitted "
			   "in an initialization expression",
			   e->symtree->n.sym->name, &e->where);
		break;

	      case AS_ASSUMED_SHAPE:
		gfc_error ("Assumed shape array %qs at %L is not permitted "
			   "in an initialization expression",
			   e->symtree->n.sym->name, &e->where);
		break;

	      case AS_DEFERRED:
		if (!e->symtree->n.sym->attr.allocatable
		    && !e->symtree->n.sym->attr.pointer
		    && e->symtree->n.sym->attr.dummy)
		  gfc_error ("Assumed-shape array %qs at %L is not permitted "
			     "in an initialization expression",
			     e->symtree->n.sym->name, &e->where);
		else
		  gfc_error ("Deferred array %qs at %L is not permitted "
			     "in an initialization expression",
			     e->symtree->n.sym->name, &e->where);
		break;

	      case AS_EXPLICIT:
		gfc_error ("Array %qs at %L is a variable, which does "
			   "not reduce to a constant expression",
			   e->symtree->n.sym->name, &e->where);
		break;

	      default:
		gcc_unreachable();
	  }
	}
      else
	gfc_error ("Parameter %qs at %L has not been declared or is "
		   "a variable, which does not reduce to a constant "
		   "expression", e->symtree->name, &e->where);

      break;

    case EXPR_CONSTANT:
    case EXPR_NULL:
      t = true;
      break;

    case EXPR_SUBSTRING:
      if (e->ref)
	{
	  t = gfc_check_init_expr (e->ref->u.ss.start);
	  if (!t)
	    break;

	  t = gfc_check_init_expr (e->ref->u.ss.end);
	  if (t)
	    t = gfc_simplify_expr (e, 0);
	}
      else
	t = false;
      break;

    case EXPR_STRUCTURE:
      t = e->ts.is_iso_c ? true : false;
      if (t)
	break;

      t = check_alloc_comp_init (e);
      if (!t)
	break;

      t = gfc_check_constructor (e, gfc_check_init_expr);
      if (!t)
	break;

      break;

    case EXPR_ARRAY:
      t = gfc_check_constructor (e, gfc_check_init_expr);
      if (!t)
	break;

      t = gfc_expand_constructor (e, true);
      if (!t)
	break;

      t = gfc_check_constructor_type (e);
      break;

    default:
      gfc_internal_error ("check_init_expr(): Unknown expression type");
    }

  return t;
}

/* Reduces a general expression to an initialization expression (a constant).
   This used to be part of gfc_match_init_expr.
   Note that this function doesn't free the given expression on false.  */

bool
gfc_reduce_init_expr (gfc_expr *expr)
{
  bool t;

  gfc_init_expr_flag = true;
  t = gfc_resolve_expr (expr);
  if (t)
    t = gfc_check_init_expr (expr);
  gfc_init_expr_flag = false;

  if (!t || !expr)
    return false;

  if (expr->expr_type == EXPR_ARRAY)
    {
      if (!gfc_check_constructor_type (expr))
	return false;
      if (!gfc_expand_constructor (expr, true))
	return false;
    }

  return true;
}


/* Match an initialization expression.  We work by first matching an
   expression, then reducing it to a constant.  */

match
gfc_match_init_expr (gfc_expr **result)
{
  gfc_expr *expr;
  match m;
  bool t;

  expr = NULL;

  gfc_init_expr_flag = true;

  m = gfc_match_expr (&expr);
  if (m != MATCH_YES)
    {
      gfc_init_expr_flag = false;
      return m;
    }

  if (gfc_derived_parameter_expr (expr))
    {
      *result = expr;
      gfc_init_expr_flag = false;
      return m;
    }

  t = gfc_reduce_init_expr (expr);
  if (!t)
    {
      gfc_free_expr (expr);
      gfc_init_expr_flag = false;
      return MATCH_ERROR;
    }

  *result = expr;
  gfc_init_expr_flag = false;

  return MATCH_YES;
}


/* Given an actual argument list, test to see that each argument is a
   restricted expression and optionally if the expression type is
   integer or character.  */

static bool
restricted_args (gfc_actual_arglist *a)
{
  for (; a; a = a->next)
    {
      if (!check_restricted (a->expr))
	return false;
    }

  return true;
}


/************* Restricted/specification expressions *************/


/* Make sure a non-intrinsic function is a specification function,
 * see F08:7.1.11.5.  */

static bool
external_spec_function (gfc_expr *e)
{
  gfc_symbol *f;

  f = e->value.function.esym;

  /* IEEE functions allowed are "a reference to a transformational function
     from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
     "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
     IEEE_EXCEPTIONS".  */
  if (f->from_intmod == INTMOD_IEEE_ARITHMETIC