gcc/fortran/frontend-passes.cc

/* Pass manager for Fortran front end.
   Copyright (C) 2010-2022 Free Software Foundation, Inc.
   Contributed by Thomas König.

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 "dependency.h"
#include "constructor.h"
#include "intrinsic.h"

/* Forward declarations.  */

static void strip_function_call (gfc_expr *);
static void optimize_namespace (gfc_namespace *);
static void optimize_assignment (gfc_code *);
static bool optimize_op (gfc_expr *);
static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
static bool optimize_trim (gfc_expr *);
static bool optimize_lexical_comparison (gfc_expr *);
static void optimize_minmaxloc (gfc_expr **);
static bool is_empty_string (gfc_expr *e);
static void doloop_warn (gfc_namespace *);
static int do_intent (gfc_expr **);
static int do_subscript (gfc_expr **);
static void optimize_reduction (gfc_namespace *);
static int callback_reduction (gfc_expr **, int *, void *);
static void realloc_strings (gfc_namespace *);
static gfc_expr *create_var (gfc_expr *, const char *vname=NULL);
static int matmul_to_var_expr (gfc_expr **, int *, void *);
static int matmul_to_var_code (gfc_code **, int *, void *);
static int inline_matmul_assign (gfc_code **, int *, void *);
static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *,
				  locus *, gfc_namespace *,
				  char *vname=NULL);
static gfc_expr* check_conjg_transpose_variable (gfc_expr *, bool *,
						 bool *);
static int call_external_blas (gfc_code **, int *, void *);
static int matmul_temp_args (gfc_code **, int *,void *data);
static int index_interchange (gfc_code **, int*, void *);
static bool is_fe_temp (gfc_expr *e);

#ifdef CHECKING_P
static void check_locus (gfc_namespace *);
#endif

/* How deep we are inside an argument list.  */

static int count_arglist;

/* Vector of gfc_expr ** we operate on.  */

static vec<gfc_expr **> expr_array;

/* Pointer to the gfc_code we currently work on - to be able to insert
   a block before the statement.  */

static gfc_code **current_code;

/* Pointer to the block to be inserted, and the statement we are
   changing within the block.  */

static gfc_code *inserted_block, **changed_statement;

/* The namespace we are currently dealing with.  */

static gfc_namespace *current_ns;

/* If we are within any forall loop.  */

static int forall_level;

/* Keep track of whether we are within an OMP workshare.  */

static bool in_omp_workshare;

/* Keep track of whether we are within an OMP atomic.  */

static bool in_omp_atomic;

/* Keep track of whether we are within a WHERE statement.  */

static bool in_where;

/* Keep track of iterators for array constructors.  */

static int iterator_level;

/* Keep track of DO loop levels.  */

typedef struct {
  gfc_code *c;
  int branch_level;
  bool seen_goto;
} do_t;

static vec<do_t> doloop_list;
static int doloop_level;

/* Keep track of if and select case levels.  */

static int if_level;
static int select_level;

/* Vector of gfc_expr * to keep track of DO loops.  */

struct my_struct *evec;

/* Keep track of association lists.  */

static bool in_assoc_list;

/* Counter for temporary variables.  */

static int var_num = 1;

/* What sort of matrix we are dealing with when inlining MATMUL.  */

enum matrix_case { none=0, A2B2, A2B1, A1B2, A2B2T, A2TB2, A2TB2T };

/* Keep track of the number of expressions we have inserted so far
   using create_var.  */

int n_vars;

/* Entry point - run all passes for a namespace.  */

void
gfc_run_passes (gfc_namespace *ns)
{

  /* Warn about dubious DO loops where the index might
     change.  */

  doloop_level = 0;
  if_level = 0;
  select_level = 0;
  doloop_warn (ns);
  doloop_list.release ();
  int w, e;

#ifdef CHECKING_P
  check_locus (ns);
#endif

  gfc_get_errors (&w, &e);
  if (e > 0)
    return;

  if (flag_frontend_optimize || flag_frontend_loop_interchange)
    optimize_namespace (ns);

  if (flag_frontend_optimize)
    {
      optimize_reduction (ns);
      if (flag_dump_fortran_optimized)
	gfc_dump_parse_tree (ns, stdout);

      expr_array.release ();
    }

  if (flag_realloc_lhs)
    realloc_strings (ns);
}

#ifdef CHECKING_P

/* Callback function: Warn if there is no location information in a
   statement.  */

static int
check_locus_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
		  void *data ATTRIBUTE_UNUSED)
{
  current_code = c;
  if (c && *c && (((*c)->loc.nextc == NULL) || ((*c)->loc.lb == NULL)))
    gfc_warning_internal (0, "Inconsistent internal state: "
			  "No location in statement");

  return 0;
}


/* Callback function: Warn if there is no location information in an
   expression.  */

static int
check_locus_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
		  void *data ATTRIBUTE_UNUSED)
{

  if (e && *e && (((*e)->where.nextc == NULL || (*e)->where.lb == NULL)))
    gfc_warning_internal (0, "Inconsistent internal state: "
			  "No location in expression near %L",
			  &((*current_code)->loc));
  return 0;
}

/* Run check for missing location information.  */

static void
check_locus (gfc_namespace *ns)
{
  gfc_code_walker (&ns->code, check_locus_code, check_locus_expr, NULL);

  for (ns = ns->contained; ns; ns = ns->sibling)
    {
      if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
	check_locus (ns);
    }
}

#endif

/* Callback for each gfc_code node invoked from check_realloc_strings.
   For an allocatable LHS string which also appears as a variable on
   the RHS, replace

   a = a(x:y)

   with

   tmp = a(x:y)
   a = tmp
 */

static int
realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
			 void *data ATTRIBUTE_UNUSED)
{
  gfc_expr *expr1, *expr2;
  gfc_code *co = *c;
  gfc_expr *n;
  gfc_ref *ref;
  bool found_substr;

  if (co->op != EXEC_ASSIGN)
    return 0;

  expr1 = co->expr1;
  if (expr1->ts.type != BT_CHARACTER
      || !gfc_expr_attr(expr1).allocatable
      || !expr1->ts.deferred)
    return 0;

  if (is_fe_temp (expr1))
    return 0;

  expr2 = gfc_discard_nops (co->expr2);

  if (expr2->expr_type == EXPR_VARIABLE)
    {
      found_substr = false;
      for (ref = expr2->ref; ref; ref = ref->next)
	{
	  if (ref->type == REF_SUBSTRING)
	    {
	      found_substr = true;
	      break;
	    }
	}
      if (!found_substr)
	return 0;
    }
  else if (expr2->expr_type != EXPR_ARRAY
	   && (expr2->expr_type != EXPR_OP
	       || expr2->value.op.op != INTRINSIC_CONCAT))
    return 0;

  if (!gfc_check_dependency (expr1, expr2, true))
    return 0;

  /* gfc_check_dependency doesn't always pick up identical expressions.
     However, eliminating the above sends the compiler into an infinite
     loop on valid expressions.  Without this check, the gimplifier emits
     an ICE for a = a, where a is deferred character length.  */
  if (!gfc_dep_compare_expr (expr1, expr2))
    return 0;

  current_code = c;
  inserted_block = NULL;
  changed_statement = NULL;
  n = create_var (expr2, "realloc_string");
  co->expr2 = n;
  return 0;
}

/* Callback for each gfc_code node invoked through gfc_code_walker
   from optimize_namespace.  */

static int
optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
	       void *data ATTRIBUTE_UNUSED)
{

  gfc_exec_op op;

  op = (*c)->op;

  if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
      || op == EXEC_CALL_PPC)
    count_arglist = 1;
  else
    count_arglist = 0;

  current_code = c;
  inserted_block = NULL;
  changed_statement = NULL;

  if (op == EXEC_ASSIGN)
    optimize_assignment (*c);
  return 0;
}

/* Callback for each gfc_expr node invoked through gfc_code_walker
   from optimize_namespace.  */

static int
optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
	       void *data ATTRIBUTE_UNUSED)
{
  bool function_expr;

  if ((*e)->expr_type == EXPR_FUNCTION)
    {
      count_arglist ++;
      function_expr = true;
    }
  else
    function_expr = false;

  if (optimize_trim (*e))
    gfc_simplify_expr (*e, 0);

  if (optimize_lexical_comparison (*e))
    gfc_simplify_expr (*e, 0);

  if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
    gfc_simplify_expr (*e, 0);

  if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
    switch ((*e)->value.function.isym->id)
      {
      case GFC_ISYM_MINLOC:
      case GFC_ISYM_MAXLOC:
	optimize_minmaxloc (e);
	break;
      default:
	break;
      }

  if (function_expr)
    count_arglist --;

  return 0;
}

/* Auxiliary function to handle the arguments to reduction intrinsics.  If the
   function is a scalar, just copy it; otherwise returns the new element, the
   old one can be freed.  */

static gfc_expr *
copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn)
{
  gfc_expr *fcn, *e = c->expr;

  fcn = gfc_copy_expr (e);
  if (c->iterator)
    {
      gfc_constructor_base newbase;
      gfc_expr *new_expr;
      gfc_constructor *new_c;

      newbase = NULL;
      new_expr = gfc_get_expr ();
      new_expr->expr_type = EXPR_ARRAY;
      new_expr->ts = e->ts;
      new_expr->where = e->where;
      new_expr->rank = 1;
      new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where));
      new_c->iterator = c->iterator;
      new_expr->value.constructor = newbase;
      c->iterator = NULL;

      fcn = new_expr;
    }

  if (fcn->rank != 0)
    {
      gfc_isym_id id = fn->value.function.isym->id;

      if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
	fcn = gfc_build_intrinsic_call (current_ns, id,
					fn->value.function.isym->name,
					fn->where, 3, fcn, NULL, NULL);
      else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
	fcn = gfc_build_intrinsic_call (current_ns, id,
					fn->value.function.isym->name,
					fn->where, 2, fcn, NULL);
      else
	gfc_internal_error ("Illegal id in copy_walk_reduction_arg");

      fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
    }

  return fcn;
}

/* Callback function for optimzation of reductions to scalars.  Transform ANY
   ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
   correspondingly.  Handly only the simple cases without MASK and DIM.  */

static int
callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
		    void *data ATTRIBUTE_UNUSED)
{
  gfc_expr *fn, *arg;
  gfc_intrinsic_op op;
  gfc_isym_id id;
  gfc_actual_arglist *a;
  gfc_actual_arglist *dim;
  gfc_constructor *c;
  gfc_expr *res, *new_expr;
  gfc_actual_arglist *mask;

  fn = *e;

  if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION
      || fn->value.function.isym == NULL)
    return 0;

  id = fn->value.function.isym->id;

  if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT
      && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL)
    return 0;

  a = fn->value.function.actual;

  /* Don't handle MASK or DIM.  */

  dim = a->next;

  if (dim->expr != NULL)
    return 0;

  if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
    {
      mask = dim->next;
      if ( mask->expr != NULL)
	return 0;
    }

  arg = a->expr;

  if (arg->expr_type != EXPR_ARRAY)
    return 0;

  switch (id)
    {
    case GFC_ISYM_SUM:
      op = INTRINSIC_PLUS;
      break;

    case GFC_ISYM_PRODUCT:
      op = INTRINSIC_TIMES;
      break;

    case GFC_ISYM_ANY:
      op = INTRINSIC_OR;
      break;

    case GFC_ISYM_ALL:
      op = INTRINSIC_AND;
      break;

    default:
      return 0;
    }

  c = gfc_constructor_first (arg->value.constructor);

  /* Don't do any simplififcation if we have
     - no element in the constructor or
     - only have a single element in the array which contains an
     iterator.  */

  if (c == NULL)
    return 0;

  res = copy_walk_reduction_arg (c, fn);

  c = gfc_constructor_next (c);
  while (c)
    {
      new_expr = gfc_get_expr ();
      new_expr->ts = fn->ts;
      new_expr->expr_type = EXPR_OP;
      new_expr->rank = fn->rank;
      new_expr->where = fn->where;
      new_expr->value.op.op = op;
      new_expr->value.op.op1 = res;
      new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn);
      res = new_expr;
      c = gfc_constructor_next (c);
    }

  gfc_simplify_expr (res, 0);
  *e = res;
  gfc_free_expr (fn);

  return 0;
}

/* Callback function for common function elimination, called from cfe_expr_0.
   Put all eligible function expressions into expr_array.  */

static int
cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
	  void *data ATTRIBUTE_UNUSED)
{

  if ((*e)->expr_type != EXPR_FUNCTION)
    return 0;

  /* We don't do character functions with unknown charlens.  */
  if ((*e)->ts.type == BT_CHARACTER
      && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
	  || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
    return 0;

  /* We don't do function elimination within FORALL statements, it can
     lead to wrong-code in certain circumstances.  */

  if (forall_level > 0)
    return 0;

  /* Function elimination inside an iterator could lead to functions which
     depend on iterator variables being moved outside.  FIXME: We should check
     if the functions do indeed depend on the iterator variable.  */

  if (iterator_level > 0)
    return 0;

  /* If we don't know the shape at compile time, we create an allocatable
     temporary variable to hold the intermediate result, but only if
     allocation on assignment is active.  */

  if ((*e)->rank > 0 && (*e)->shape == NULL && !flag_realloc_lhs)
    return 0;

  /* Skip the test for pure functions if -faggressive-function-elimination
     is specified.  */
  if ((*e)->value.function.esym)
    {
      /* Don't create an array temporary for elemental functions.  */
      if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
	return 0;

      /* Only eliminate potentially impure functions if the
	 user specifically requested it.  */
      if (!flag_aggressive_function_elimination
	  && !(*e)->value.function.esym->attr.pure
	  && !(*e)->value.function.esym->attr.implicit_pure)
	return 0;
    }

  if ((*e)->value.function.isym)
    {
      /* Conversions are handled on the fly by the middle end,
	 transpose during trans-* stages and TRANSFER by the middle end.  */
      if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
	  || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
	  || gfc_inline_intrinsic_function_p (*e))
	return 0;

      /* Don't create an array temporary for elemental functions,
	 as this would be wasteful of memory.
	 FIXME: Create a scalar temporary during scalarization.  */
      if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
	return 0;

      if (!(*e)->value.function.isym->pure)
	return 0;
    }

  expr_array.safe_push (e);
  return 0;
}

/* Auxiliary function to check if an expression is a temporary created by
   create var.  */

static bool
is_fe_temp (gfc_expr *e)
{
  if (e->expr_type != EXPR_VARIABLE)
    return false;

  return e->symtree->n.sym->attr.fe_temp;
}

/* Determine the length of a string, if it can be evaluated as a constant
   expression.  Return a newly allocated gfc_expr or NULL on failure.
   If the user specified a substring which is potentially longer than
   the string itself, the string will be padded with spaces, which
   is harmless.  */

static gfc_expr *
constant_string_length (gfc_expr *e)
{

  gfc_expr *length;
  gfc_ref *ref;
  gfc_expr *res;
  mpz_t value;

  if (e->ts.u.cl)
    {
      length = e->ts.u.cl->length;
      if (length && length->expr_type == EXPR_CONSTANT)
	return gfc_copy_expr(length);
    }

  /* See if there is a substring. If it has a constant length, return
     that and NULL otherwise.  */
  for (ref = e->ref; ref; ref = ref->next)
    {
      if (ref->type == REF_SUBSTRING)
	{
	  if (gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value))
	    {
	      res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
					   &e->where);

	      mpz_add_ui (res->value.integer, value, 1);
	      mpz_clear (value);
	      return res;
	    }
	  else
	    return NULL;
	}
    }

  /* Return length of char symbol, if constant.  */
  if (e->symtree && e->symtree->n.sym->ts.u.cl
      && e->symtree->n.sym->ts.u.cl->length
      && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
    return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);

  return NULL;

}

/* Insert a block at the current position unless it has already
   been inserted; in this case use the one already there.  */

static gfc_namespace*
insert_block ()
{
  gfc_namespace *ns;

  /* If the block hasn't already been created, do so.  */
  if (inserted_block == NULL)
    {
      inserted_block = XCNEW (gfc_code);
      inserted_block->op = EXEC_BLOCK;
      inserted_block->loc = (*current_code)->loc;
      ns = gfc_build_block_ns (current_ns);
      inserted_block->ext.block.ns = ns;
      inserted_block->ext.block.assoc = NULL;

      ns->code = *current_code;

      /* If the statement has a label,  make sure it is transferred to
	 the newly created block.  */

      if ((*current_code)->here)
	{
	  inserted_block->here = (*current_code)->here;
	  (*current_code)->here = NULL;
	}

      inserted_block->next = (*current_code)->next;
      changed_statement = &(inserted_block->ext.block.ns->code);
      (*current_code)->next = NULL;
      /* Insert the BLOCK at the right position.  */
      *current_code = inserted_block;
      ns->parent = current_ns;
    }
  else
    ns = inserted_block->ext.block.ns;

  return ns;
}


/* Insert a call to the intrinsic len. Use a different name for
   the symbol tree so we don't run into trouble when the user has
   renamed len for some reason.  */

static gfc_expr*
get_len_call (gfc_expr *str)
{
  gfc_expr *fcn;
  gfc_actual_arglist *actual_arglist;

  fcn = gfc_get_expr ();
  fcn->expr_type = EXPR_FUNCTION;
  fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN);
  actual_arglist = gfc_get_actual_arglist ();
  actual_arglist->expr = str;

  fcn->value.function.actual = actual_arglist;
  fcn->where = str->where;
  fcn->ts.type = BT_INTEGER;
  fcn->ts.kind = gfc_charlen_int_kind;

  gfc_get_sym_tree ("__internal_len", current_ns, &fcn->symtree, false);
  fcn->symtree->n.sym->ts = fcn->ts;
  fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
  fcn->symtree->n.sym->attr.function = 1;
  fcn->symtree->n.sym->attr.elemental = 1;
  fcn->symtree->n.sym->attr.referenced = 1;
  fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
  gfc_commit_symbol (fcn->symtree->n.sym);

  return fcn;
}


/* Returns a new expression (a variable) to be used in place of the old one,
   with an optional assignment statement before the current statement to set
   the value of the variable. Creates a new BLOCK for the statement if that
   hasn't already been done and puts the statement, plus the newly created
   variables, in that block.  Special cases: If the expression is constant or
   a temporary which has already been created, just copy it.  */

static gfc_expr*
create_var (gfc_expr * e, const char *vname)
{
  char name[GFC_MAX_SYMBOL_LEN +1];
  gfc_symtree *symtree;
  gfc_symbol *symbol;
  gfc_expr *result;
  gfc_code *n;
  gfc_namespace *ns;
  int i;
  bool deferred;

  if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e))
    return gfc_copy_expr (e);

  /* Creation of an array of unknown size requires realloc on assignment.
     If that is not possible, just return NULL.  */
  if (flag_realloc_lhs == 0 && e->rank > 0 && e->shape == NULL)
    return NULL;

  ns = insert_block ();

  if (vname)
    snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d_%s", var_num++, vname);
  else
    snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d", var_num++);

  if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
    gcc_unreachable ();

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

  if (e->rank > 0)
    {
      symbol->as = gfc_get_array_spec ();
      symbol->as->rank = e->rank;

      if (e->shape == NULL)
	{
	  /* We don't know the shape at compile time, so we use an
	     allocatable.  */
	  symbol->as->type = AS_DEFERRED;
	  symbol->attr.allocatable = 1;
	}
      else
	{
	  symbol->as->type = AS_EXPLICIT;
	  /* Copy the shape.  */
	  for (i=0; i<e->rank; i++)
	    {
	      gfc_expr *p, *q;

	      p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
					 &(e->where));
	      mpz_set_si (p->value.integer, 1);
	      symbol->as->lower[i] = p;

	      q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
					 &(e->where));
	      mpz_set (q->value.integer, e->shape[i]);
	      symbol->as->upper[i] = q;
	    }
	}
    }

  deferred = 0;
  if (e->ts.type == BT_CHARACTER)
    {
      gfc_expr *length;

      symbol->ts.u.cl = gfc_new_charlen (ns, NULL);
      length = constant_string_length (e);
      if (length)
	symbol->ts.u.cl->length = length;
      else if (e->expr_type == EXPR_VARIABLE
	       && e->symtree->n.sym->ts.type == BT_CHARACTER
	       && e->ts.u.cl->length)
	symbol->ts.u.cl->length = get_len_call (gfc_copy_expr (e));
      else
	{
	  symbol->attr.allocatable = 1;
	  symbol->ts.u.cl->length = NULL;
	  symbol->ts.deferred = 1;
	  deferred = 1;
	}
    }

  symbol->attr.flavor = FL_VARIABLE;
  symbol->attr.referenced = 1;
  symbol->attr.dimension = e->rank > 0;
  symbol->attr.fe_temp = 1;
  gfc_commit_symbol (symbol);

  result = gfc_get_expr ();
  result->expr_type = EXPR_VARIABLE;
  result->ts = symbol->ts;
  result->ts.deferred = deferred;
  result->rank = e->rank;
  result->shape = gfc_copy_shape (e->shape, e->rank);
  result->symtree = symtree;
  result->where = e->where;
  if (e->rank > 0)
    {
      result->ref = gfc_get_ref ();
      result->ref->type = REF_ARRAY;
      result->ref->u.ar.type = AR_FULL;
      result->ref->u.ar.where = e->where;
      result->ref->u.ar.dimen = e->rank;
      result->ref->u.ar.as = symbol->ts.type == BT_CLASS
			     ? CLASS_DATA (symbol)->as : symbol->as;
      if (warn_array_temporaries)
	gfc_warning (OPT_Warray_temporaries,
		     "Creating array temporary at %L", &(e->where));
    }

  /* Generate the new assignment.  */
  n = XCNEW (gfc_code);
  n->op = EXEC_ASSIGN;
  n->loc = (*current_code)->loc;
  n->next = *changed_statement;
  n->expr1 = gfc_copy_expr (result);
  n->expr2 = e;
  *changed_statement = n;
  n_vars ++;

  return result;
}

/* Warn about function elimination.  */

static void
do_warn_function_elimination (gfc_expr *e)
{
  const char *name;
  if (e->expr_type == EXPR_FUNCTION
      && !gfc_pure_function (e, &name) && !gfc_implicit_pure_function (e))
   {
      if (name)
	  gfc_warning (OPT_Wfunction_elimination,
		      "Removing call to impure function %qs at %L", name,
		      &(e->where));
      else
	  gfc_warning (OPT_Wfunction_elimination,
		      "Removing call to impure function at %L",
		      &(e->where));
   }
}


/* Callback function for the code walker for doing common function
   elimination.  This builds up the list of functions in the expression
   and goes through them to detect duplicates, which it then replaces
   by variables.  */

static int
cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
	  void *data ATTRIBUTE_UNUSED)
{
  int i,j;
  gfc_expr *newvar;
  gfc_expr **ei, **ej;

  /* Don't do this optimization within OMP workshare/atomic or ASSOC lists.  */

  if (in_omp_workshare || in_omp_atomic || in_assoc_list)
    {
      *walk_subtrees = 0;
      return 0;
    }

  expr_array.release ();

  gfc_expr_walker (e, cfe_register_funcs, NULL);

  /* Walk through all the functions.  */

  FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1)
    {
      /* Skip if the function has been replaced by a variable already.  */
      if ((*ei)->expr_type == EXPR_VARIABLE)
	continue;

      newvar = NULL;
      for (j=0; j<i; j++)
	{
	  ej = expr_array[j];
	  if (gfc_dep_compare_functions (*ei, *ej, true) == 0)
	    {
	      if (newvar == NULL)
		newvar = create_var (*ei, "fcn");

	      if (warn_function_elimination)
		do_warn_function_elimination (*ej);

	      free (*ej);
	      *ej = gfc_copy_expr (newvar);
	    }
	}
      if (newvar)
	*ei = newvar;
    }

  /* We did all the necessary walking in this function.  */
  *walk_subtrees = 0;
  return 0;
}

/* Callback function for common function elimination, called from
   gfc_code_walker.  This keeps track of the current code, in order
   to insert statements as needed.  */

static int
cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
{
  current_code = c;
  inserted_block = NULL;
  changed_statement = NULL;

  /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
     and allocation on assignment are prohibited inside WHERE, and finally
     masking an expression would lead to wrong-code when replacing

     WHERE (a>0)
       b = sum(foo(a) + foo(a))
     END WHERE

     with

     WHERE (a > 0)
       tmp = foo(a)
       b = sum(tmp + tmp)
     END WHERE
*/

  if ((*c)->op == EXEC_WHERE)
    {
      *walk_subtrees = 0;
      return 0;
    }


  return 0;
}

/* Dummy function for expression call back, for use when we
   really don't want to do any walking.  */

static int
dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
		     void *data ATTRIBUTE_UNUSED)
{
  *walk_subtrees = 0;
  return 0;
}

/* Dummy function for code callback, for use when we really
   don't want to do anything.  */
int
gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
			 int *walk_subtrees ATTRIBUTE_UNUSED,
			 void *data ATTRIBUTE_UNUSED)
{
  return 0;
}

/* Code callback function for converting
   do while(a)
   end do
   into the equivalent
   do
     if (.not. a) exit
   end do
   This is because common function elimination would otherwise place the
   temporary variables outside the loop.  */

static int
convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
		  void *data ATTRIBUTE_UNUSED)
{
  gfc_code *co = *c;
  gfc_code *c_if1, *c_if2, *c_exit;
  gfc_code *loopblock;
  gfc_expr *e_not, *e_cond;

  if (co->op != EXEC_DO_WHILE)
    return 0;

  if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
    return 0;

  e_cond = co->expr1;

  /* Generate the condition of the if statement, which is .not. the original
     statement.  */
  e_not = gfc_get_expr ();
  e_not->ts = e_cond->ts;
  e_not->where = e_cond->where;
  e_not->expr_type = EXPR_OP;
  e_not->value.op.op = INTRINSIC_NOT;
  e_not->value.op.op1 = e_cond;

  /* Generate the EXIT statement.  */
  c_exit = XCNEW (gfc_code);
  c_exit->op = EXEC_EXIT;
  c_exit->ext.which_construct = co;
  c_exit->loc = co->loc;

  /* Generate the IF statement.  */
  c_if2 = XCNEW (gfc_code);
  c_if2->op = EXEC_IF;
  c_if2->expr1 = e_not;
  c_if2->next = c_exit;
  c_if2->loc = co->loc;

  /* ... plus the one to chain it to.  */
  c_if1 = XCNEW (gfc_code);
  c_if1->op = EXEC_IF;
  c_if1->block = c_if2;
  c_if1->loc = co->loc;

  /* Make the DO WHILE loop into a DO block by replacing the condition
     with a true constant.  */
  co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);

  /* Hang the generated if statement into the loop body.  */

  loopblock = co->block->next;
  co->block->next = c_if1;
  c_if1->next = loopblock;

  return 0;
}

/* Code callback function for converting
   if (a) then
   ...
   else if (b) then
   end if

   into
   if (a) then
   else
     if (b) then
     end if
   end if

   because otherwise common function elimination would place the BLOCKs
   into the wrong place.  */

static int
convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
		void *data ATTRIBUTE_UNUSED)
{
  gfc_code *co = *c;
  gfc_code *c_if1, *c_if2, *else_stmt;

  if (co->op != EXEC_IF)
    return 0;

  /* This loop starts out with the first ELSE statement.  */
  else_stmt = co->block->block;

  while (else_stmt != NULL)
    {
      gfc_code *next_else;

      /* If there is no condition, we're done.  */
      if (else_stmt->expr1 == NULL)
	break;

      next_else = else_stmt->block;

      /* Generate the new IF statement.  */
      c_if2 = XCNEW (gfc_code);
      c_if2->op = EXEC_IF;
      c_if2->expr1 = else_stmt->expr1;
      c_if2->next = else_stmt->next;
      c_if2->loc = else_stmt->loc;
      c_if2->block = next_else;

      /* ... plus the one to chain it to.  */
      c_if1 = XCNEW (gfc_code);
      c_if1->op = EXEC_IF;
      c_if1->block = c_if2;
      c_if1->loc = else_stmt->loc;

      /* Insert the new IF after the ELSE.  */
      else_stmt->expr1 = NULL;
      else_stmt->next = c_if1;
      else_stmt->block = NULL;

      else_stmt = next_else;
    }
  /*  Don't walk subtrees.  */
  return 0;
}

/* Callback function to var_in_expr - return true if expr1 and
   expr2 are identical variables. */
static int
var_in_expr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
		      void *data)
{
  gfc_expr *expr1 = (gfc_expr *) data;
  gfc_expr *expr2 = *e;

  if (expr2->expr_type != EXPR_VARIABLE)
    return 0;

  return expr1->symtree->n.sym == expr2->symtree->n.sym;
}

/* Return true if expr1 is found in expr2. */

static bool
var_in_expr (gfc_expr *expr1, gfc_expr *expr2)
{
  gcc_assert (expr1->expr_type == EXPR_VARIABLE);

  return gfc_expr_walker (&expr2, var_in_expr_callback, (void *) expr1);
}

struct do_stack
{
  struct do_stack *prev;
  gfc_iterator *iter;
  gfc_code *code;
} *stack_top;

/* Recursively traverse the block of a WRITE or READ statement, and maybe
   optimize by replacing do loops with their analog array slices.  For
   example:

     write (*,*) (a(i), i=1,4)

   is replaced with

     write (*,*) a(1:4:1) .  */

static bool
traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev)
{
  gfc_code *curr;
  gfc_expr *new_e, *expr, *start;
  gfc_ref *ref;
  struct do_stack ds_push;
  int i, future_rank = 0;
  gfc_iterator *iters[GFC_MAX_DIMENSIONS];
  gfc_expr *e;

  /* Find the first transfer/do statement.  */
  for (curr = code; curr; curr = curr->next)
    {
      if (curr->op == EXEC_DO || curr->op == EXEC_TRANSFER)
	break;
    }

  /* Ensure it is the only transfer/do statement because cases like

     write (*,*) (a(i), b(i), i=1,4)

     cannot be optimized.  */

  if (!curr || curr->next)
    return false;

  if (curr->op == EXEC_DO)
    {
      if (curr->ext.iterator->var->ref)
	return false;
      ds_push.prev = stack_top;
      ds_push.iter = curr->ext.iterator;
      ds_push.code = curr;
      stack_top = &ds_push;
      if (traverse_io_block (curr->block->next, has_reached, prev))
	{
	  if (curr != stack_top->code && !*has_reached)
	    {
	      curr->block->next = NULL;
	      gfc_free_statements (curr);
	    }
	  else
	    *has_reached = true;
	  return true;
	}
      return false;
    }

  gcc_assert (curr->op == EXEC_TRANSFER);

  e = curr->expr1;
  ref = e->ref;
  if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0 || ref->next)
    return false;

  /* Find the iterators belonging to each variable and check conditions.  */
  for (i = 0; i < ref->u.ar.dimen; i++)
    {
      if (!ref->u.ar.start[i] || ref->u.ar.start[i]->ref
	  || ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
	return false;

      start = ref->u.ar.start[i];
      gfc_simplify_expr (start, 0);
      switch (start->expr_type)
	{
	case EXPR_VARIABLE:

	  /* write (*,*) (a(i), i=a%b,1) not handled yet.  */
	  if (start->ref)
	    return false;

	  /*  Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4).  */
	  if (!stack_top || !stack_top->iter
	      || stack_top->iter->var->symtree != start->symtree)
	    {
	      /* Check for (a(i,i), i=1,3).  */
	      int j;

	      for (j=0; j<i; j++)
		if (iters[j] && iters[j]->var->symtree == start->symtree)
		  return false;

	      iters[i] = NULL;
	    }
	  else
	    {
	      iters[i] = stack_top->iter;
	      stack_top = stack_top->prev;
	      future_rank++;
	    }
	  break;
	case EXPR_CONSTANT:
	  iters[i] = NULL;
	  break;
	case EXPR_OP:
	  switch (start->value.op.op)
	    {
	    case INTRINSIC_PLUS:
	    case INTRINSIC_TIMES:
	      if (start->value.op.op1->expr_type != EXPR_VARIABLE)
		std::swap (start->value.op.op1, start->value.op.op2);
	      gcc_fallthrough ();
	    case INTRINSIC_MINUS:
	      if (start->value.op.op1->expr_type!= EXPR_VARIABLE
		  || start->value.op.op2->expr_type != EXPR_CONSTANT
		  || start->value.op.op1->ref)
		return false;
	      if (!stack_top || !stack_top->iter
		  || stack_top->iter->var->symtree
		  != start->value.op.op1->symtree)
		return false;
	      iters[i] = stack_top->iter;
	      stack_top = stack_top->prev;
	      break;
	    default:
	      return false;
	    }
	  future_rank++;
	  break;
	default:
	  return false;
	}
    }

  /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
  for (int i = 1; i < ref->u.ar.dimen; i++)
    {
      if (iters[i])
	{
	  gfc_expr *var = iters[i]->var;
	  for (int j = i - 1; j < i; j++)
	    {
	      if (iters[j]
		  && (var_in_expr (var, iters[j]->start)
		      || var_in_expr (var, iters[j]->end)
		      || var_in_expr (var, iters[j]->step)))
		  return false;
	    }
	}
    }

  /* Create new expr.  */
  new_e = gfc_copy_expr (curr->expr1);
  new_e->expr_type = EXPR_VARIABLE;
  new_e->rank = future_rank;
  if (curr->expr1->shape)
    new_e->shape = gfc_get_shape (new_e->rank);

  /* Assign new starts, ends and strides if necessary.  */
  for (i = 0; i < ref->u.ar.dimen; i++)
    {
      if (!iters[i])
	continue;
      start = ref->u.ar.start[i];
      switch (start->expr_type)
	{
	case EXPR_CONSTANT:
	  gfc_internal_error ("bad expression");
	  break;
	case EXPR_VARIABLE:
	  new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
	  new_e->ref->u.ar.type = AR_SECTION;
	  gfc_free_expr (new_e->ref->u.ar.start[i]);
	  new_e->ref->u.ar.start[i] = gfc_copy_expr (iters[i]->start);
	  new_e->ref->u.ar.end[i] = gfc_copy_expr (iters[i]->end);
	  new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step);
	  break;
	case EXPR_OP:
	  new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
	  new_e->ref->u.ar.type = AR_SECTION;
	  gfc_free_expr (new_e->ref->u.ar.start[i]);
	  expr = gfc_copy_expr (start);
	  expr->value.op.op1 = gfc_copy_expr (iters[i]->start);
	  new_e->ref->u.ar.start[i] = expr;
	  gfc_simplify_expr (new_e->ref->u.ar.start[i], 0);
	  expr = gfc_copy_expr (start);
	  expr->value.op.op1 = gfc_copy_expr (iters[i]->end);
	  new_e->ref->u.ar.end[i] = expr;
	  gfc_simplify_expr (new_e->ref->u.ar.end[i], 0);
	  switch (start->value.op.op)
	    {
	    case INTRINSIC_MINUS:
	    case INTRINSIC_PLUS:
	      new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step);
	      break;
	    case INTRINSIC_TIMES:
	      expr = gfc_copy_expr (start);
	      expr->value.op.op1 = gfc_copy_expr (iters[i]->step);
	      new_e->ref->u.ar.stride[i] = expr;
	      gfc_simplify_expr (new_e->ref->u.ar.stride[i], 0);
	      break;
	    default:
	      gfc_internal_error ("bad op");
	    }
	  break;
	default:
	  gfc_internal_error ("bad expression");
	}
    }
  curr->expr1 = new_e;

  /* Insert modified statement. Check whether the statement needs to be
     inserted at the lowest level.  */
  if (!stack_top->iter)
    {
      if (prev)
	{
	  curr->next = prev->next->next;
	  prev->next = curr;
	}
      else
	{
	  curr->next = stack_top->code->block->next->next->next;
	  stack_top->code->block->next = curr;
	}
    }
  else
    stack_top->code->block->next = curr;
  return true;
}

/* Function for the gfc_code_walker.  If code is a READ or WRITE statement, it
   tries to optimize its block.  */

static int
simplify_io_impl_do (gfc_code **code, int *walk_subtrees,
		     void *data ATTRIBUTE_UNUSED)
{
  gfc_code **curr, *prev = NULL;
  struct do_stack write, first;
  bool b = false;
  *walk_subtrees = 1;
  if (!(*code)->block
      || ((*code)->block->op != EXEC_WRITE
	  && (*code)->block->op != EXEC_READ))
    return 0;

  *walk_subtrees = 0;
  write.prev = NULL;
  write.iter = NULL;
  write.code = *code;

  for (curr = &(*code)->block; *curr; curr = &(*curr)->next)
    {
      if ((*curr)->op == EXEC_DO)
	{
	  first.prev = &write;
	  first.iter = (*curr)->ext.iterator;
	  first.code = *curr;
	  stack_top = &first;
	  traverse_io_block ((*curr)->block->next, &b, prev);
	  stack_top = NULL;
	}
      prev = *curr;
    }
  return 0;
}

/* Optimize a namespace, including all contained namespaces.
  flag_frontend_optimize and flag_fronend_loop_interchange are
  handled separately.  */

static void
optimize_namespace (gfc_namespace *ns)
{
  gfc_namespace *saved_ns = gfc_current_ns;
  current_ns = ns;
  gfc_current_ns = ns;
  forall_level = 0;
  iterator_level = 0;
  in_assoc_list = false;
  in_omp_workshare = false;
  in_omp_atomic = false;

  if (flag_frontend_optimize)
    {
      gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL);
      gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
      gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
      gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
      gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
      if (flag_inline_matmul_limit != 0 || flag_external_blas)
	{
	  bool found;
	  do
	    {
	      found = false;
	      gfc_code_walker (&ns->code, matmul_to_var_code, matmul_to_var_expr,
			       (void *) &found);
	    }
	  while (found);

	  gfc_code_walker (&ns->code, matmul_temp_args, dummy_expr_callback,
			   NULL);
	}

      if (flag_external_blas)
	gfc_code_walker (&ns->code, call_external_blas, dummy_expr_callback,
			 NULL);

      if (flag_inline_matmul_limit != 0)
	gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback,
			 NULL);
    }

  if (flag_frontend_loop_interchange)
    gfc_code_walker (&ns->code, index_interchange, dummy_expr_callback,
		     NULL);

  /* BLOCKs are handled in the expression walker below.  */
  for (ns = ns->contained; ns; ns = ns->sibling)
    {
      if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
	optimize_namespace (ns);
    }
  gfc_current_ns = saved_ns;
}

/* Handle dependencies for allocatable strings which potentially redefine
   themselves in an assignment.  */

static void
realloc_strings (gfc_namespace *ns)
{
  current_ns = ns;
  gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL);

  for (ns = ns->contained; ns; ns = ns->sibling)
    {
      if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
	realloc_strings (ns);
    }

}

static void
optimize_reduction (gfc_namespace *ns)
{
  current_ns = ns;
  gfc_code_walker (&ns->code, gfc_dummy_code_callback,
		   callback_reduction, NULL);

/* BLOCKs are handled in the expression walker below.  */
  for (ns = ns->contained; ns; ns = ns->sibling)
    {
      if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
	optimize_reduction (ns);
    }
}

/* Replace code like
   a = matmul(b,c) + d
   with
   a = matmul(b,c) ;   a = a + d
   where the array function is not elemental and not allocatable
   and does not depend on the left-hand side.
*/

static bool
optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
{
  gfc_expr *e;

  if (!*rhs)
    return false;

  e = *rhs;
  if (e->expr_type == EXPR_OP)
    {
      switch (e->value.op.op)
	{
	  /* Unary operators and exponentiation: Only look at a single
	     operand.  */
	case INTRINSIC_NOT:
	case INTRINSIC_UPLUS:
	case INTRINSIC_UMINUS:
	case INTRINSIC_PARENTHESES:
	case INTRINSIC_POWER:
	  if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
	    return true;
	  break;

	case INTRINSIC_CONCAT:
	  /* Do not do string concatenations.  */
	  break;

	default:
	  /* Binary operators.  */
	  if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
	    return true;

	  if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
	    return true;

	  break;
	}
    }
  else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
	   && ! (e->value.function.esym
		 && (e->value.function.esym->attr.elemental
		     || e->value.function.esym->attr.allocatable
		     || e->value.function.esym->ts.type != c->expr1->ts.type
		     || e->value.function.esym->ts.kind != c->expr1->ts.kind))
	   && ! (e->value.function.isym
		 && (e->value.function.isym->elemental
		     || e->ts.type != c->expr1->ts.type
		     || e->ts.kind != c->expr1->ts.kind))
	   && ! gfc_inline_intrinsic_function_p (e))
    {

      gfc_code *n;
      gfc_expr *new_expr;

      /* Insert a new assignment statement after the current one.  */
      n = XCNEW (gfc_code);
      n->op = EXEC_ASSIGN;
      n->loc = c->loc;
      n->next = c->next;
      c->next = n;

      n->expr1 = gfc_copy_expr (c->expr1);
      n->expr2 = c->expr2;
      new_expr = gfc_copy_expr (c->expr1);
      c->expr2 = e;
      *rhs = new_expr;

      return true;

    }

  /* Nothing to optimize.  */
  return false;
}

/* Remove unneeded TRIMs at the end of expressions.  */

static bool
remove_trim (gfc_expr *rhs)
{
  bool ret;

  ret = false;
  if (!rhs)
    return ret;

  /* Check for a // b // trim(c).  Looping is probably not
     necessary because the parser usually generates
     (// (// a b ) trim(c) ) , but better safe than sorry.  */

  while (rhs->expr_type == EXPR_OP
	 && rhs->value.op.op == INTRINSIC_CONCAT)
    rhs = rhs->value.op.op2;

  while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
	 && rhs->value.function.isym->id == GFC_ISYM_TRIM)
    {
      strip_function_call (rhs);
      /* Recursive call to catch silly stuff like trim ( a // trim(b)).  */
      remove_trim (rhs);
      ret = true;
    }

  return ret;
}

/* Optimizations for an assignment.  */

static void
optimize_assignment (gfc_code * c)
{
  gfc_expr *lhs, *rhs;

  lhs = c->expr1;
  rhs = c->expr2;

  if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred)
    {
      /* Optimize  a = trim(b)  to  a = b.  */
      remove_trim (rhs);

      /* Replace a = '   ' by a = '' to optimize away a memcpy.  */
      if (is_empty_string (rhs))
	rhs->value.character.length = 0;
    }

  if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
    optimize_binop_array_assignment (c, &rhs, false);
}


/* Remove an unneeded function call, modifying the expression.
   This replaces the function call with the value of its
   first argument.  The rest of the argument list is freed.  */

static void
strip_function_call (gfc_expr *e)
{
  gfc_expr *e1;
  gfc_actual_arglist *a;

  a = e->value.function.actual;

  /* We should have at least one argument.  */
  gcc_assert (a->expr != NULL);

  e1 = a->expr;

  /* Free the remaining arglist, if any.  */
  if (a->next)
    gfc_free_actual_arglist (a->next);

  /* Graft the argument expression onto the original function.  */
  *e = *e1;
  free (e1);

}

/* Optimization of lexical comparison functions.  */

static bool
optimize_lexical_comparison (gfc_expr *e)
{
  if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
    return false;

  switch (e->value.function.isym->id)
    {
    case GFC_ISYM_LLE:
      return optimize_comparison (e, INTRINSIC_LE);

    case GFC_ISYM_LGE:
      return optimize_comparison (e, INTRINSIC_GE);

    case GFC_ISYM_LGT:
      return optimize_comparison (e, INTRINSIC_GT);

    case GFC_ISYM_LLT:
      return optimize_comparison (e, INTRINSIC_LT);

    default:
      break;
    }
  return false;
}

/* Combine stuff like [a]>b into [a>b], for easier optimization later.  Do not
   do CHARACTER because of possible pessimization involving character
   lengths.  */

static bool
combine_array_constructor (gfc_expr *e)
{

  gfc_expr *op1, *op2;
  gfc_expr *scalar;
  gfc_expr *new_expr;
  gfc_constructor *c, *new_c;
  gfc_constructor_base oldbase, newbase;
  bool scalar_first;
  int n_elem;
  bool all_const;

  /* Array constructors have rank one.  */
  if (e->rank != 1)
    return false;

  /* Don't try to combine association lists, this makes no sense
     and leads to an ICE.  */
  if (in_assoc_list)
    return false;

  /* With FORALL, the BLOCKS created by create_var will cause an ICE.  */
  if (forall_level > 0)
    return false;

  /* Inside an iterator, things can get hairy; we are likely to create
     an invalid temporary variable.  */
  if (iterator_level > 0)
    return false;

  /* WHERE also doesn't work.  */
  if (in_where > 0)
    return false;

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

  if (!op1 || !op2)
    return false;

  if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
    scalar_first = false;
  else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0)
    {
      scalar_first = true;
      op1 = e->value.op.op2;
      op2 = e->value.op.op1;
    }
  else
    return false;

  if (op2->ts.type == BT_CHARACTER)
    return false;

  /* This might be an expanded constructor with very many constant values. If
     we perform the operation here, we might end up with a long compile time
     and actually longer execution time, so a length bound is in order here.
     If the constructor constains something which is not a constant, it did
     not come from an expansion, so leave it alone.  */

#define CONSTR_LEN_MAX 4

  oldbase = op1->value.constructor;

  n_elem = 0;
  all_const = true;
  for (c = gfc_constructor_first (oldbase); c; c = gfc_constructor_next(c))
    {
      if (c->expr->expr_type != EXPR_CONSTANT)
	{
	  all_const = false;
	  break;
	}
      n_elem += 1;
    }

  if (all_const && n_elem > CONSTR_LEN_MAX)
    return false;

#undef CONSTR_LEN_MAX

  newbase = NULL;
  e->expr_type = EXPR_ARRAY;

  scalar = create_var (gfc_copy_expr (op2), "constr");

  for (c = gfc_constructor_first (oldbase); c;
       c = gfc_constructor_next (c))
    {
      new_expr = gfc_get_expr ();
      new_expr->ts = e->ts;
      new_expr->expr_type = EXPR_OP;
      new_expr->rank = c->expr->rank;
      new_expr->where = c->expr->where;
      new_expr->value.op.op = e->value.op.op;

      if (scalar_first)
	{
	  new_expr->value.op.op1 = gfc_copy_expr (scalar);
	  new_expr->value.op.op2 = gfc_copy_expr (c->expr);
	}
      else
	{
	  new_expr->value.op.op1 = gfc_copy_expr (c->expr);
	  new_expr->value.op.op2 = gfc_copy_expr (scalar);
	}

      new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where));
      new_c->iterator = c->iterator;
      c->iterator = NULL;
    }

  gfc_free_expr (op1);
  gfc_free_expr (op2);
  gfc_free_expr (scalar);

  e->value.constructor = newbase;
  return true;
}

/* Recursive optimization of operators.  */

static bool
optimize_op (gfc_expr *e)
{
  bool changed;

  gfc_intrinsic_op op = e->value.op.op;

  changed = false;

  /* Only use new-style comparisons.  */
  switch(op)
    {
    case INTRINSIC_EQ_OS:
      op = INTRINSIC_EQ;
      break;

    case INTRINSIC_GE_OS:
      op = INTRINSIC_GE;
      break;

    case INTRINSIC_LE_OS:
      op = INTRINSIC_LE;
      break;

    case INTRINSIC_NE_OS:
      op = INTRINSIC_NE;
      break;

    case INTRINSIC_GT_OS:
      op = INTRINSIC_GT;
      break;

    case INTRINSIC_LT_OS:
      op = INTRINSIC_LT;
      break;

    default:
      break;
    }

  switch (op)
    {
    case INTRINSIC_EQ:
    case INTRINSIC_GE:
    case INTRINSIC_LE:
    case INTRINSIC_NE:
    case INTRINSIC_GT:
    case INTRINSIC_LT:
      changed = optimize_comparison (e, op);

      gcc_fallthrough ();
      /* Look at array constructors.  */
    case INTRINSIC_PLUS:
    case INTRINSIC_MINUS:
    case INTRINSIC_TIMES:
    case INTRINSIC_DIVIDE:
      return combine_array_constructor (e) || changed;

    default:
      break;
    }

  return false;
}


/* Return true if a constant string contains only blanks.  */

static bool
is_empty_string (gfc_expr *e)
{
  int i;

  if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
    return false;

  for (i=0; i < e->value.character.length; i++)
    {
      if (e->value.character.string[i] != ' ')
	return false;
    }

  return true;
}


/* Insert a call to the intrinsic len_trim. Use a different name for
   the symbol tree so we don't run into trouble when the user has
   renamed len_trim for some reason.  */

static gfc_expr*
get_len_trim_call (gfc_expr *str, int kind)
{
  gfc_expr *fcn;
  gfc_actual_arglist *actual_arglist, *next;

  fcn = gfc_get_expr ();
  fcn->expr_type = EXPR_FUNCTION;
  fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
  actual_arglist = gfc_get_actual_arglist ();
  actual_arglist->expr = str;
  next = gfc_get_actual_arglist ();
  next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
  actual_arglist->next = next;

  fcn->value.function.actual = actual_arglist;
  fcn->where = str->where;
  fcn->ts.type = BT_INTEGER;
  fcn->ts.kind = gfc_charlen_int_kind;

  gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
  fcn->symtree->n.sym->ts = fcn->ts;
  fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
  fcn->symtree->n.sym->attr.function = 1;
  fcn->symtree->n.sym->attr.elemental = 1;
  fcn->symtree->n.sym->attr.referenced = 1;
  fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
  gfc_commit_symbol (fcn->symtree->n.sym);

  return fcn;
}


/* Optimize expressions for equality.  */

static bool
optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
{
  gfc_expr *op1, *op2;
  bool change;
  int eq;
  bool result;
  gfc_actual_arglist *firstarg, *secondarg;

  if (e->expr_type == EXPR_OP)
    {
      firstarg = NULL;
      secondarg = NULL;
      op1 = e->value.op.op1;
      op2 = e->value.op.op2;
    }
  else if (e->expr_type == EXPR_FUNCTION)
    {
      /* One of the lexical comparison functions.  */
      firstarg = e->value.function.actual;
      secondarg = firstarg->next;
      op1 = firstarg->expr;
      op2 = secondarg->expr;
    }
  else
    gcc_unreachable ();

  /* Strip off unneeded TRIM calls from string comparisons.  */

  change = remove_trim (op1);

  if (remove_trim (op2))
    change = true;

  /* An expression of type EXPR_CONSTANT is only valid for scalars.  */
  /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
     handles them well). However, there are also cases that need a non-scalar
     argument. For example the any intrinsic. See PR 45380.  */
  if (e->rank > 0)
    return change;

  /* Replace a == '' with len_trim(a) == 0 and a /= '' with
     len_trim(a) != 0 */
  if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
      && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
    {
      bool empty_op1, empty_op2;
      empty_op1 = is_empty_string (op1);
      empty_op2 = is_empty_string (op2);

      if (empty_op1 || empty_op2)
	{
	  gfc_expr *fcn;
	  gfc_expr *zero;
	  gfc_expr *str;

	  /* This can only happen when an error for comparing
	     characters of different kinds has already been issued.  */
	  if (empty_op1 && empty_op2)
	    return false;

	  zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
	  str = empty_op1 ? op2 : op1;

	  fcn = get_len_trim_call (str, gfc_charlen_int_kind);


	  if (empty_op1)
	    gfc_free_expr (op1);
	  else
	    gfc_free_expr (op2);

	  op1 = fcn;
	  op2 = zero;
	  e->value.op.op1 = fcn;
	  e->value.op.op2 = zero;
	}
    }


  /* Don't compare REAL or COMPLEX expressions when honoring NaNs.  */

  if (flag_finite_math_only
      || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
	  && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
    {
      eq = gfc_dep_compare_expr (op1, op2);
      if (eq <= -2)
	{
	  /* Replace A // B < A // C with B < C, and A // B < C // B
	     with A < C.  */
	  if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
	      && op1->expr_type == EXPR_OP
	      && op1->value.op.op == INTRINSIC_CONCAT
	      && op2->expr_type == EXPR_OP
	      && op2->value.op.op == INTRINSIC_CONCAT)
	    {
	      gfc_expr *op1_left = op1->value.op.op1;
	      gfc_expr *op2_left = op2->value.op.op1;
	      gfc_expr *op1_right = op1->value.op.op2;
	      gfc_expr *op2_right = op2->value.op.op2;

	      if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
		{
		  /* Watch out for 'A ' // x vs. 'A' // x.  */

		  if (op1_left->expr_type == EXPR_CONSTANT
			&& op2_left->expr_type == EXPR_CONSTANT
			&& op1_left->value.character.length
			   != op2_left->value.character.length)
		    return change;
		  else
		    {
		      free (op1_left);
		      free (op2_left);
		      if (firstarg)
			{
			  firstarg->expr = op1_right;
			  secondarg->expr = op2_right;
			}
		      else
			{
			  e->value.op.op1 = op1_right;
			  e->value.op.op2 = op2_right;
			}
		      optimize_comparison (e, op);
		      return true;
		    }
		}
	      if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
		{
		  free (op1_right);
		  free (op2_right);
		  if (firstarg)
		    {
		      firstarg->expr = op1_left;
		      secondarg->expr = op2_left;
		    }
		  else
		    {
		      e->value.op.op1 = op1_left;
		      e->value.op.op2 = op2_left;
		    }

		  optimize_comparison (e, op);
		  return true;
		}
	    }
	}
      else
	{
	  /* eq can only be -1, 0 or 1 at this point.  */
	  switch (op)
	    {
	    case INTRINSIC_EQ:
	      result = eq == 0;
	      break;

	    case INTRINSIC_GE:
	      result = eq >= 0;
	      break;

	    case INTRINSIC_LE:
	      result = eq <= 0;
	      break;

	    case INTRINSIC_NE:
	      result = eq != 0;
	      break;

	    case INTRINSIC_GT:
	      result = eq > 0;
	      break;

	    case INTRINSIC_LT:
	      result = eq < 0;
	      break;

	    default:
	      gfc_internal_error ("illegal OP in optimize_comparison");
	      break;
	    }

	  /* Replace the expression by a constant expression.  The typespec
	     and where remains the way it is.  */
	  free (op1);
	  free (op2);
	  e->expr_type = EXPR_CONSTANT;
	  e->value.logical = result;
	  return true;
	}
    }

  return change;
}

/* Optimize a trim function by replacing it with an equivalent substring
   involving a call to len_trim.  This only works for expressions where
   variables are trimmed.  Return true if anything was modified.  */

static bool
optimize_trim (gfc_expr *e)
{
  gfc_expr *a;
  gfc_ref *ref;
  gfc_expr *fcn;
  gfc_ref **rr = NULL;

  /* Don't do this optimization within an argument list, because
     otherwise aliasing issues may occur.  */

  if (count_arglist != 1)
    return false;

  if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
      || e->value.function.isym == NULL
      || e->value.function.isym->id != GFC_ISYM_TRIM)
    return false;

  a = e->value.function.actual->expr;

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

  /* This would pessimize the idiom a = trim(a) for reallocatable strings.  */

  if (a->symtree->n.sym->attr.allocatable)
    return false;

  /* Follow all references to find the correct place to put the newly
     created reference.  FIXME:  Also handle substring references and
     array references.  Array references cause strange regressions at
     the moment.  */

  if (a->ref)
    {
      for (rr = &(a->ref); *rr; rr = &((*rr)->next))
	{
	  if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
	    return false;
	}
    }

  strip_function_call (e);

  if (e->ref == NULL)
    rr = &(e->ref);

  /* Create the reference.  */

  ref = gfc_get_ref ();
  ref->type = REF_SUBSTRING;

  /* Set the start of the reference.  */

  ref->u.ss.start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);

  /* Build the function call to len_trim(x, gfc_default_integer_kind).  */

  fcn = get_len_trim_call (gfc_copy_expr (e), gfc_charlen_int_kind);

  /* Set the end of the reference to the call to len_trim.  */

  ref->u.ss.end = fcn;
  gcc_assert (rr != NULL && *rr == NULL);
  *rr = ref;
  return true;
}

/* Optimize minloc(b), where b is rank 1 array, into
   (/ minloc(b, dim=1) /), and similarly for maxloc,
   as the latter forms are expanded inline.  */

static void
optimize_minmaxloc (gfc_expr **e)
{
  gfc_expr *fn = *e;
  gfc_actual_arglist *a;
  char *name, *p;

  if (fn->rank != 1
      || fn->value.function.actual == NULL
      || fn->value.function.actual->expr == NULL
      || fn->value.function.actual->expr->ts.type == BT_CHARACTER
      || fn->value.function.actual->expr->rank != 1)
    return;

  *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
  (*e)->shape = fn->shape;
  fn->rank = 0;
  fn->shape = NULL;
  gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);

  name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
  strcpy (name, fn->value.function.name);
  p = strstr (name, "loc0");
  p[3] = '1';
  fn->value.function.name = gfc_get_string ("%s", name);
  if (fn->value.function.actual->next)
    {
      a = fn->value.function.actual->next;
      gcc_assert (a->expr == NULL);
    }
  else
    {
      a = gfc_get_actual_arglist ();
      fn->value.function.actual->next = a;
    }
  a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
				   &fn->where);
  mpz_set_ui (a->expr->value.integer, 1);
}

/* Data package to hand down for DO loop checks in a contained
   procedure.  */
typedef struct contained_info
{
  gfc_symbol *do_var;
  gfc_symbol *procedure;
  locus where_do;
} contained_info;

static enum gfc_exec_op last_io_op;

/* Callback function to check for INTENT(OUT) and INTENT(INOUT) in a
   contained function call.  */

static int
doloop_contained_function_call (gfc_expr **e,
				int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
{
  gfc_expr *expr = *e;
  gfc_formal_arglist *f;
  gfc_actual_arglist *a;
  gfc_symbol *sym, *do_var;
  contained_info *info;

  if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym
      || expr->value.function.esym == NULL)
    return 0;

  sym = expr->value.function.esym;
  f = gfc_sym_get_dummy_args (sym);
  if (f == NULL)
    return 0;

  info = (contained_info *) data;
  do_var = info->do_var;
  a = expr->value.function.actual;

  while (a && f)
    {
      if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
	{
	  if (f->sym->attr.intent == INTENT_OUT)
	    {
	      gfc_error_now ("Index variable %qs set to undefined as "
			     "INTENT(OUT) argument at %L in procedure %qs "
			     "called from within DO loop at %L", do_var->name,
			     &a->expr->where, info->procedure->name,
			     &info->where_do);
	      return 1;
	    }
	  else if (f->sym->attr.intent == INTENT_INOUT)
	    {
	      gfc_error_now ("Index variable %qs not definable as "
			     "INTENT(INOUT) argument at %L in procedure %qs "
			     "called from within DO loop at %L", do_var->name,
			     &a->expr->where, info->procedure->name,
			     &info->where_do);
	      return 1;
	    }
	}
      a = a->next;
      f = f->next;
    }
  return 0;
}

/* Callback function that goes through the code in a contained
   procedure to make sure it does not change a variable in a DO
   loop.  */

static int
doloop_contained_procedure_code (gfc_code **c,
				 int *walk_subtrees ATTRIBUTE_UNUSED,
				 void *data)
{
  gfc_code *co = *c;
  contained_info *info = (contained_info *) data;
  gfc_symbol *do_var = info->do_var;
  const char *errmsg = _("Index variable %qs redefined at %L in procedure %qs "
			 "called from within DO loop at %L");
  static enum gfc_exec_op saved_io_op;

  switch (co->op)
    {
    case EXEC_ASSIGN:
      if (co->expr1->symtree && co->expr1->symtree->n.sym == do_var)
	gfc_error_now (errmsg, do_var->name, &co->loc, info->procedure->name,
		       &info->where_do);
      break;

    case EXEC_DO:
      if (co->ext.iterator && co->ext.iterator->var
	  && co->ext.iterator->var->symtree->n.sym == do_var)
	gfc_error (errmsg, do_var->name, &co->loc, info->procedure->name,
		   &info->where_do);
      break;

    case EXEC_READ:
    case EXEC_WRITE:
    case EXEC_INQUIRE:
    case EXEC_IOLENGTH:
      saved_io_op = last_io_op;
      last_io_op = co->op;
      break;

    case EXEC_OPEN:
      if (co->ext.open && co->ext.open->iostat
	  && co->ext.open->iostat->symtree->n.sym == do_var)
	gfc_error_now (errmsg, do_var->name, &co->ext.open->iostat->where,
		       info->procedure->name, &info->where_do);
      break;

    case EXEC_CLOSE:
      if (co->ext.close && co->ext.close->iostat
	  && co->ext.close->iostat->symtree->n.sym == do_var)
	gfc_error_now (errmsg, do_var->name, &co->ext.close->iostat->where,
		       info->procedure->name, &info->where_do);
      break;

    case EXEC_TRANSFER:
      switch (last_io_op)
	{

	case EXEC_INQUIRE:
#define CHECK_INQ(a) do { if (co->ext.inquire    &&			\
			      co->ext.inquire->a &&			\
			      co->ext.inquire->a->symtree->n.sym == do_var) \
	      gfc_error_now (errmsg, do_var->name,			\
			     &co->ext.inquire->a->where,		\
			     info->procedure->name,			\
			     &info->where_do);				\
	  } while (0)

	  CHECK_INQ(iostat);
	  CHECK_INQ(number);
	  CHECK_INQ(position);
	  CHECK_INQ(recl);
	  CHECK_INQ(position);
	  CHECK_INQ(iolength);
	  CHECK_INQ(strm_pos);
	  break;
#undef CHECK_INQ

	case EXEC_READ:
	  if (co->expr1 && co->expr1->symtree
	      && co->expr1->symtree->n.sym == do_var)
	    gfc_error_now (errmsg, do_var->name, &co->expr1->where,
			   info->procedure->name, &info->where_do);

	  /* Fallthrough.  */

	case EXEC_WRITE:
	  if (co->ext.dt && co->ext.dt->iostat && co->ext.dt->iostat->symtree
	      && co->ext.dt->iostat->symtree->n.sym == do_var)
	    gfc_error_now (errmsg, do_var->name, &co->ext.dt->iostat->where,
			   info->procedure->name, &info->where_do);
	  break;

	case EXEC_IOLENGTH:
	  if (co->expr1 && co->expr1->symtree
	      && co->expr1->symtree->n.sym == do_var)
	    gfc_error_now (errmsg, do_var->name, &co->expr1->where,
			   info->procedure->name, &info->where_do);
	  break;

	default:
	  gcc_unreachable ();
	}
      break;

    case EXEC_DT_END:
      last_io_op = saved_io_op;
      break;

    case EXEC_CALL:
      gfc_formal_arglist *f;
      gfc_actual_arglist *a;

      f = gfc_sym_get_dummy_args (co->resolved_sym);
      if (f == NULL)
	break;
      a = co->ext.actual;
      /* Slightly different error message here. If there is an error,
	 return 1 to avoid an infinite loop.  */
      while (a && f)
	{
	  if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
	    {
	      if (f->sym->attr.intent == INTENT_OUT)
		{
		  gfc_error_now ("Index variable %qs set to undefined as "
				 "INTENT(OUT) argument at %L in subroutine %qs "
				 "called from within DO loop at %L",
				 do_var->name, &a->expr->where,
				 info->procedure->name, &info->where_do);
		  return 1;
		}
	      else if (f->sym->attr.intent == INTENT_INOUT)
		{
		  gfc_error_now ("Index variable %qs not definable as "
				 "INTENT(INOUT) argument at %L in subroutine %qs "
				 "called from within DO loop at %L", do_var->name,
				 &a->expr->where, info->procedure->name,
				 &info->where_do);
		  return 1;
		}
	    }
	  a = a->next;
	  f = f->next;
	}
      break;
    default:
      break;
    }
  return 0;
}

/* Callback function for code checking that we do not pass a DO variable to an
   INTENT(OUT) or INTENT(INOUT) dummy variable.  */

static int
doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
	 void *data ATTRIBUTE_UNUSED)
{
  gfc_code *co;
  int i;
  gfc_formal_arglist *f;
  gfc_actual_arglist *a;
  gfc_code *cl;
  do_t loop, *lp;
  bool seen_goto;

  co = *c;

  /* If the doloop_list grew, we have to truncate it here.  */

  if ((unsigned) doloop_level < doloop_list.length())
    doloop_list.truncate (doloop_level);

  seen_goto = false;
  switch (co->op)
    {
    case EXEC_DO:

      if (co->ext.iterator && co->ext.iterator->var)
	loop.c = co;
      else
	loop.c = NULL;

      loop.branch_level = if_level + select_level;
      loop.seen_goto = false;
      doloop_list.safe_push (loop);
      break;

      /* If anything could transfer control away from a suspicious
	 subscript, make sure to set seen_goto in the current DO loop
	 (if any).  */
    case EXEC_GOTO:
    case EXEC_EXIT:
    case EXEC_STOP:
    case EXEC_ERROR_STOP:
    case EXEC_CYCLE:
      seen_goto = true;
      break;

    case EXEC_OPEN:
      if (co->ext.open->err)
	seen_goto = true;
      break;

    case EXEC_CLOSE:
      if (co->ext.close->err)
	seen_goto = true;
      break;

    case EXEC_BACKSPACE:
    case EXEC_ENDFILE:
    case EXEC_REWIND:
    case EXEC_FLUSH:

      if (co->ext.filepos->err)
	seen_goto = true;
      break;

    case EXEC_INQUIRE:
      if (co->ext.filepos->err)
	seen_goto = true;
      break;

    case EXEC_READ:
    case EXEC_WRITE:
      if (co->ext.dt->err || co->ext.dt->end || co->ext.dt->eor)
	seen_goto = true;
      break;

    case EXEC_WAIT:
      if (co->ext.wait->err || co->ext.wait->end || co->ext.wait->eor)
	loop.seen_goto = true;
      break;

    case EXEC_CALL:
      if (co->resolved_sym == NULL)
	break;

      /* Test if somebody stealthily changes the DO variable from
	 under us by changing it in a host-associated procedure.  */
      if (co->resolved_sym->attr.contained)
	{
	  FOR_EACH_VEC_ELT (doloop_list, i, lp)
	    {
	      gfc_symbol *sym = co->resolved_sym;
	      contained_info info;
	      gfc_namespace *ns;

	      cl = lp->c;
	      info.do_var = cl->ext.iterator->var->symtree->n.sym;
	      info.procedure = co->resolved_sym;  /* sym? */
	      info.where_do = co->loc;
	      /* Look contained procedures under the namespace of the
		 variable.  */
	      for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
		if (ns->proc_name && ns->proc_name == sym)
		  gfc_code_walker (&ns->code, doloop_contained_procedure_code,
				   doloop_contained_function_call, &info);
	    }
	}

      f = gfc_sym_get_dummy_args (co->resolved_sym);

      /* Withot a formal arglist, there is only unknown INTENT,
	 which we don't check for.  */
      if (f == NULL)
	break;

      a = co->ext.actual;

      while (a && f)
	{
	  FOR_EACH_VEC_ELT (doloop_list, i, lp)
	    {
	      gfc_symbol *do_sym;
	      cl = lp->c;

	      if (cl == NULL)
		break;

	      do_sym = cl->ext.iterator->var->symtree->n.sym;

	      if (a->expr && a->expr->symtree && f->sym
		  && a->expr->symtree->n.sym == do_sym)
		{
		  if (f->sym->attr.intent == INTENT_OUT)
		    gfc_error_now ("Variable %qs at %L set to undefined "
				   "value inside loop beginning at %L as "
				   "INTENT(OUT) argument to subroutine %qs",
				   do_sym->name, &a->expr->where,
				   &(doloop_list[i].c->loc),
				   co->symtree->n.sym->name);
		  else if (f->sym->attr.intent == INTENT_INOUT)
		    gfc_error_now ("Variable %qs at %L not definable inside "
				   "loop beginning at %L as INTENT(INOUT) "
				   "argument to subroutine %qs",
				   do_sym->name, &a->expr->where,
				   &(doloop_list[i].c->loc),
				   co->symtree->n.sym->name);
		}
	    }
	  a = a->next;
	  f = f->next;
	}

      break;

    default:
      break;
    }
  if (seen_goto && doloop_level > 0)
    doloop_list[doloop_level-1].seen_goto = true;

  return 0;
}

/* Callback function to warn about different things within DO loops.  */

static int
do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
	     void *data ATTRIBUTE_UNUSED)
{
  do_t *last;

  if (doloop_list.length () == 0)
    return 0;

  if ((*e)->expr_type == EXPR_FUNCTION)
    do_intent (e);

  last = &doloop_list.last();
  if (last->seen_goto && !warn_do_subscript)
    return 0;

  if ((*e)->expr_type == EXPR_VARIABLE)
    do_subscript (e);

  return 0;
}

typedef struct
{
  gfc_symbol *sym;
  mpz_t val;
} insert_index_t;

/* Callback function - if the expression is the variable in data->sym,
   replace it with a constant from data->val.  */

static int
callback_insert_index (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
		       void *data)
{
  insert_index_t *d;
  gfc_expr *ex, *n;

  ex = (*e);
  if (ex->expr_type != EXPR_VARIABLE)
    return 0;

  d = (insert_index_t *) data;
  if (ex->symtree->n.sym != d->sym)
    return 0;

  n = gfc_get_constant_expr (BT_INTEGER, ex->ts.kind, &ex->where);
  mpz_set (n->value.integer, d->val);

  gfc_free_expr (ex);
  *e = n;
  return 0;
}

/* In the expression e, replace occurrences of the variable sym with
   val.  If this results in a constant expression, return true and
   return the value in ret.  Return false if the expression already
   is a constant.  Caller has to clear ret in that case.  */

static bool
insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret)
{
  gfc_expr *n;
  insert_index_t data;
  bool rc;

  if (e->expr_type == EXPR_CONSTANT)
    return false;

  n = gfc_copy_expr (e);
  data.sym = sym;
  mpz_init_set (data.val, val);
  gfc_expr_walker (&n, callback_insert_index, (void *) &data);

  /* Suppress errors here - we could get errors here such as an
     out of bounds access for arrays, see PR 90563.  */
  gfc_push_suppress_errors ();
  gfc_simplify_expr (n, 0);
  gfc_pop_suppress_errors ();

  if (n->expr_type == EXPR_CONSTANT)
    {
      rc = true;
      mpz_init_set (ret, n->value.integer);
    }
  else
    rc = false;

  mpz_clear (data.val);
  gfc_free_expr (n);
  return rc;

}

/* Check array subscripts for possible out-of-bounds accesses in DO
   loops with constant bounds.  */

static int
do_subscript (gfc_expr **e)
{
  gfc_expr *v;
  gfc_array_ref *ar;
  gfc_ref *ref;
  int i,j;
  gfc_code *dl;
  do_t *lp;

  v = *e;
  /* Constants are already checked.  */
  if (v->expr_type == EXPR_CONSTANT)
    return 0;

  /* Wrong warnings will be generated in an associate list.  */
  if (in_assoc_list)
    return 0;

  /* We already warned about this.  */
  if (v->do_not_warn)
    return 0;

  v->do_not_warn = 1;

  for (ref = v->ref; ref; ref = ref->next)
    {
      if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
	{
	  ar = & ref->u.ar;
	  FOR_EACH_VEC_ELT (doloop_list, j, lp)
	    {
	      gfc_symbol *do_sym;
	      mpz_t do_start, do_step, do_end;
	      bool have_do_start, have_do_end;
	      bool error_not_proven;
	      int warn;
	      int sgn;

	      dl = lp->c;
	      if (dl == NULL)
		break;

	      /* If we are within a branch, or a goto or equivalent
		 was seen in the DO loop before, then we cannot prove that
		 this expression is actually evaluated.  Don't do anything
		 unless we want to see it all.  */
	      error_not_proven = lp->seen_goto
		|| lp->branch_level < if_level + select_level;

	      if (error_not_proven && !warn_do_subscript)
		break;

	      if (error_not_proven)
		warn = OPT_Wdo_subscript;
	      else
		warn = 0;

	      do_sym = dl->ext.iterator->var->symtree->n.sym;
	      if (do_sym->ts.type != BT_INTEGER)
		continue;

	      /* If we do not know about the stepsize, the loop may be zero trip.
		 Do not warn in this case.  */

	      if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
		{
		  sgn = mpz_cmp_ui (dl->ext.iterator->step->value.integer, 0);
		  /* This can happen, but then the error has been
		     reported previously.  */
		  if (sgn == 0)
		    continue;

		  mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
		}

	      else
		continue;

	      if (dl->ext.iterator->start->expr_type == EXPR_CONSTANT)
		{
		  have_do_start = true;
		  mpz_init_set (do_start, dl->ext.iterator->start->value.integer);
		}
	      else
		have_do_start = false;

	      if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
		{
		  have_do_end = true;
		  mpz_init_set (do_end, dl->ext.iterator->end->value.integer);
		}
	      else
		have_do_end = false;

	      if (!have_do_start && !have_do_end)
		return 0;

	      /* No warning inside a zero-trip loop.  */
	      if (have_do_start && have_do_end)
		{
		  int cmp;

		  cmp = mpz_cmp (do_end, do_start);
		  if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
		    break;
		}

	      /* May have to correct the end value if the step does not equal
		 one.  */
	      if (have_do_start && have_do_end && mpz_cmp_ui (do_step, 1) != 0)
		{
		  mpz_t diff, rem;

		  mpz_init (diff);
		  mpz_init (rem);
		  mpz_sub (diff, do_end, do_start);
		  mpz_tdiv_r (rem, diff, do_step);
		  mpz_sub (do_end, do_end, rem);
		  mpz_clear (diff);
		  mpz_clear (rem);
		}

	      for (i = 0; i< ar->dimen; i++)
		{
		  mpz_t val;
		  if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_start
		      && insert_index (ar->start[i], do_sym, do_start, val))
		    {
		      if (ar->as->lower[i]
			  && ar->as->lower[i]->expr_type == EXPR_CONSTANT
			  && ar->as->lower[i]->ts.type == BT_INTEGER
			  && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
			gfc_warning (warn, "Array reference at %L out of bounds "
				     "(%ld < %ld) in loop beginning at %L",
				     &ar->start[i]->where, mpz_get_si (val),
				     mpz_get_si (ar->as->lower[i]->value.integer),
				     &doloop_list[j].c->loc);

		      if (ar->as->upper[i]
			  && ar->as->upper[i]->expr_type == EXPR_CONSTANT
			  && ar->as->upper[i]->ts.type == BT_INTEGER
			  && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
			    gfc_warning (warn, "Array reference at %L out of bounds "
					 "(%ld > %ld) in loop beginning at %L",
					 &ar->start[i]->where, mpz_get_si (val),
					 mpz_get_si (ar->as->upper[i]->value.integer),
					 &doloop_list[j].c->loc);

		      mpz_clear (val);
		    }

		  if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_end
		      && insert_index (ar->start[i], do_sym, do_end, val))
		    {
		      if (ar->as->lower[i]
			  && ar->as->lower[i]->expr_type == EXPR_CONSTANT
			  && ar->as->lower[i]->ts.type == BT_INTEGER
			  && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
			gfc_warning (warn, "Array reference at %L out of bounds "
				     "(%ld < %ld) in loop beginning at %L",
				     &ar->start[i]->where, mpz_get_si (val),
				     mpz_get_si (ar->as->lower[i]->value.integer),
				     &doloop_list[j].c->loc);

		      if (ar->as->upper[i]
			  && ar->as->upper[i]->expr_type == EXPR_CONSTANT
			  && ar->as->upper[i]->ts.type == BT_INTEGER
			  && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
			gfc_warning (warn, "Array reference at %L out of bounds "
				     "(%ld > %ld) in loop beginning at %L",
				     &ar->start[i]->where, mpz_get_si (val),
				     mpz_get_si (ar->as->upper[i]->value.integer),
				     &doloop_list[j].c->loc);

		      mpz_clear (val);
		    }
		}
	    }
	}
    }
  return 0;
}
/* Function for functions checking that we do not pass a DO variable
   to an INTENT(OUT) or INTENT(INOUT) dummy variable.  */

static int
do_intent (gfc_expr **e)
{
  gfc_formal_arglist *f;
  gfc_actual_arglist *a;
  gfc_expr *expr;
  gfc_code *dl;
  do_t *lp;
  int i;
  gfc_symbol *sym;

  expr = *e;
  if (expr->expr_type != EXPR_FUNCTION)
    return 0;

  /* Intrinsic functions don't modify their arguments.  */

  if (expr->value.function.isym)
    return 0;

  sym = expr->value.function.esym;
  if (sym == NULL)
    return 0;

  if (sym->attr.contained)
    {
      FOR_EACH_VEC_ELT (doloop_list, i, lp)
	{
	  contained_info info;
	  gfc_namespace *ns;

	  dl = lp->c;
	  info.do_var = dl->ext.iterator->var->symtree->n.sym;
	  info.procedure = sym;
	  info.where_do = expr->where;
	  /* Look contained procedures under the namespace of the
		 variable.  */
	  for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
	    if (ns->proc_name && ns->proc_name == sym)
	      gfc_code_walker (&ns->code, doloop_contained_procedure_code,
			       dummy_expr_callback, &info);
	}
    }

  f = gfc_sym_get_dummy_args (sym);

  /* Without a formal arglist, there is only unknown INTENT,
     which we don't check for.  */
  if (f == NULL)
    return 0;

  a = expr->value.function.actual;

  while (a && f)
    {
      FOR_EACH_VEC_ELT (doloop_list, i, lp)
	{
	  gfc_symbol *do_sym;
	  dl = lp->c;
	  if (dl == NULL)
	    break;

	  do_sym = dl->ext.iterator->var->symtree->n.sym;

	  if (a->expr && a->expr->symtree
	      && a->expr->symtree->n.sym == do_sym)
	    {
	      if (f->sym->attr.intent == INTENT_OUT)
		gfc_error_now ("Variable %qs at %L set to undefined value "
			       "inside loop beginning at %L as INTENT(OUT) "
			       "argument to function %qs", do_sym->name,
			       &a->expr->where, &doloop_list[i].c->loc,
			       expr->symtree->n.sym->name);
	      else if (f->sym->attr.intent == INTENT_INOUT)
		gfc_error_now ("Variable %qs at %L not definable inside loop"
			       " beginning at %L as INTENT(INOUT) argument to"
			       " function %qs", do_sym->name,
			       &a->expr->where, &doloop_list[i].c->loc,
			       expr->symtree->n.sym->name);
	    }
	}
      a = a->next;
      f = f->next;
    }

  return 0;
}

static void
doloop_warn (gfc_namespace *ns)
{
  gfc_code_walker (&ns->code, doloop_code, do_function, NULL);

  for (ns = ns->contained; ns; ns = ns->sibling)
    {
      if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
	doloop_warn (ns);
    }
}

/* This selction deals with inlining calls to MATMUL.  */

/* Replace calls to matmul outside of straight assignments with a temporary
   variable so that later inlining will work.  */

static int
matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
		    void *data)
{
  gfc_expr *e, *n;
  bool *found = (bool *) data;

  e = *ep;

  if (e->expr_type != EXPR_FUNCTION
      || e->value.function.isym == NULL
      || e->value.function.isym->id != GFC_ISYM_MATMUL)
    return 0;

  if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
      || in_omp_atomic || in_where || in_assoc_list)
    return 0;

  /* Check if this is already in the form c = matmul(a,b).  */

  if ((*current_code)->expr2 == e)
    return 0;

  n = create_var (e, "matmul");