2010-04-27 Tobias Burnus <burnus@net-b.de>

[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-array.c

/* Array translation routines
   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
   Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>
   and Steven Bosscher <s.bosscher@student.tudelft.nl>

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/>.  */

/* trans-array.c-- Various array related code, including scalarization,
                   allocation, initialization and other support routines.  */

/* How the scalarizer works.
   In gfortran, array expressions use the same core routines as scalar
   expressions.
   First, a Scalarization State (SS) chain is built.  This is done by walking
   the expression tree, and building a linear list of the terms in the
   expression.  As the tree is walked, scalar subexpressions are translated.

   The scalarization parameters are stored in a gfc_loopinfo structure.
   First the start and stride of each term is calculated by
   gfc_conv_ss_startstride.  During this process the expressions for the array
   descriptors and data pointers are also translated.

   If the expression is an assignment, we must then resolve any dependencies.
   In fortran all the rhs values of an assignment must be evaluated before
   any assignments take place.  This can require a temporary array to store the
   values.  We also require a temporary when we are passing array expressions
   or vector subscripts as procedure parameters.

   Array sections are passed without copying to a temporary.  These use the
   scalarizer to determine the shape of the section.  The flag
   loop->array_parameter tells the scalarizer that the actual values and loop
   variables will not be required.

   The function gfc_conv_loop_setup generates the scalarization setup code.
   It determines the range of the scalarizing loop variables.  If a temporary
   is required, this is created and initialized.  Code for scalar expressions
   taken outside the loop is also generated at this time.  Next the offset and
   scaling required to translate from loop variables to array indices for each
   term is calculated.

   A call to gfc_start_scalarized_body marks the start of the scalarized
   expression.  This creates a scope and declares the loop variables.  Before
   calling this gfc_make_ss_chain_used must be used to indicate which terms
   will be used inside this loop.

   The scalar gfc_conv_* functions are then used to build the main body of the
   scalarization loop.  Scalarization loop variables and precalculated scalar
   values are automatically substituted.  Note that gfc_advance_se_ss_chain
   must be used, rather than changing the se->ss directly.

   For assignment expressions requiring a temporary two sub loops are
   generated.  The first stores the result of the expression in the temporary,
   the second copies it to the result.  A call to
   gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
   the start of the copying loop.  The temporary may be less than full rank.

   Finally gfc_trans_scalarizing_loops is called to generate the implicit do
   loops.  The loops are added to the pre chain of the loopinfo.  The post
   chain may still contain cleanup code.

   After the loop code has been added into its parent scope gfc_cleanup_loop
   is called to free all the SS allocated by the scalarizer.  */

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "gimple.h"
#include "ggc.h"
#include "toplev.h"
#include "real.h"
#include "flags.h"
#include "gfortran.h"
#include "constructor.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-types.h"
#include "trans-array.h"
#include "trans-const.h"
#include "dependency.h"

static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);

/* The contents of this structure aren't actually used, just the address.  */
static gfc_ss gfc_ss_terminator_var;
gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;


static tree
gfc_array_dataptr_type (tree desc)
{
  return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
}


/* Build expressions to access the members of an array descriptor.
   It's surprisingly easy to mess up here, so never access
   an array descriptor by "brute force", always use these
   functions.  This also avoids problems if we change the format
   of an array descriptor.

   To understand these magic numbers, look at the comments
   before gfc_build_array_type() in trans-types.c.

   The code within these defines should be the only code which knows the format
   of an array descriptor.

   Any code just needing to read obtain the bounds of an array should use
   gfc_conv_array_* rather than the following functions as these will return
   know constant values, and work with arrays which do not have descriptors.

   Don't forget to #undef these!  */

#define DATA_FIELD 0
#define OFFSET_FIELD 1
#define DTYPE_FIELD 2
#define DIMENSION_FIELD 3

#define STRIDE_SUBFIELD 0
#define LBOUND_SUBFIELD 1
#define UBOUND_SUBFIELD 2

/* This provides READ-ONLY access to the data field.  The field itself
   doesn't have the proper type.  */

tree
gfc_conv_descriptor_data_get (tree desc)
{
  tree field, type, t;

  type = TREE_TYPE (desc);
  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));

  field = TYPE_FIELDS (type);
  gcc_assert (DATA_FIELD == 0);

  t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
  t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);

  return t;
}

/* This provides WRITE access to the data field.

   TUPLES_P is true if we are generating tuples.
   
   This function gets called through the following macros:
     gfc_conv_descriptor_data_set
     gfc_conv_descriptor_data_set.  */

void
gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
{
  tree field, type, t;

  type = TREE_TYPE (desc);
  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));

  field = TYPE_FIELDS (type);
  gcc_assert (DATA_FIELD == 0);

  t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
  gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
}


/* This provides address access to the data field.  This should only be
   used by array allocation, passing this on to the runtime.  */

tree
gfc_conv_descriptor_data_addr (tree desc)
{
  tree field, type, t;

  type = TREE_TYPE (desc);
  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));

  field = TYPE_FIELDS (type);
  gcc_assert (DATA_FIELD == 0);

  t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
  return gfc_build_addr_expr (NULL_TREE, t);
}

static tree
gfc_conv_descriptor_offset (tree desc)
{
  tree type;
  tree field;

  type = TREE_TYPE (desc);
  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));

  field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);

  return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
                      desc, field, NULL_TREE);
}

tree
gfc_conv_descriptor_offset_get (tree desc)
{
  return gfc_conv_descriptor_offset (desc);
}

void
gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
                                tree value)
{
  tree t = gfc_conv_descriptor_offset (desc);
  gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
}


tree
gfc_conv_descriptor_dtype (tree desc)
{
  tree field;
  tree type;

  type = TREE_TYPE (desc);
  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));

  field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);

  return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
                      desc, field, NULL_TREE);
}

static tree
gfc_conv_descriptor_dimension (tree desc, tree dim)
{
  tree field;
  tree type;
  tree tmp;

  type = TREE_TYPE (desc);
  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));

  field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
  gcc_assert (field != NULL_TREE
          && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
          && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);

  tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
                     desc, field, NULL_TREE);
  tmp = gfc_build_array_ref (tmp, dim, NULL);
  return tmp;
}

static tree
gfc_conv_descriptor_stride (tree desc, tree dim)
{
  tree tmp;
  tree field;

  tmp = gfc_conv_descriptor_dimension (desc, dim);
  field = TYPE_FIELDS (TREE_TYPE (tmp));
  field = gfc_advance_chain (field, STRIDE_SUBFIELD);
  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);

  tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
                     tmp, field, NULL_TREE);
  return tmp;
}

tree
gfc_conv_descriptor_stride_get (tree desc, tree dim)
{
  tree type = TREE_TYPE (desc);
  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
  if (integer_zerop (dim)
      && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
    return gfc_index_one_node;

  return gfc_conv_descriptor_stride (desc, dim);
}

void
gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
                                tree dim, tree value)
{
  tree t = gfc_conv_descriptor_stride (desc, dim);
  gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
}

static tree
gfc_conv_descriptor_lbound (tree desc, tree dim)
{
  tree tmp;
  tree field;

  tmp = gfc_conv_descriptor_dimension (desc, dim);
  field = TYPE_FIELDS (TREE_TYPE (tmp));
  field = gfc_advance_chain (field, LBOUND_SUBFIELD);
  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);

  tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
                     tmp, field, NULL_TREE);
  return tmp;
}

tree
gfc_conv_descriptor_lbound_get (tree desc, tree dim)
{
  return gfc_conv_descriptor_lbound (desc, dim);
}

void
gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
                                tree dim, tree value)
{
  tree t = gfc_conv_descriptor_lbound (desc, dim);
  gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
}

static tree
gfc_conv_descriptor_ubound (tree desc, tree dim)
{
  tree tmp;
  tree field;

  tmp = gfc_conv_descriptor_dimension (desc, dim);
  field = TYPE_FIELDS (TREE_TYPE (tmp));
  field = gfc_advance_chain (field, UBOUND_SUBFIELD);
  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);

  tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
                     tmp, field, NULL_TREE);
  return tmp;
}

tree
gfc_conv_descriptor_ubound_get (tree desc, tree dim)
{
  return gfc_conv_descriptor_ubound (desc, dim);
}

void
gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
                                tree dim, tree value)
{
  tree t = gfc_conv_descriptor_ubound (desc, dim);
  gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
}

/* Build a null array descriptor constructor.  */

tree
gfc_build_null_descriptor (tree type)
{
  tree field;
  tree tmp;

  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
  gcc_assert (DATA_FIELD == 0);
  field = TYPE_FIELDS (type);

  /* Set a NULL data pointer.  */
  tmp = build_constructor_single (type, field, null_pointer_node);
  TREE_CONSTANT (tmp) = 1;
  /* All other fields are ignored.  */

  return tmp;
}


/* Cleanup those #defines.  */

#undef DATA_FIELD
#undef OFFSET_FIELD
#undef DTYPE_FIELD
#undef DIMENSION_FIELD
#undef STRIDE_SUBFIELD
#undef LBOUND_SUBFIELD
#undef UBOUND_SUBFIELD


/* Mark a SS chain as used.  Flags specifies in which loops the SS is used.
   flags & 1 = Main loop body.
   flags & 2 = temp copy loop.  */

void
gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
{
  for (; ss != gfc_ss_terminator; ss = ss->next)
    ss->useflags = flags;
}

static void gfc_free_ss (gfc_ss *);


/* Free a gfc_ss chain.  */

static void
gfc_free_ss_chain (gfc_ss * ss)
{
  gfc_ss *next;

  while (ss != gfc_ss_terminator)
    {
      gcc_assert (ss != NULL);
      next = ss->next;
      gfc_free_ss (ss);
      ss = next;
    }
}


/* Free a SS.  */

static void
gfc_free_ss (gfc_ss * ss)
{
  int n;

  switch (ss->type)
    {
    case GFC_SS_SECTION:
      for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
        {
          if (ss->data.info.subscript[n])
            gfc_free_ss_chain (ss->data.info.subscript[n]);
        }
      break;

    default:
      break;
    }

  gfc_free (ss);
}


/* Free all the SS associated with a loop.  */

void
gfc_cleanup_loop (gfc_loopinfo * loop)
{
  gfc_ss *ss;
  gfc_ss *next;

  ss = loop->ss;
  while (ss != gfc_ss_terminator)
    {
      gcc_assert (ss != NULL);
      next = ss->loop_chain;
      gfc_free_ss (ss);
      ss = next;
    }
}


/* Associate a SS chain with a loop.  */

void
gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
{
  gfc_ss *ss;

  if (head == gfc_ss_terminator)
    return;

  ss = head;
  for (; ss && ss != gfc_ss_terminator; ss = ss->next)
    {
      if (ss->next == gfc_ss_terminator)
        ss->loop_chain = loop->ss;
      else
        ss->loop_chain = ss->next;
    }
  gcc_assert (ss == gfc_ss_terminator);
  loop->ss = head;
}


/* Generate an initializer for a static pointer or allocatable array.  */

void
gfc_trans_static_array_pointer (gfc_symbol * sym)
{
  tree type;

  gcc_assert (TREE_STATIC (sym->backend_decl));
  /* Just zero the data member.  */
  type = TREE_TYPE (sym->backend_decl);
  DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
}


/* If the bounds of SE's loop have not yet been set, see if they can be
   determined from array spec AS, which is the array spec of a called
   function.  MAPPING maps the callee's dummy arguments to the values
   that the caller is passing.  Add any initialization and finalization
   code to SE.  */

void
gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
                                     gfc_se * se, gfc_array_spec * as)
{
  int n, dim;
  gfc_se tmpse;
  tree lower;
  tree upper;
  tree tmp;

  if (as && as->type == AS_EXPLICIT)
    for (dim = 0; dim < se->loop->dimen; dim++)
      {
        n = se->loop->order[dim];
        if (se->loop->to[n] == NULL_TREE)
          {
            /* Evaluate the lower bound.  */
            gfc_init_se (&tmpse, NULL);
            gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
            gfc_add_block_to_block (&se->pre, &tmpse.pre);
            gfc_add_block_to_block (&se->post, &tmpse.post);
            lower = fold_convert (gfc_array_index_type, tmpse.expr);

            /* ...and the upper bound.  */
            gfc_init_se (&tmpse, NULL);
            gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
            gfc_add_block_to_block (&se->pre, &tmpse.pre);
            gfc_add_block_to_block (&se->post, &tmpse.post);
            upper = fold_convert (gfc_array_index_type, tmpse.expr);

            /* Set the upper bound of the loop to UPPER - LOWER.  */
            tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
            tmp = gfc_evaluate_now (tmp, &se->pre);
            se->loop->to[n] = tmp;
          }
      }
}


/* Generate code to allocate an array temporary, or create a variable to
   hold the data.  If size is NULL, zero the descriptor so that the
   callee will allocate the array.  If DEALLOC is true, also generate code to
   free the array afterwards.

   If INITIAL is not NULL, it is packed using internal_pack and the result used
   as data instead of allocating a fresh, unitialized area of memory.

   Initialization code is added to PRE and finalization code to POST.
   DYNAMIC is true if the caller may want to extend the array later
   using realloc.  This prevents us from putting the array on the stack.  */

static void
gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
                                  gfc_ss_info * info, tree size, tree nelem,
                                  tree initial, bool dynamic, bool dealloc)
{
  tree tmp;
  tree desc;
  bool onstack;

  desc = info->descriptor;
  info->offset = gfc_index_zero_node;
  if (size == NULL_TREE || integer_zerop (size))
    {
      /* A callee allocated array.  */
      gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
      onstack = FALSE;
    }
  else
    {
      /* Allocate the temporary.  */
      onstack = !dynamic && initial == NULL_TREE
                         && gfc_can_put_var_on_stack (size);

      if (onstack)
        {
          /* Make a temporary variable to hold the data.  */
          tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
                             gfc_index_one_node);
          tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
                                  tmp);
          tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
                                  tmp);
          tmp = gfc_create_var (tmp, "A");
          tmp = gfc_build_addr_expr (NULL_TREE, tmp);
          gfc_conv_descriptor_data_set (pre, desc, tmp);
        }
      else
        {
          /* Allocate memory to hold the data or call internal_pack.  */
          if (initial == NULL_TREE)
            {
              tmp = gfc_call_malloc (pre, NULL, size);
              tmp = gfc_evaluate_now (tmp, pre);
            }
          else
            {
              tree packed;
              tree source_data;
              tree was_packed;
              stmtblock_t do_copying;

              tmp = TREE_TYPE (initial); /* Pointer to descriptor.  */
              gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
              tmp = TREE_TYPE (tmp); /* The descriptor itself.  */
              tmp = gfc_get_element_type (tmp);
              gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
              packed = gfc_create_var (build_pointer_type (tmp), "data");

              tmp = build_call_expr_loc (input_location,
                                     gfor_fndecl_in_pack, 1, initial);
              tmp = fold_convert (TREE_TYPE (packed), tmp);
              gfc_add_modify (pre, packed, tmp);

              tmp = build_fold_indirect_ref_loc (input_location,
                                             initial);
              source_data = gfc_conv_descriptor_data_get (tmp);

              /* internal_pack may return source->data without any allocation
                 or copying if it is already packed.  If that's the case, we
                 need to allocate and copy manually.  */

              gfc_start_block (&do_copying);
              tmp = gfc_call_malloc (&do_copying, NULL, size);
              tmp = fold_convert (TREE_TYPE (packed), tmp);
              gfc_add_modify (&do_copying, packed, tmp);
              tmp = gfc_build_memcpy_call (packed, source_data, size);
              gfc_add_expr_to_block (&do_copying, tmp);

              was_packed = fold_build2 (EQ_EXPR, boolean_type_node,
                                        packed, source_data);
              tmp = gfc_finish_block (&do_copying);
              tmp = build3_v (COND_EXPR, was_packed, tmp,
                              build_empty_stmt (input_location));
              gfc_add_expr_to_block (pre, tmp);

              tmp = fold_convert (pvoid_type_node, packed);
            }

          gfc_conv_descriptor_data_set (pre, desc, tmp);
        }
    }
  info->data = gfc_conv_descriptor_data_get (desc);

  /* The offset is zero because we create temporaries with a zero
     lower bound.  */
  gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);

  if (dealloc && !onstack)
    {
      /* Free the temporary.  */
      tmp = gfc_conv_descriptor_data_get (desc);
      tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
      gfc_add_expr_to_block (post, tmp);
    }
}


/* Generate code to create and initialize the descriptor for a temporary
   array.  This is used for both temporaries needed by the scalarizer, and
   functions returning arrays.  Adjusts the loop variables to be
   zero-based, and calculates the loop bounds for callee allocated arrays.
   Allocate the array unless it's callee allocated (we have a callee
   allocated array if 'callee_alloc' is true, or if loop->to[n] is
   NULL_TREE for any n).  Also fills in the descriptor, data and offset
   fields of info if known.  Returns the size of the array, or NULL for a
   callee allocated array.

   PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
   gfc_trans_allocate_array_storage.
 */

tree
gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
                             gfc_loopinfo * loop, gfc_ss_info * info,
                             tree eltype, tree initial, bool dynamic,
                             bool dealloc, bool callee_alloc, locus * where)
{
  tree type;
  tree desc;
  tree tmp;
  tree size;
  tree nelem;
  tree cond;
  tree or_expr;
  int n;
  int dim;

  gcc_assert (info->dimen > 0);

  if (gfc_option.warn_array_temp && where)
    gfc_warning ("Creating array temporary at %L", where);

  /* Set the lower bound to zero.  */
  for (dim = 0; dim < info->dimen; dim++)
    {
      n = loop->order[dim];
      /* Callee allocated arrays may not have a known bound yet.  */
      if (loop->to[n])
        loop->to[n] = gfc_evaluate_now (fold_build2 (MINUS_EXPR,
                                        gfc_array_index_type,
                                        loop->to[n], loop->from[n]), pre);
      loop->from[n] = gfc_index_zero_node;

      info->delta[dim] = gfc_index_zero_node;
      info->start[dim] = gfc_index_zero_node;
      info->end[dim] = gfc_index_zero_node;
      info->stride[dim] = gfc_index_one_node;
      info->dim[dim] = dim;
    }

  /* Initialize the descriptor.  */
  type =
    gfc_get_array_type_bounds (eltype, info->dimen, 0, loop->from, loop->to, 1,
                               GFC_ARRAY_UNKNOWN, true);
  desc = gfc_create_var (type, "atmp");
  GFC_DECL_PACKED_ARRAY (desc) = 1;

  info->descriptor = desc;
  size = gfc_index_one_node;

  /* Fill in the array dtype.  */
  tmp = gfc_conv_descriptor_dtype (desc);
  gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));

  /*
     Fill in the bounds and stride.  This is a packed array, so:

     size = 1;
     for (n = 0; n < rank; n++)
       {
         stride[n] = size
         delta = ubound[n] + 1 - lbound[n];
         size = size * delta;
       }
     size = size * sizeof(element);
  */

  or_expr = NULL_TREE;

  /* If there is at least one null loop->to[n], it is a callee allocated 
     array.  */
  for (n = 0; n < info->dimen; n++)
    if (loop->to[n] == NULL_TREE)
      {
        size = NULL_TREE;
        break;
      }

  for (n = 0; n < info->dimen; n++)
     {
      if (size == NULL_TREE)
        {
          /* For a callee allocated array express the loop bounds in terms
             of the descriptor fields.  */
          tmp =
            fold_build2 (MINUS_EXPR, gfc_array_index_type,
                         gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
                         gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
          loop->to[n] = tmp;
          continue;
        }
        
      /* Store the stride and bound components in the descriptor.  */
      gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);

      gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
                                      gfc_index_zero_node);

      gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]);

      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
                         loop->to[n], gfc_index_one_node);

      /* Check whether the size for this dimension is negative.  */
      cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
                          gfc_index_zero_node);
      cond = gfc_evaluate_now (cond, pre);

      if (n == 0)
        or_expr = cond;
      else
        or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);

      size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
      size = gfc_evaluate_now (size, pre);
    }

  /* Get the size of the array.  */

  if (size && !callee_alloc)
    {
      /* If or_expr is true, then the extent in at least one
         dimension is zero and the size is set to zero.  */
      size = fold_build3 (COND_EXPR, gfc_array_index_type,
                          or_expr, gfc_index_zero_node, size);

      nelem = size;
      size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
                fold_convert (gfc_array_index_type,
                              TYPE_SIZE_UNIT (gfc_get_element_type (type))));
    }
  else
    {
      nelem = size;
      size = NULL_TREE;
    }

  gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
                                    dynamic, dealloc);

  if (info->dimen > loop->temp_dim)
    loop->temp_dim = info->dimen;

  return size;
}


/* Generate code to transpose array EXPR by creating a new descriptor
   in which the dimension specifications have been reversed.  */

void
gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
{
  tree dest, src, dest_index, src_index;
  gfc_loopinfo *loop;
  gfc_ss_info *dest_info;
  gfc_ss *dest_ss, *src_ss;
  gfc_se src_se;
  int n;

  loop = se->loop;

  src_ss = gfc_walk_expr (expr);
  dest_ss = se->ss;

  dest_info = &dest_ss->data.info;
  gcc_assert (dest_info->dimen == 2);

  /* Get a descriptor for EXPR.  */
  gfc_init_se (&src_se, NULL);
  gfc_conv_expr_descriptor (&src_se, expr, src_ss);
  gfc_add_block_to_block (&se->pre, &src_se.pre);
  gfc_add_block_to_block (&se->post, &src_se.post);
  src = src_se.expr;

  /* Allocate a new descriptor for the return value.  */
  dest = gfc_create_var (TREE_TYPE (src), "atmp");
  dest_info->descriptor = dest;
  se->expr = dest;

  /* Copy across the dtype field.  */
  gfc_add_modify (&se->pre,
                       gfc_conv_descriptor_dtype (dest),
                       gfc_conv_descriptor_dtype (src));

  /* Copy the dimension information, renumbering dimension 1 to 0 and
     0 to 1.  */
  for (n = 0; n < 2; n++)
    {
      dest_info->delta[n] = gfc_index_zero_node;
      dest_info->start[n] = gfc_index_zero_node;
      dest_info->end[n] = gfc_index_zero_node;
      dest_info->stride[n] = gfc_index_one_node;
      dest_info->dim[n] = n;

      dest_index = gfc_rank_cst[n];
      src_index = gfc_rank_cst[1 - n];

      gfc_conv_descriptor_stride_set (&se->pre, dest, dest_index,
                           gfc_conv_descriptor_stride_get (src, src_index));

      gfc_conv_descriptor_lbound_set (&se->pre, dest, dest_index,
                           gfc_conv_descriptor_lbound_get (src, src_index));

      gfc_conv_descriptor_ubound_set (&se->pre, dest, dest_index,
                           gfc_conv_descriptor_ubound_get (src, src_index));

      if (!loop->to[n])
        {
          gcc_assert (integer_zerop (loop->from[n]));
          loop->to[n] =
            fold_build2 (MINUS_EXPR, gfc_array_index_type,
                         gfc_conv_descriptor_ubound_get (dest, dest_index),
                         gfc_conv_descriptor_lbound_get (dest, dest_index));
        }
    }

  /* Copy the data pointer.  */
  dest_info->data = gfc_conv_descriptor_data_get (src);
  gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);

  /* Copy the offset.  This is not changed by transposition; the top-left
     element is still at the same offset as before, except where the loop
     starts at zero.  */
  if (!integer_zerop (loop->from[0]))
    dest_info->offset = gfc_conv_descriptor_offset_get (src);
  else
    dest_info->offset = gfc_index_zero_node;

  gfc_conv_descriptor_offset_set (&se->pre, dest,
                                  dest_info->offset);
          
  if (dest_info->dimen > loop->temp_dim)
    loop->temp_dim = dest_info->dimen;
}


/* Return the number of iterations in a loop that starts at START,
   ends at END, and has step STEP.  */

static tree
gfc_get_iteration_count (tree start, tree end, tree step)
{
  tree tmp;
  tree type;

  type = TREE_TYPE (step);
  tmp = fold_build2 (MINUS_EXPR, type, end, start);
  tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
  tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
  tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
  return fold_convert (gfc_array_index_type, tmp);
}


/* Extend the data in array DESC by EXTRA elements.  */

static void
gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
{
  tree arg0, arg1;
  tree tmp;
  tree size;
  tree ubound;

  if (integer_zerop (extra))
    return;

  ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);

  /* Add EXTRA to the upper bound.  */
  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
  gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);

  /* Get the value of the current data pointer.  */
  arg0 = gfc_conv_descriptor_data_get (desc);

  /* Calculate the new array size.  */
  size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
                     ubound, gfc_index_one_node);
  arg1 = fold_build2 (MULT_EXPR, size_type_node,
                       fold_convert (size_type_node, tmp),
                       fold_convert (size_type_node, size));

  /* Call the realloc() function.  */
  tmp = gfc_call_realloc (pblock, arg0, arg1);
  gfc_conv_descriptor_data_set (pblock, desc, tmp);
}


/* Return true if the bounds of iterator I can only be determined
   at run time.  */

static inline bool
gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
{
  return (i->start->expr_type != EXPR_CONSTANT
          || i->end->expr_type != EXPR_CONSTANT
          || i->step->expr_type != EXPR_CONSTANT);
}


/* Split the size of constructor element EXPR into the sum of two terms,
   one of which can be determined at compile time and one of which must
   be calculated at run time.  Set *SIZE to the former and return true
   if the latter might be nonzero.  */

static bool
gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
{
  if (expr->expr_type == EXPR_ARRAY)
    return gfc_get_array_constructor_size (size, expr->value.constructor);
  else if (expr->rank > 0)
    {
      /* Calculate everything at run time.  */
      mpz_set_ui (*size, 0);
      return true;
    }
  else
    {
      /* A single element.  */
      mpz_set_ui (*size, 1);
      return false;
    }
}


/* Like gfc_get_array_constructor_element_size, but applied to the whole
   of array constructor C.  */

static bool
gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
{
  gfc_constructor *c;
  gfc_iterator *i;
  mpz_t val;
  mpz_t len;
  bool dynamic;

  mpz_set_ui (*size, 0);
  mpz_init (len);
  mpz_init (val);

  dynamic = false;
  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
    {
      i = c->iterator;
      if (i && gfc_iterator_has_dynamic_bounds (i))
        dynamic = true;
      else
        {
          dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
          if (i)
            {
              /* Multiply the static part of the element size by the
                 number of iterations.  */
              mpz_sub (val, i->end->value.integer, i->start->value.integer);
              mpz_fdiv_q (val, val, i->step->value.integer);
              mpz_add_ui (val, val, 1);
              if (mpz_sgn (val) > 0)
                mpz_mul (len, len, val);
              else
                mpz_set_ui (len, 0);
            }
          mpz_add (*size, *size, len);
        }
    }
  mpz_clear (len);
  mpz_clear (val);
  return dynamic;
}


/* Make sure offset is a variable.  */

static void
gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
                         tree * offsetvar)
{
  /* We should have already created the offset variable.  We cannot
     create it here because we may be in an inner scope.  */
  gcc_assert (*offsetvar != NULL_TREE);
  gfc_add_modify (pblock, *offsetvar, *poffset);
  *poffset = *offsetvar;
  TREE_USED (*offsetvar) = 1;
}


/* Variables needed for bounds-checking.  */
static bool first_len;
static tree first_len_val; 
static bool typespec_chararray_ctor;

static void
gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
                              tree offset, gfc_se * se, gfc_expr * expr)
{
  tree tmp;

  gfc_conv_expr (se, expr);

  /* Store the value.  */
  tmp = build_fold_indirect_ref_loc (input_location,
                                 gfc_conv_descriptor_data_get (desc));
  tmp = gfc_build_array_ref (tmp, offset, NULL);

  if (expr->ts.type == BT_CHARACTER)
    {
      int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
      tree esize;

      esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
      esize = fold_convert (gfc_charlen_type_node, esize);
      esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize,
                           build_int_cst (gfc_charlen_type_node,
                                          gfc_character_kinds[i].bit_size / 8));

      gfc_conv_string_parameter (se);
      if (POINTER_TYPE_P (TREE_TYPE (tmp)))
        {
          /* The temporary is an array of pointers.  */
          se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
          gfc_add_modify (&se->pre, tmp, se->expr);
        }
      else
        {
          /* The temporary is an array of string values.  */
          tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
          /* We know the temporary and the value will be the same length,
             so can use memcpy.  */
          gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
                                 se->string_length, se->expr, expr->ts.kind);
        }
      if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
        {
          if (first_len)
            {
              gfc_add_modify (&se->pre, first_len_val,
                                   se->string_length);
              first_len = false;
            }
          else
            {
              /* Verify that all constructor elements are of the same
                 length.  */
              tree cond = fold_build2 (NE_EXPR, boolean_type_node,
                                       first_len_val, se->string_length);
              gfc_trans_runtime_check
                (true, false, cond, &se->pre, &expr->where,
                 "Different CHARACTER lengths (%ld/%ld) in array constructor",
                 fold_convert (long_integer_type_node, first_len_val),
                 fold_convert (long_integer_type_node, se->string_length));
            }
        }
    }
  else
    {
      /* TODO: Should the frontend already have done this conversion?  */
      se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
      gfc_add_modify (&se->pre, tmp, se->expr);
    }

  gfc_add_block_to_block (pblock, &se->pre);
  gfc_add_block_to_block (pblock, &se->post);
}


/* Add the contents of an array to the constructor.  DYNAMIC is as for
   gfc_trans_array_constructor_value.  */

static void
gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
                                      tree type ATTRIBUTE_UNUSED,
                                      tree desc, gfc_expr * expr,
                                      tree * poffset, tree * offsetvar,
                                      bool dynamic)
{
  gfc_se se;
  gfc_ss *ss;
  gfc_loopinfo loop;
  stmtblock_t body;
  tree tmp;
  tree size;
  int n;

  /* We need this to be a variable so we can increment it.  */
  gfc_put_offset_into_var (pblock, poffset, offsetvar);

  gfc_init_se (&se, NULL);

  /* Walk the array expression.  */
  ss = gfc_walk_expr (expr);
  gcc_assert (ss != gfc_ss_terminator);

  /* Initialize the scalarizer.  */
  gfc_init_loopinfo (&loop);
  gfc_add_ss_to_loop (&loop, ss);

  /* Initialize the loop.  */
  gfc_conv_ss_startstride (&loop);
  gfc_conv_loop_setup (&loop, &expr->where);

  /* Make sure the constructed array has room for the new data.  */
  if (dynamic)
    {
      /* Set SIZE to the total number of elements in the subarray.  */
      size = gfc_index_one_node;
      for (n = 0; n < loop.dimen; n++)
        {
          tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
                                         gfc_index_one_node);
          size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
        }

      /* Grow the constructed array by SIZE elements.  */
      gfc_grow_array (&loop.pre, desc, size);
    }

  /* Make the loop body.  */
  gfc_mark_ss_chain_used (ss, 1);
  gfc_start_scalarized_body (&loop, &body);
  gfc_copy_loopinfo_to_se (&se, &loop);
  se.ss = ss;

  gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
  gcc_assert (se.ss == gfc_ss_terminator);

  /* Increment the offset.  */
  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
                     *poffset, gfc_index_one_node);
  gfc_add_modify (&body, *poffset, tmp);

  /* Finish the loop.  */
  gfc_trans_scalarizing_loops (&loop, &body);
  gfc_add_block_to_block (&loop.pre, &loop.post);
  tmp = gfc_finish_block (&loop.pre);
  gfc_add_expr_to_block (pblock, tmp);

  gfc_cleanup_loop (&loop);
}


/* Assign the values to the elements of an array constructor.  DYNAMIC
   is true if descriptor DESC only contains enough data for the static
   size calculated by gfc_get_array_constructor_size.  When true, memory
   for the dynamic parts must be allocated using realloc.  */

static void
gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
                                   tree desc, gfc_constructor_base base,
                                   tree * poffset, tree * offsetvar,
                                   bool dynamic)
{
  tree tmp;
  stmtblock_t body;
  gfc_se se;
  mpz_t size;
  gfc_constructor *c;

  tree shadow_loopvar = NULL_TREE;
  gfc_saved_var saved_loopvar;

  mpz_init (size);
  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
    {
      /* If this is an iterator or an array, the offset must be a variable.  */
      if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
        gfc_put_offset_into_var (pblock, poffset, offsetvar);

      /* Shadowing the iterator avoids changing its value and saves us from
         keeping track of it. Further, it makes sure that there's always a
         backend-decl for the symbol, even if there wasn't one before,
         e.g. in the case of an iterator that appears in a specification
         expression in an interface mapping.  */
      if (c->iterator)
        {
          gfc_symbol *sym = c->iterator->var->symtree->n.sym;
          tree type = gfc_typenode_for_spec (&sym->ts);

          shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
          gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
        }

      gfc_start_block (&body);

      if (c->expr->expr_type == EXPR_ARRAY)
        {
          /* Array constructors can be nested.  */
          gfc_trans_array_constructor_value (&body, type, desc,
                                             c->expr->value.constructor,
                                             poffset, offsetvar, dynamic);
        }
      else if (c->expr->rank > 0)
        {
          gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
                                                poffset, offsetvar, dynamic);
        }
      else
        {
          /* This code really upsets the gimplifier so don't bother for now.  */
          gfc_constructor *p;
          HOST_WIDE_INT n;
          HOST_WIDE_INT size;

          p = c;
          n = 0;
          while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
            {
              p = gfc_constructor_next (p);
              n++;
            }
          if (n < 4)
            {
              /* Scalar values.  */
              gfc_init_se (&se, NULL);
              gfc_trans_array_ctor_element (&body, desc, *poffset,
                                            &se, c->expr);

              *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
                                      *poffset, gfc_index_one_node);
            }
          else
            {
              /* Collect multiple scalar constants into a constructor.  */
              tree list;
              tree init;
              tree bound;
              tree tmptype;
              HOST_WIDE_INT idx = 0;

              p = c;
              list = NULL_TREE;
              /* Count the number of consecutive scalar constants.  */
              while (p && !(p->iterator
                            || p->expr->expr_type != EXPR_CONSTANT))
                {
                  gfc_init_se (&se, NULL);
                  gfc_conv_constant (&se, p->expr);

                  if (c->expr->ts.type != BT_CHARACTER)
                    se.expr = fold_convert (type, se.expr);
                  /* For constant character array constructors we build
                     an array of pointers.  */
                  else if (POINTER_TYPE_P (type))
                    se.expr = gfc_build_addr_expr
                                (gfc_get_pchar_type (p->expr->ts.kind),
                                 se.expr);

                  list = tree_cons (build_int_cst (gfc_array_index_type,
                                                   idx++), se.expr, list);
                  c = p;
                  p = gfc_constructor_next (p);
                }

              bound = build_int_cst (NULL_TREE, n - 1);
              /* Create an array type to hold them.  */
              tmptype = build_range_type (gfc_array_index_type,
                                          gfc_index_zero_node, bound);
              tmptype = build_array_type (type, tmptype);

              init = build_constructor_from_list (tmptype, nreverse (list));
              TREE_CONSTANT (init) = 1;
              TREE_STATIC (init) = 1;
              /* Create a static variable to hold the data.  */
              tmp = gfc_create_var (tmptype, "data");
              TREE_STATIC (tmp) = 1;
              TREE_CONSTANT (tmp) = 1;
              TREE_READONLY (tmp) = 1;
              DECL_INITIAL (tmp) = init;
              init = tmp;

              /* Use BUILTIN_MEMCPY to assign the values.  */
              tmp = gfc_conv_descriptor_data_get (desc);
              tmp = build_fold_indirect_ref_loc (input_location,
                                             tmp);
              tmp = gfc_build_array_ref (tmp, *poffset, NULL);
              tmp = gfc_build_addr_expr (NULL_TREE, tmp);
              init = gfc_build_addr_expr (NULL_TREE, init);

              size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
              bound = build_int_cst (NULL_TREE, n * size);
              tmp = build_call_expr_loc (input_location,
                                     built_in_decls[BUILT_IN_MEMCPY], 3,
                                     tmp, init, bound);
              gfc_add_expr_to_block (&body, tmp);

              *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
                                      *poffset,
                                      build_int_cst (gfc_array_index_type, n));
            }
          if (!INTEGER_CST_P (*poffset))
            {
              gfc_add_modify (&body, *offsetvar, *poffset);
              *poffset = *offsetvar;
            }
        }

      /* The frontend should already have done any expansions
         at compile-time.  */
      if (!c->iterator)
        {
          /* Pass the code as is.  */
          tmp = gfc_finish_block (&body);
          gfc_add_expr_to_block (pblock, tmp);
        }
      else
        {
          /* Build the implied do-loop.  */
          stmtblock_t implied_do_block;
          tree cond;
          tree end;
          tree step;
          tree exit_label;
          tree loopbody;
          tree tmp2;

          loopbody = gfc_finish_block (&body);

          /* Create a new block that holds the implied-do loop. A temporary
             loop-variable is used.  */
          gfc_start_block(&implied_do_block);

          /* Initialize the loop.  */
          gfc_init_se (&se, NULL);
          gfc_conv_expr_val (&se, c->iterator->start);
          gfc_add_block_to_block (&implied_do_block, &se.pre);
          gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);

          gfc_init_se (&se, NULL);
          gfc_conv_expr_val (&se, c->iterator->end);
          gfc_add_block_to_block (&implied_do_block, &se.pre);
          end = gfc_evaluate_now (se.expr, &implied_do_block);

          gfc_init_se (&se, NULL);
          gfc_conv_expr_val (&se, c->iterator->step);
          gfc_add_block_to_block (&implied_do_block, &se.pre);
          step = gfc_evaluate_now (se.expr, &implied_do_block);

          /* If this array expands dynamically, and the number of iterations
             is not constant, we won't have allocated space for the static
             part of C->EXPR's size.  Do that now.  */
          if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
            {
              /* Get the number of iterations.  */
              tmp = gfc_get_iteration_count (shadow_loopvar, end, step);

              /* Get the static part of C->EXPR's size.  */
              gfc_get_array_constructor_element_size (&size, c->expr);
              tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);

              /* Grow the array by TMP * TMP2 elements.  */
              tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
              gfc_grow_array (&implied_do_block, desc, tmp);
            }

          /* Generate the loop body.  */
          exit_label = gfc_build_label_decl (NULL_TREE);
          gfc_start_block (&body);

          /* Generate the exit condition.  Depending on the sign of
             the step variable we have to generate the correct
             comparison.  */
          tmp = fold_build2 (GT_EXPR, boolean_type_node, step, 
                             build_int_cst (TREE_TYPE (step), 0));
          cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
                              fold_build2 (GT_EXPR, boolean_type_node,
                                           shadow_loopvar, end),
                              fold_build2 (LT_EXPR, boolean_type_node,
                                           shadow_loopvar, end));
          tmp = build1_v (GOTO_EXPR, exit_label);
          TREE_USED (exit_label) = 1;
          tmp = build3_v (COND_EXPR, cond, tmp,
                          build_empty_stmt (input_location));
          gfc_add_expr_to_block (&body, tmp);

          /* The main loop body.  */
          gfc_add_expr_to_block (&body, loopbody);

          /* Increase loop variable by step.  */
          tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (shadow_loopvar), shadow_loopvar, step);
          gfc_add_modify (&body, shadow_loopvar, tmp);

          /* Finish the loop.  */
          tmp = gfc_finish_block (&body);
          tmp = build1_v (LOOP_EXPR, tmp);
          gfc_add_expr_to_block (&implied_do_block, tmp);

          /* Add the exit label.  */
          tmp = build1_v (LABEL_EXPR, exit_label);
          gfc_add_expr_to_block (&implied_do_block, tmp);

          /* Finishe the implied-do loop.  */
          tmp = gfc_finish_block(&implied_do_block);
          gfc_add_expr_to_block(pblock, tmp);

          gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
        }
    }
  mpz_clear (size);
}


/* Figure out the string length of a variable reference expression.
   Used by get_array_ctor_strlen.  */

static void
get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
{
  gfc_ref *ref;
  gfc_typespec *ts;
  mpz_t char_len;

  /* Don't bother if we already know the length is a constant.  */
  if (*len && INTEGER_CST_P (*len))
    return;

  ts = &expr->symtree->n.sym->ts;
  for (ref = expr->ref; ref; ref = ref->next)
    {
      switch (ref->type)
        {
        case REF_ARRAY:
          /* Array references don't change the string length.  */
          break;

        case REF_COMPONENT:
          /* Use the length of the component.  */
          ts = &ref->u.c.component->ts;
          break;

        case REF_SUBSTRING:
          if (ref->u.ss.start->expr_type != EXPR_CONSTANT
              || ref->u.ss.end->expr_type != EXPR_CONSTANT)
            break;
          mpz_init_set_ui (char_len, 1);
          mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
          mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
          *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
          *len = convert (gfc_charlen_type_node, *len);
          mpz_clear (char_len);
          return;

        default:
          /* TODO: Substrings are tricky because we can't evaluate the
             expression more than once.  For now we just give up, and hope
             we can figure it out elsewhere.  */
          return;
        }
    }

  *len = ts->u.cl->backend_decl;
}


/* A catch-all to obtain the string length for anything that is not a
   constant, array or variable.  */
static void
get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
{
  gfc_se se;
  gfc_ss *ss;

  /* Don't bother if we already know the length is a constant.  */
  if (*len && INTEGER_CST_P (*len))
    return;

  if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
        && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
    {
      /* This is easy.  */
      gfc_conv_const_charlen (e->ts.u.cl);
      *len = e->ts.u.cl->backend_decl;
    }
  else
    {
      /* Otherwise, be brutal even if inefficient.  */
      ss = gfc_walk_expr (e);
      gfc_init_se (&se, NULL);

      /* No function call, in case of side effects.  */
      se.no_function_call = 1;
      if (ss == gfc_ss_terminator)
        gfc_conv_expr (&se, e);
      else
        gfc_conv_expr_descriptor (&se, e, ss);

      /* Fix the value.  */
      *len = gfc_evaluate_now (se.string_length, &se.pre);

      gfc_add_block_to_block (block, &se.pre);
      gfc_add_block_to_block (block, &se.post);

      e->ts.u.cl->backend_decl = *len;
    }
}


/* Figure out the string length of a character array constructor.
   If len is NULL, don't calculate the length; this happens for recursive calls
   when a sub-array-constructor is an element but not at the first position,
   so when we're not interested in the length.
   Returns TRUE if all elements are character constants.  */

bool
get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
{
  gfc_constructor *c;
  bool is_const;

  is_const = TRUE;

  if (gfc_constructor_first (base) == NULL)
    {
      if (len)
        *len = build_int_cstu (gfc_charlen_type_node, 0);
      return is_const;
    }

  /* Loop over all constructor elements to find out is_const, but in len we
     want to store the length of the first, not the last, element.  We can
     of course exit the loop as soon as is_const is found to be false.  */
  for (c = gfc_constructor_first (base);
       c && is_const; c = gfc_constructor_next (c))
    {
      switch (c->expr->expr_type)
        {
        case EXPR_CONSTANT:
          if (len && !(*len && INTEGER_CST_P (*len)))
            *len = build_int_cstu (gfc_charlen_type_node,
                                   c->expr->value.character.length);
          break;

        case EXPR_ARRAY:
          if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
            is_const = false;
          break;

        case EXPR_VARIABLE:
          is_const = false;
          if (len)
            get_array_ctor_var_strlen (c->expr, len);
          break;

        default:
          is_const = false;
          if (len)
            get_array_ctor_all_strlen (block, c->expr, len);
          break;
        }

      /* After the first iteration, we don't want the length modified.  */
      len = NULL;
    }

  return is_const;
}

/* Check whether the array constructor C consists entirely of constant
   elements, and if so returns the number of those elements, otherwise
   return zero.  Note, an empty or NULL array constructor returns zero.  */

unsigned HOST_WIDE_INT
gfc_constant_array_constructor_p (gfc_constructor_base base)
{
  unsigned HOST_WIDE_INT nelem = 0;

  gfc_constructor *c = gfc_constructor_first (base);
  while (c)
    {
      if (c->iterator
          || c->expr->rank > 0
          || c->expr->expr_type != EXPR_CONSTANT)
        return 0;
      c = gfc_constructor_next (c);
      nelem++;
    }
  return nelem;
}


/* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
   and the tree type of it's elements, TYPE, return a static constant
   variable that is compile-time initialized.  */

tree
gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
{
  tree tmptype, list, init, tmp;
  HOST_WIDE_INT nelem;
  gfc_constructor *c;
  gfc_array_spec as;
  gfc_se se;
  int i;

  /* First traverse the constructor list, converting the constants
     to tree to build an initializer.  */
  nelem = 0;
  list = NULL_TREE;
  c = gfc_constructor_first (expr->value.constructor);
  while (c)
    {
      gfc_init_se (&se, NULL);
      gfc_conv_constant (&se, c->expr);
      if (c->expr->ts.type != BT_CHARACTER)
        se.expr = fold_convert (type, se.expr);
      else if (POINTER_TYPE_P (type))
        se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
                                       se.expr);
      list = tree_cons (build_int_cst (gfc_array_index_type, nelem),
                        se.expr, list);
      c = gfc_constructor_next (c);
      nelem++;
    }

  /* Next determine the tree type for the array.  We use the gfortran
     front-end's gfc_get_nodesc_array_type in order to create a suitable
     GFC_ARRAY_TYPE_P that may be used by the scalarizer.  */

  memset (&as, 0, sizeof (gfc_array_spec));

  as.rank = expr->rank;
  as.type = AS_EXPLICIT;
  if (!expr->shape)
    {
      as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
      as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
                                      NULL, nelem - 1);
    }
  else
    for (i = 0; i < expr->rank; i++)
      {
        int tmp = (int) mpz_get_si (expr->shape[i]);
        as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
        as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
                                        NULL, tmp - 1);
      }

  tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);

  init = build_constructor_from_list (tmptype, nreverse (list));

  TREE_CONSTANT (init) = 1;
  TREE_STATIC (init) = 1;

  tmp = gfc_create_var (tmptype, "A");
  TREE_STATIC (tmp) = 1;
  TREE_CONSTANT (tmp) = 1;
  TREE_READONLY (tmp) = 1;
  DECL_INITIAL (tmp) = init;

  return tmp;
}


/* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
   This mostly initializes the scalarizer state info structure with the
   appropriate values to directly use the array created by the function
   gfc_build_constant_array_constructor.  */

static void
gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
                                      gfc_ss * ss, tree type)
{
  gfc_ss_info *info;
  tree tmp;
  int i;

  tmp = gfc_build_constant_array_constructor (ss->expr, type);

  info = &ss->data.info;

  info->descriptor = tmp;
  info->data = gfc_build_addr_expr (NULL_TREE, tmp);
  info->offset = gfc_index_zero_node;

  for (i = 0; i < info->dimen; i++)
    {
      info->delta[i] = gfc_index_zero_node;
      info->start[i] = gfc_index_zero_node;
      info->end[i] = gfc_index_zero_node;
      info->stride[i] = gfc_index_one_node;
      info->dim[i] = i;
    }

  if (info->dimen > loop->temp_dim)
    loop->temp_dim = info->dimen;
}

/* Helper routine of gfc_trans_array_constructor to determine if the
   bounds of the loop specified by LOOP are constant and simple enough
   to use with gfc_trans_constant_array_constructor.  Returns the
   iteration count of the loop if suitable, and NULL_TREE otherwise.  */

static tree
constant_array_constructor_loop_size (gfc_loopinfo * loop)
{
  tree size = gfc_index_one_node;
  tree tmp;
  int i;

  for (i = 0; i < loop->dimen; i++)
    {
      /* If the bounds aren't constant, return NULL_TREE.  */
      if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
        return NULL_TREE;
      if (!integer_zerop (loop->from[i]))
        {
          /* Only allow nonzero "from" in one-dimensional arrays.  */
          if (loop->dimen != 1)
            return NULL_TREE;
          tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
                             loop->to[i], loop->from[i]);
        }
      else
        tmp = loop->to[i];
      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
                         tmp, gfc_index_one_node);
      size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
    }

  return size;
}


/* Array constructors are handled by constructing a temporary, then using that
   within the scalarization loop.  This is not optimal, but seems by far the
   simplest method.  */

static void
gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
{
  gfc_constructor_base c;
  tree offset;
  tree offsetvar;
  tree desc;
  tree type;
  bool dynamic;
  bool old_first_len, old_typespec_chararray_ctor;
  tree old_first_len_val;

  /* Save the old values for nested checking.  */
  old_first_len = first_len;
  old_first_len_val = first_len_val;
  old_typespec_chararray_ctor = typespec_chararray_ctor;

  /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
     typespec was given for the array constructor.  */
  typespec_chararray_ctor = (ss->expr->ts.u.cl
                             && ss->expr->ts.u.cl->length_from_typespec);

  if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
      && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
    {  
      first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
      first_len = true;
    }

  ss->data.info.dimen = loop->dimen;

  c = ss->expr->value.constructor;
  if (ss->expr->ts.type == BT_CHARACTER)
    {
      bool const_string;
      
      /* get_array_ctor_strlen walks the elements of the constructor, if a
         typespec was given, we already know the string length and want the one
         specified there.  */
      if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
          && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
        {
          gfc_se length_se;

          const_string = false;
          gfc_init_se (&length_se, NULL);
          gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
                              gfc_charlen_type_node);
          ss->string_length = length_se.expr;
          gfc_add_block_to_block (&loop->pre, &length_se.pre);
          gfc_add_block_to_block (&loop->post, &length_se.post);
        }
      else
        const_string = get_array_ctor_strlen (&loop->pre, c,
                                              &ss->string_length);

      /* Complex character array constructors should have been taken care of
         and not end up here.  */
      gcc_assert (ss->string_length);

      ss->expr->ts.u.cl->backend_decl = ss->string_length;

      type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
      if (const_string)
        type = build_pointer_type (type);
    }
  else
    type = gfc_typenode_for_spec (&ss->expr->ts);

  /* See if the constructor determines the loop bounds.  */
  dynamic = false;

  if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
    {
      /* We have a multidimensional parameter.  */
      int n;
      for (n = 0; n < ss->expr->rank; n++)
      {
        loop->from[n] = gfc_index_zero_node;
        loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
                                            gfc_index_integer_kind);
        loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
                                   loop->to[n], gfc_index_one_node);
      }
    }

  if (loop->to[0] == NULL_TREE)
    {
      mpz_t size;

      /* We should have a 1-dimensional, zero-based loop.  */
      gcc_assert (loop->dimen == 1);
      gcc_assert (integer_zerop (loop->from[0]));

      /* Split the constructor size into a static part and a dynamic part.
         Allocate the static size up-front and record whether the dynamic
         size might be nonzero.  */
      mpz_init (size);
      dynamic = gfc_get_array_constructor_size (&size, c);
      mpz_sub_ui (size, size, 1);
      loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
      mpz_clear (size);
    }

  /* Special case constant array constructors.  */
  if (!dynamic)
    {
      unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
      if (nelem > 0)
        {
          tree size = constant_array_constructor_loop_size (loop);
          if (size && compare_tree_int (size, nelem) == 0)
            {
              gfc_trans_constant_array_constructor (loop, ss, type);
              goto finish;
            }
        }
    }

  gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
                               type, NULL_TREE, dynamic, true, false, where);

  desc = ss->data.info.descriptor;
  offset = gfc_index_zero_node;
  offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
  TREE_NO_WARNING (offsetvar) = 1;
  TREE_USED (offsetvar) = 0;
  gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
                                     &offset, &offsetvar, dynamic);

  /* If the array grows dynamically, the upper bound of the loop variable
     is determined by the array's final upper bound.  */
  if (dynamic)
    loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);

  if (TREE_USED (offsetvar))
    pushdecl (offsetvar);
  else
    gcc_assert (INTEGER_CST_P (offset));
#if 0
  /* Disable bound checking for now because it's probably broken.  */
  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    {
      gcc_unreachable ();
    }
#endif

finish:
  /* Restore old values of globals.  */
  first_len = old_first_len;
  first_len_val = old_first_len_val;
  typespec_chararray_ctor = old_typespec_chararray_ctor;
}


/* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
   called after evaluating all of INFO's vector dimensions.  Go through
   each such vector dimension and see if we can now fill in any missing
   loop bounds.  */

static void
gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
{
  gfc_se se;
  tree tmp;
  tree desc;
  tree zero;
  int n;
  int dim;

  for (n = 0; n < loop->dimen; n++)
    {
      dim = info->dim[n];
      if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
          && loop->to[n] == NULL)
        {
          /* Loop variable N indexes vector dimension DIM, and we don't
             yet know the upper bound of loop variable N.  Set it to the
             difference between the vector's upper and lower bounds.  */
          gcc_assert (loop->from[n] == gfc_index_zero_node);
          gcc_assert (info->subscript[dim]
                      && info->subscript[dim]->type == GFC_SS_VECTOR);

          gfc_init_se (&se, NULL);
          desc = info->subscript[dim]->data.info.descriptor;
          zero = gfc_rank_cst[0];
          tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
                             gfc_conv_descriptor_ubound_get (desc, zero),
                             gfc_conv_descriptor_lbound_get (desc, zero));
          tmp = gfc_evaluate_now (tmp, &loop->pre);
          loop->to[n] = tmp;
        }
    }
}


/* Add the pre and post chains for all the scalar expressions in a SS chain
   to loop.  This is called after the loop parameters have been calculated,
   but before the actual scalarizing loops.  */

static void
gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
                      locus * where)
{
  gfc_se se;
  int n;

  /* TODO: This can generate bad code if there are ordering dependencies,
     e.g., a callee allocated function and an unknown size constructor.  */
  gcc_assert (ss != NULL);

  for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
    {
      gcc_assert (ss);

      switch (ss->type)
        {
        case GFC_SS_SCALAR:
          /* Scalar expression.  Evaluate this now.  This includes elemental
             dimension indices, but not array section bounds.  */
          gfc_init_se (&se, NULL);
          gfc_conv_expr (&se, ss->expr);
          gfc_add_block_to_block (&loop->pre, &se.pre);

          if (ss->expr->ts.type != BT_CHARACTER)
            {
              /* Move the evaluation of scalar expressions outside the
                 scalarization loop, except for WHERE assignments.  */
              if (subscript)
                se.expr = convert(gfc_array_index_type, se.expr);
              if (!ss->where)
                se.expr = gfc_evaluate_now (se.expr, &loop->pre);
              gfc_add_block_to_block (&loop->pre, &se.post);
            }
          else
            gfc_add_block_to_block (&loop->post, &se.post);

          ss->data.scalar.expr = se.expr;
          ss->string_length = se.string_length;
          break;

        case GFC_SS_REFERENCE:
          /* Scalar argument to elemental procedure.  Evaluate this
             now.  */
          gfc_init_se (&se, NULL);
          gfc_conv_expr (&se, ss->expr);
          gfc_add_block_to_block (&loop->pre, &se.pre);
          gfc_add_block_to_block (&loop->post, &se.post);

          ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
          ss->string_length = se.string_length;
          break;

        case GFC_SS_SECTION:
          /* Add the expressions for scalar and vector subscripts.  */
          for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
            if (ss->data.info.subscript[n])
              gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
                                    where);

          gfc_set_vector_loop_bounds (loop, &ss->data.info);
          break;

        case GFC_SS_VECTOR:
          /* Get the vector's descriptor and store it in SS.  */
          gfc_init_se (&se, NULL);
          gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
          gfc_add_block_to_block (&loop->pre, &se.pre);
          gfc_add_block_to_block (&loop->post, &se.post);
          ss->data.info.descriptor = se.expr;
          break;

        case GFC_SS_INTRINSIC:
          gfc_add_intrinsic_ss_code (loop, ss);
          break;

        case GFC_SS_FUNCTION:
          /* Array function return value.  We call the function and save its
             result in a temporary for use inside the loop.  */
          gfc_init_se (&se, NULL);
          se.loop = loop;
          se.ss = ss;
          gfc_conv_expr (&se, ss->expr);
          gfc_add_block_to_block (&loop->pre, &se.pre);
          gfc_add_block_to_block (&loop->post, &se.post);
          ss->string_length = se.string_length;
          break;

        case GFC_SS_CONSTRUCTOR:
          if (ss->expr->ts.type == BT_CHARACTER
                && ss->string_length == NULL
                && ss->expr->ts.u.cl
                && ss->expr->ts.u.cl->length)
            {
              gfc_init_se (&se, NULL);
              gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
                                  gfc_charlen_type_node);
              ss->string_length = se.expr;
              gfc_add_block_to_block (&loop->pre, &se.pre);
              gfc_add_block_to_block (&loop->post, &se.post);
            }
          gfc_trans_array_constructor (loop, ss, where);
          break;

        case GFC_SS_TEMP:
        case GFC_SS_COMPONENT:
          /* Do nothing.  These are handled elsewhere.  */
          break;

        default:
          gcc_unreachable ();
        }
    }
}


/* Translate expressions for the descriptor and data pointer of a SS.  */
/*GCC ARRAYS*/

static void
gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
{
  gfc_se se;
  tree tmp;

  /* Get the descriptor for the array to be scalarized.  */
  gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
  gfc_init_se (&se, NULL);
  se.descriptor_only = 1;
  gfc_conv_expr_lhs (&se, ss->expr);
  gfc_add_block_to_block (block, &se.pre);
  ss->data.info.descriptor = se.expr;
  ss->string_length = se.string_length;

  if (base)
    {
      /* Also the data pointer.  */
      tmp = gfc_conv_array_data (se.expr);
      /* If this is a variable or address of a variable we use it directly.
         Otherwise we must evaluate it now to avoid breaking dependency
         analysis by pulling the expressions for elemental array indices
         inside the loop.  */
      if (!(DECL_P (tmp)
            || (TREE_CODE (tmp) == ADDR_EXPR
                && DECL_P (TREE_OPERAND (tmp, 0)))))
        tmp = gfc_evaluate_now (tmp, block);
      ss->data.info.data = tmp;

      tmp = gfc_conv_array_offset (se.expr);
      ss->data.info.offset = gfc_evaluate_now (tmp, block);
    }
}


/* Initialize a gfc_loopinfo structure.  */

void
gfc_init_loopinfo (gfc_loopinfo * loop)
{
  int n;

  memset (loop, 0, sizeof (gfc_loopinfo));
  gfc_init_block (&loop->pre);
  gfc_init_block (&loop->post);

  /* Initially scalarize in order.  */
  for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
    loop->order[n] = n;

  loop->ss = gfc_ss_terminator;
}


/* Copies the loop variable info to a gfc_se structure. Does not copy the SS
   chain.  */

void
gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
{
  se->loop = loop;
}


/* Return an expression for the data pointer of an array.  */

tree
gfc_conv_array_data (tree descriptor)
{
  tree type;

  type = TREE_TYPE (descriptor);
  if (GFC_ARRAY_TYPE_P (type))
    {
      if (TREE_CODE (type) == POINTER_TYPE)
        return descriptor;
      else
        {
          /* Descriptorless arrays.  */
          return gfc_build_addr_expr (NULL_TREE, descriptor);
        }
    }
  else
    return gfc_conv_descriptor_data_get (descriptor);
}


/* Return an expression for the base offset of an array.  */

tree
gfc_conv_array_offset (tree descriptor)
{
  tree type;

  type = TREE_TYPE (descriptor);
  if (GFC_ARRAY_TYPE_P (type))
    return GFC_TYPE_ARRAY_OFFSET (type);
  else
    return gfc_conv_descriptor_offset_get (descriptor);
}


/* Get an expression for the array stride.  */

tree
gfc_conv_array_stride (tree descriptor, int dim)
{
  tree tmp;
  tree type;

  type = TREE_TYPE (descriptor);

  /* For descriptorless arrays use the array size.  */
  tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
  if (tmp != NULL_TREE)
    return tmp;

  tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
  return tmp;
}


/* Like gfc_conv_array_stride, but for the lower bound.  */

tree
gfc_conv_array_lbound (tree descriptor, int dim)
{
  tree tmp;
  tree type;

  type = TREE_TYPE (descriptor);

  tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
  if (tmp != NULL_TREE)
    return tmp;

  tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
  return tmp;
}


/* Like gfc_conv_array_stride, but for the upper bound.  */

tree
gfc_conv_array_ubound (tree descriptor, int dim)
{
  tree tmp;
  tree type;

  type = TREE_TYPE (descriptor);

  tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
  if (tmp != NULL_TREE)
    return tmp;

  /* This should only ever happen when passing an assumed shape array
     as an actual parameter.  The value will never be used.  */
  if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
    return gfc_index_zero_node;

  tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
  return tmp;
}


/* Generate code to perform an array index bound check.  */

static tree
gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
                             locus * where, bool check_upper)
{
  tree fault;
  tree tmp_lo, tmp_up;
  char *msg;
  const char * name = NULL;

  if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
    return index;

  index = gfc_evaluate_now (index, &se->pre);

  /* We find a name for the error message.  */
  if (se->ss)
    name = se->ss->expr->symtree->name;

  if (!name && se->loop && se->loop->ss && se->loop->ss->expr
      && se->loop->ss->expr->symtree)
    name = se->loop->ss->expr->symtree->name;

  if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
      && se->loop->ss->loop_chain->expr
      && se->loop->ss->loop_chain->expr->symtree)
    name = se->loop->ss->loop_chain->expr->symtree->name;

  if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
    {
      if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
          && se->loop->ss->expr->value.function.name)
        name = se->loop->ss->expr->value.function.name;
      else
        if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
            || se->loop->ss->type == GFC_SS_SCALAR)
          name = "unnamed constant";
    }

  if (TREE_CODE (descriptor) == VAR_DECL)
    name = IDENTIFIER_POINTER (DECL_NAME (descriptor));

  /* If upper bound is present, include both bounds in the error message.  */
  if (check_upper)
    {
      tmp_lo = gfc_conv_array_lbound (descriptor, n);
      tmp_up = gfc_conv_array_ubound (descriptor, n);

      if (name)
        asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
                  "outside of expected range (%%ld:%%ld)", n+1, name);
      else
        asprintf (&msg, "Index '%%ld' of dimension %d "
                  "outside of expected range (%%ld:%%ld)", n+1);

      fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
                               fold_convert (long_integer_type_node, index),
                               fold_convert (long_integer_type_node, tmp_lo),
                               fold_convert (long_integer_type_node, tmp_up));
      fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp_up);
      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
                               fold_convert (long_integer_type_node, index),
                               fold_convert (long_integer_type_node, tmp_lo),
                               fold_convert (long_integer_type_node, tmp_up));
      gfc_free (msg);
    }
  else
    {
      tmp_lo = gfc_conv_array_lbound (descriptor, n);

      if (name)
        asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
                  "below lower bound of %%ld", n+1, name);
      else
        asprintf (&msg, "Index '%%ld' of dimension %d "
                  "below lower bound of %%ld", n+1);

      fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
                               fold_convert (long_integer_type_node, index),
                               fold_convert (long_integer_type_node, tmp_lo));
      gfc_free (msg);
    }

  return index;
}


/* Return the offset for an index.  Performs bound checking for elemental
   dimensions.  Single element references are processed separately.  */

static tree
gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
                             gfc_array_ref * ar, tree stride)
{
  tree index;
  tree desc;
  tree data;

  /* Get the index into the array for this dimension.  */
  if (ar)
    {
      gcc_assert (ar->type != AR_ELEMENT);
      switch (ar->dimen_type[dim])
        {
        case DIMEN_ELEMENT:
          /* Elemental dimension.  */
          gcc_assert (info->subscript[dim]
                      && info->subscript[dim]->type == GFC_SS_SCALAR);
          /* We've already translated this value outside the loop.  */
          index = info->subscript[dim]->data.scalar.expr;

          index = gfc_trans_array_bound_check (se, info->descriptor,
                        index, dim, &ar->where,
                        ar->as->type != AS_ASSUMED_SIZE
                        || dim < ar->dimen - 1);
          break;

        case DIMEN_VECTOR:
          gcc_assert (info && se->loop);
          gcc_assert (info->subscript[dim]
                      && info->subscript[dim]->type == GFC_SS_VECTOR);
          desc = info->subscript[dim]->data.info.descriptor;

          /* Get a zero-based index into the vector.  */
          index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
                               se->loop->loopvar[i], se->loop->from[i]);

          /* Multiply the index by the stride.  */
          index = fold_build2 (MULT_EXPR, gfc_array_index_type,
                               index, gfc_conv_array_stride (desc, 0));

          /* Read the vector to get an index into info->descriptor.  */
          data = build_fold_indirect_ref_loc (input_location,
                                          gfc_conv_array_data (desc));
          index = gfc_build_array_ref (data, index, NULL);
          index = gfc_evaluate_now (index, &se->pre);
          index = fold_convert (gfc_array_index_type, index);

          /* Do any bounds checking on the final info->descriptor index.  */
          index = gfc_trans_array_bound_check (se, info->descriptor,
                        index, dim, &ar->where,
                        ar->as->type != AS_ASSUMED_SIZE
                        || dim < ar->dimen - 1);
          break;

        case DIMEN_RANGE:
          /* Scalarized dimension.  */
          gcc_assert (info && se->loop);

          /* Multiply the loop variable by the stride and delta.  */
          index = se->loop->loopvar[i];
          if (!integer_onep (info->stride[i]))
            index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
                                 info->stride[i]);
          if (!integer_zerop (info->delta[i]))
            index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
                                 info->delta[i]);
          break;

        default:
          gcc_unreachable ();
        }
    }
  else
    {
      /* Temporary array or derived type component.  */
      gcc_assert (se->loop);
      index = se->loop->loopvar[se->loop->order[i]];
      if (!integer_zerop (info->delta[i]))
        index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
                             index, info->delta[i]);
    }

  /* Multiply by the stride.  */
  if (!integer_onep (stride))
    index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);

  return index;
}


/* Build a scalarized reference to an array.  */

static void
gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
{
  gfc_ss_info *info;
  tree decl = NULL_TREE;
  tree index;
  tree tmp;
  int n;

  info = &se->ss->data.info;
  if (ar)
    n = se->loop->order[0];
  else
    n = 0;

  index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
                                       info->stride0);
  /* Add the offset for this dimension to the stored offset for all other
     dimensions.  */
  if (!integer_zerop (info->offset))
    index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);

  if (se->ss->expr && is_subref_array (se->ss->expr))
    decl = se->ss->expr->symtree->n.sym->backend_decl;

  tmp = build_fold_indirect_ref_loc (input_location,
                                 info->data);
  se->expr = gfc_build_array_ref (tmp, index, decl);
}


/* Translate access of temporary array.  */

void
gfc_conv_tmp_array_ref (gfc_se * se)
{
  se->string_length = se->ss->string_length;
  gfc_conv_scalarized_array_ref (se, NULL);
}


/* Build an array reference.  se->expr already holds the array descriptor.
   This should be either a variable, indirect variable reference or component
   reference.  For arrays which do not have a descriptor, se->expr will be
   the data pointer.
   a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/

void
gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
                    locus * where)
{
  int n;
  tree index;
  tree tmp;
  tree stride;
  gfc_se indexse;
  gfc_se tmpse;

  if (ar->dimen == 0)
    return;

  /* Handle scalarized references separately.  */
  if (ar->type != AR_ELEMENT)
    {
      gfc_conv_scalarized_array_ref (se, ar);
      gfc_advance_se_ss_chain (se);
      return;
    }

  index = gfc_index_zero_node;

  /* Calculate the offsets from all the dimensions.  */
  for (n = 0; n < ar->dimen; n++)
    {
      /* Calculate the index for this dimension.  */
      gfc_init_se (&indexse, se);
      gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
      gfc_add_block_to_block (&se->pre, &indexse.pre);

      if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
        {
          /* Check array bounds.  */
          tree cond;
          char *msg;

          /* Evaluate the indexse.expr only once.  */
          indexse.expr = save_expr (indexse.expr);

          /* Lower bound.  */
          tmp = gfc_conv_array_lbound (se->expr, n);
          if (sym->attr.temporary)
            {
              gfc_init_se (&tmpse, se);
              gfc_conv_expr_type (&tmpse, ar->as->lower[n],
                                  gfc_array_index_type);
              gfc_add_block_to_block (&se->pre, &tmpse.pre);
              tmp = tmpse.expr;
            }

          cond = fold_build2 (LT_EXPR, boolean_type_node, 
                              indexse.expr, tmp);
          asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
                    "below lower bound of %%ld", n+1, sym->name);
          gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
                                   fold_convert (long_integer_type_node,
                                                 indexse.expr),
                                   fold_convert (long_integer_type_node, tmp));
          gfc_free (msg);

          /* Upper bound, but not for the last dimension of assumed-size
             arrays.  */
          if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
            {
              tmp = gfc_conv_array_ubound (se->expr, n);
              if (sym->attr.temporary)
                {
                  gfc_init_se (&tmpse, se);
                  gfc_conv_expr_type (&tmpse, ar->as->upper[n],
                                      gfc_array_index_type);
                  gfc_add_block_to_block (&se->pre, &tmpse.pre);
                  tmp = tmpse.expr;
                }

              cond = fold_build2 (GT_EXPR, boolean_type_node, 
                                  indexse.expr, tmp);
              asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
                        "above upper bound of %%ld", n+1, sym->name);
              gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
                                   fold_convert (long_integer_type_node,
                                                 indexse.expr),
                                   fold_convert (long_integer_type_node, tmp));
              gfc_free (msg);
            }
        }

      /* Multiply the index by the stride.  */
      stride = gfc_conv_array_stride (se->expr, n);
      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
                         stride);

      /* And add it to the total.  */
      index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
    }

  tmp = gfc_conv_array_offset (se->expr);
  if (!integer_zerop (tmp))
    index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);

  /* Access the calculated element.  */
  tmp = gfc_conv_array_data (se->expr);
  tmp = build_fold_indirect_ref (tmp);
  se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
}


/* Generate the code to be executed immediately before entering a
   scalarization loop.  */

static void
gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
                         stmtblock_t * pblock)
{
  tree index;
  tree stride;
  gfc_ss_info *info;
  gfc_ss *ss;
  gfc_se se;
  int i;

  /* This code will be executed before entering the scalarization loop
     for this dimension.  */
  for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
    {
      if ((ss->useflags & flag) == 0)
        continue;

      if (ss->type != GFC_SS_SECTION
          && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
          && ss->type != GFC_SS_COMPONENT)
        continue;

      info = &ss->data.info;

      if (dim >= info->dimen)
        continue;

      if (dim == info->dimen - 1)
        {
          /* For the outermost loop calculate the offset due to any
             elemental dimensions.  It will have been initialized with the
             base offset of the array.  */
          if (info->ref)
            {
              for (i = 0; i < info->ref->u.ar.dimen; i++)
                {
                  if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
                    continue;

                  gfc_init_se (&se, NULL);
                  se.loop = loop;
                  se.expr = info->descriptor;
                  stride = gfc_conv_array_stride (info->descriptor, i);
                  index = gfc_conv_array_index_offset (&se, info, i, -1,
                                                       &info->ref->u.ar,
                                                       stride);
                  gfc_add_block_to_block (pblock, &se.pre);

                  info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
                                              info->offset, index);
                  info->offset = gfc_evaluate_now (info->offset, pblock);
                }

              i = loop->order[0];
              stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
            }
          else
            stride = gfc_conv_array_stride (info->descriptor, 0);

          /* Calculate the stride of the innermost loop.  Hopefully this will
             allow the backend optimizers to do their stuff more effectively.
           */
          info->stride0 = gfc_evaluate_now (stride, pblock);
        }
      else
        {
          /* Add the offset for the previous loop dimension.  */
          gfc_array_ref *ar;

          if (info->ref)
            {
              ar = &info->ref->u.ar;
              i = loop->order[dim + 1];
            }
          else
            {
              ar = NULL;
              i = dim + 1;
            }

          gfc_init_se (&se, NULL);
          se.loop = loop;
          se.expr = info->descriptor;
          stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
          index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
                                               ar, stride);
          gfc_add_block_to_block (pblock, &se.pre);
          info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
                                      info->offset, index);
          info->offset = gfc_evaluate_now (info->offset, pblock);
        }

      /* Remember this offset for the second loop.  */
      if (dim == loop->temp_dim - 1)
        info->saved_offset = info->offset;
    }
}


/* Start a scalarized expression.  Creates a scope and declares loop
   variables.  */

void
gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
{
  int dim;
  int n;
  int flags;

  gcc_assert (!loop->array_parameter);

  for (dim = loop->dimen - 1; dim >= 0; dim--)
    {
      n = loop->order[dim];

      gfc_start_block (&loop->code[n]);

      /* Create the loop variable.  */
      loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");

      if (dim < loop->temp_dim)
        flags = 3;
      else
        flags = 1;
      /* Calculate values that will be constant within this loop.  */
      gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
    }
  gfc_start_block (pbody);
}


/* Generates the actual loop code for a scalarization loop.  */

void
gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
                               stmtblock_t * pbody)
{
  stmtblock_t block;
  tree cond;
  tree tmp;
  tree loopbody;
  tree exit_label;
  tree stmt;
  tree init;
  tree incr;

  if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
      == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
      && n == loop->dimen - 1)
    {
      /* We create an OMP_FOR construct for the outermost scalarized loop.  */
      init = make_tree_vec (1);
      cond = make_tree_vec (1);
      incr = make_tree_vec (1);

      /* Cycle statement is implemented with a goto.  Exit statement must not
         be present for this loop.  */
      exit_label = gfc_build_label_decl (NULL_TREE);
      TREE_USED (exit_label) = 1;

      /* Label for cycle statements (if needed).  */
      tmp = build1_v (LABEL_EXPR, exit_label);
      gfc_add_expr_to_block (pbody, tmp);

      stmt = make_node (OMP_FOR);

      TREE_TYPE (stmt) = void_type_node;
      OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);

      OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
                                                 OMP_CLAUSE_SCHEDULE);
      OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
        = OMP_CLAUSE_SCHEDULE_STATIC;
      if (ompws_flags & OMPWS_NOWAIT)
        OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
          = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);

      /* Initialize the loopvar.  */
      TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
                                         loop->from[n]);
      OMP_FOR_INIT (stmt) = init;
      /* The exit condition.  */
      TREE_VEC_ELT (cond, 0) = build2 (LE_EXPR, boolean_type_node,
                                       loop->loopvar[n], loop->to[n]);
      OMP_FOR_COND (stmt) = cond;
      /* Increment the loopvar.  */
      tmp = build2 (PLUS_EXPR, gfc_array_index_type,
          loop->loopvar[n], gfc_index_one_node);
      TREE_VEC_ELT (incr, 0) = fold_build2 (MODIFY_EXPR,
          void_type_node, loop->loopvar[n], tmp);
      OMP_FOR_INCR (stmt) = incr;

      ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
      gfc_add_expr_to_block (&loop->code[n], stmt);
    }
  else
    {
      loopbody = gfc_finish_block (pbody);

      /* Initialize the loopvar.  */
      if (loop->loopvar[n] != loop->from[n])
        gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);

      exit_label = gfc_build_label_decl (NULL_TREE);

      /* Generate the loop body.  */
      gfc_init_block (&block);

      /* The exit condition.  */
      cond = fold_build2 (GT_EXPR, boolean_type_node,
                         loop->loopvar[n], loop->to[n]);
      tmp = build1_v (GOTO_EXPR, exit_label);
      TREE_USED (exit_label) = 1;
      tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
      gfc_add_expr_to_block (&block, tmp);

      /* The main body.  */
      gfc_add_expr_to_block (&block, loopbody);

      /* Increment the loopvar.  */
      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
                         loop->loopvar[n], gfc_index_one_node);
      gfc_add_modify (&block, loop->loopvar[n], tmp);

      /* Build the loop.  */
      tmp = gfc_finish_block (&block);
      tmp = build1_v (LOOP_EXPR, tmp);
      gfc_add_expr_to_block (&loop->code[n], tmp);

      /* Add the exit label.  */
      tmp = build1_v (LABEL_EXPR, exit_label);
      gfc_add_expr_to_block (&loop->code[n], tmp);
    }

}


/* Finishes and generates the loops for a scalarized expression.  */

void
gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
{
  int dim;
  int n;
  gfc_ss *ss;
  stmtblock_t *pblock;
  tree tmp;

  pblock = body;
  /* Generate the loops.  */
  for (dim = 0; dim < loop->dimen; dim++)
    {
      n = loop->order[dim];
      gfc_trans_scalarized_loop_end (loop, n, pblock);
      loop->loopvar[n] = NULL_TREE;
      pblock = &loop->code[n];
    }

  tmp = gfc_finish_block (pblock);
  gfc_add_expr_to_block (&loop->pre, tmp);

  /* Clear all the used flags.  */
  for (ss = loop->ss; ss; ss = ss->loop_chain)
    ss->useflags = 0;
}


/* Finish the main body of a scalarized expression, and start the secondary
   copying body.  */

void
gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
{
  int dim;
  int n;
  stmtblock_t *pblock;
  gfc_ss *ss;

  pblock = body;
  /* We finish as many loops as are used by the temporary.  */
  for (dim = 0; dim < loop->temp_dim - 1; dim++)
    {
      n = loop->order[dim];
      gfc_trans_scalarized_loop_end (loop, n, pblock);
      loop->loopvar[n] = NULL_TREE;
      pblock = &loop->code[n];
    }

  /* We don't want to finish the outermost loop entirely.  */
  n = loop->order[loop->temp_dim - 1];
  gfc_trans_scalarized_loop_end (loop, n, pblock);

  /* Restore the initial offsets.  */
  for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
    {
      if ((ss->useflags & 2) == 0)
        continue;

      if (ss->type != GFC_SS_SECTION
          && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
          && ss->type != GFC_SS_COMPONENT)
        continue;

      ss->data.info.offset = ss->data.info.saved_offset;
    }

  /* Restart all the inner loops we just finished.  */
  for (dim = loop->temp_dim - 2; dim >= 0; dim--)
    {
      n = loop->order[dim];

      gfc_start_block (&loop->code[n]);

      loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");

      gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
    }

  /* Start a block for the secondary copying code.  */
  gfc_start_block (body);
}


/* Calculate the upper bound of an array section.  */

static tree
gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
{
  int dim;
  gfc_expr *end;
  tree desc;
  tree bound;
  gfc_se se;
  gfc_ss_info *info;

  gcc_assert (ss->type == GFC_SS_SECTION);

  info = &ss->data.info;
  dim = info->dim[n];

  if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
    /* We'll calculate the upper bound once we have access to the
       vector's descriptor.  */
    return NULL;

  gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
  desc = info->descriptor;
  end = info->ref->u.ar.end[dim];

  if (end)
    {
      /* The upper bound was specified.  */
      gfc_init_se (&se, NULL);
      gfc_conv_expr_type (&se, end, gfc_array_index_type);
      gfc_add_block_to_block (pblock, &se.pre);
      bound = se.expr;
    }
  else
    {
      /* No upper bound was specified, so use the bound of the array.  */
      bound = gfc_conv_array_ubound (desc, dim);
    }

  return bound;
}


/* Calculate the lower bound of an array section.  */

static void
gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
{
  gfc_expr *start;
  gfc_expr *end;
  gfc_expr *stride;
  tree desc;
  gfc_se se;
  gfc_ss_info *info;
  int dim;

  gcc_assert (ss->type == GFC_SS_SECTION);

  info = &ss->data.info;
  dim = info->dim[n];

  if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
    {
      /* We use a zero-based index to access the vector.  */
      info->start[n] = gfc_index_zero_node;
      info->end[n] = gfc_index_zero_node;
      info->stride[n] = gfc_index_one_node;
      return;
    }

  gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
  desc = info->descriptor;
  start = info->ref->u.ar.start[dim];
  end = info->ref->u.ar.end[dim];
  stride = info->ref->u.ar.stride[dim];

  /* Calculate the start of the range.  For vector subscripts this will
     be the range of the vector.  */
  if (start)
    {
      /* Specified section start.  */
      gfc_init_se (&se, NULL);
      gfc_conv_expr_type (&se, start, gfc_array_index_type);
      gfc_add_block_to_block (&loop->pre, &se.pre);
      info->start[n] = se.expr;
    }
  else
    {
      /* No lower bound specified so use the bound of the array.  */
      info->start[n] = gfc_conv_array_lbound (desc, dim);
    }
  info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);

  /* Similarly calculate the end.  Although this is not used in the
     scalarizer, it is needed when checking bounds and where the end
     is an expression with side-effects.  */
  if (end)
    {
      /* Specified section start.  */
      gfc_init_se (&se, NULL);
      gfc_conv_expr_type (&se, end, gfc_array_index_type);
      gfc_add_block_to_block (&loop->pre, &se.pre);
      info->end[n] = se.expr;
    }
  else
    {
      /* No upper bound specified so use the bound of the array.  */
      info->end[n] = gfc_conv_array_ubound (desc, dim);
    }
  info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);

  /* Calculate the stride.  */
  if (stride == NULL)
    info->stride[n] = gfc_index_one_node;
  else
    {
      gfc_init_se (&se, NULL);
      gfc_conv_expr_type (&se, stride, gfc_array_index_type);
      gfc_add_block_to_block (&loop->pre, &se.pre);
      info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
    }
}


/* Calculates the range start and stride for a SS chain.  Also gets the
   descriptor and data pointer.  The range of vector subscripts is the size
   of the vector.  Array bounds are also checked.  */

void
gfc_conv_ss_startstride (gfc_loopinfo * loop)
{
  int n;
  tree tmp;
  gfc_ss *ss;
  tree desc;

  loop->dimen = 0;
  /* Determine the rank of the loop.  */
  for (ss = loop->ss;
       ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
    {
      switch (ss->type)
        {
        case GFC_SS_SECTION:
        case GFC_SS_CONSTRUCTOR:
        case GFC_SS_FUNCTION:
        case GFC_SS_COMPONENT:
          loop->dimen = ss->data.info.dimen;
          break;

        /* As usual, lbound and ubound are exceptions!.  */
        case GFC_SS_INTRINSIC:
          switch (ss->expr->value.function.isym->id)
            {
            case GFC_ISYM_LBOUND:
            case GFC_ISYM_UBOUND:
              loop->dimen = ss->data.info.dimen;

            default:
              break;
            }

        default:
          break;
        }
    }

  /* We should have determined the rank of the expression by now.  If
     not, that's bad news.  */
  gcc_assert (loop->dimen != 0);

  /* Loop over all the SS in the chain.  */
  for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
    {
      if (ss->expr && ss->expr->shape && !ss->shape)
        ss->shape = ss->expr->shape;

      switch (ss->type)
        {
        case GFC_SS_SECTION:
          /* Get the descriptor for the array.  */
          gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);

          for (n = 0; n < ss->data.info.dimen; n++)
            gfc_conv_section_startstride (loop, ss, n);
          break;

        case GFC_SS_INTRINSIC:
          switch (ss->expr->value.function.isym->id)
            {
            /* Fall through to supply start and stride.  */
            case GFC_ISYM_LBOUND:
            case GFC_ISYM_UBOUND:
              break;
            default:
              continue;
            }

        case GFC_SS_CONSTRUCTOR:
        case GFC_SS_FUNCTION:
          for (n = 0; n < ss->data.info.dimen; n++)
            {
              ss->data.info.start[n] = gfc_index_zero_node;
              ss->data.info.end[n] = gfc_index_zero_node;
              ss->data.info.stride[n] = gfc_index_one_node;
            }
          break;

        default:
          break;
        }
    }

  /* The rest is just runtime bound checking.  */
  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    {
      stmtblock_t block;
      tree lbound, ubound;
      tree end;
      tree size[GFC_MAX_DIMENSIONS];
      tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
      gfc_ss_info *info;
      char *msg;
      int dim;

      gfc_start_block (&block);

      for (n = 0; n < loop->dimen; n++)
        size[n] = NULL_TREE;

      for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
        {
          stmtblock_t inner;

          if (ss->type != GFC_SS_SECTION)
            continue;

          gfc_start_block (&inner);

          /* TODO: range checking for mapped dimensions.  */
          info = &ss->data.info;

          /* This code only checks ranges.  Elemental and vector
             dimensions are checked later.  */
          for (n = 0; n < loop->dimen; n++)
            {
              bool check_upper;

              dim = info->dim[n];
              if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
                continue;

              if (dim == info->ref->u.ar.dimen - 1
                  && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
                check_upper = false;
              else
                check_upper = true;

              /* Zero stride is not allowed.  */
              tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
                                 gfc_index_zero_node);
              asprintf (&msg, "Zero stride is not allowed, for dimension %d "
                        "of array '%s'", info->dim[n]+1,
                        ss->expr->symtree->name);
              gfc_trans_runtime_check (true, false, tmp, &inner,
                                       &ss->expr->where, msg);
              gfc_free (msg);

              desc = ss->data.info.descriptor;

              /* This is the run-time equivalent of resolve.c's
                 check_dimension().  The logical is more readable there
                 than it is here, with all the trees.  */
              lbound = gfc_conv_array_lbound (desc, dim);
              end = info->end[n];
              if (check_upper)
                ubound = gfc_conv_array_ubound (desc, dim);
              else
                ubound = NULL;

              /* non_zerosized is true when the selected range is not
                 empty.  */
              stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
                                        info->stride[n], gfc_index_zero_node);
              tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
                                 end);
              stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
                                        stride_pos, tmp);

              stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
                                        info->stride[n], gfc_index_zero_node);
              tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
                                 end);
              stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
                                        stride_neg, tmp);
              non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
                                           stride_pos, stride_neg);

              /* Check the start of the range against the lower and upper
                 bounds of the array, if the range is not empty. 
                 If upper bound is present, include both bounds in the 
                 error message.  */
              if (check_upper)
                {
                  tmp = fold_build2 (LT_EXPR, boolean_type_node, 
                                     info->start[n], lbound);
                  tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
                                     non_zerosized, tmp);
                  tmp2 = fold_build2 (GT_EXPR, boolean_type_node,
                                      info->start[n], ubound);
                  tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
                                      non_zerosized, tmp2);
                  asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
                            "outside of expected range (%%ld:%%ld)", 
                            info->dim[n]+1, ss->expr->symtree->name);
                  gfc_trans_runtime_check (true, false, tmp, &inner, 
                                           &ss->expr->where, msg,
                     fold_convert (long_integer_type_node, info->start[n]),
                     fold_convert (long_integer_type_node, lbound), 
                     fold_convert (long_integer_type_node, ubound));
                  gfc_trans_runtime_check (true, false, tmp2, &inner, 
                                           &ss->expr->where, msg,
                     fold_convert (long_integer_type_node, info->start[n]),
                     fold_convert (long_integer_type_node, lbound), 
                     fold_convert (long_integer_type_node, ubound));
                  gfc_free (msg);
                }
              else
                {
                  tmp = fold_build2 (LT_EXPR, boolean_type_node, 
                                     info->start[n], lbound);
                  tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
                                     non_zerosized, tmp);
                  asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
                            "below lower bound of %%ld", 
                            info->dim[n]+1, ss->expr->symtree->name);
                  gfc_trans_runtime_check (true, false, tmp, &inner, 
                                           &ss->expr->where, msg,
                     fold_convert (long_integer_type_node, info->start[n]),
                     fold_convert (long_integer_type_node, lbound));
                  gfc_free (msg);
                }
              
              /* Compute the last element of the range, which is not
                 necessarily "end" (think 0:5:3, which doesn't contain 5)
                 and check it against both lower and upper bounds.  */

              tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
                                  info->start[n]);
              tmp = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp,
                                  info->stride[n]);
              tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
                                  tmp);
              tmp2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, lbound);
              tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
                                 non_zerosized, tmp2);
              if (check_upper)
                {
                  tmp3 = fold_build2 (GT_EXPR, boolean_type_node, tmp, ubound);
                  tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
                                      non_zerosized, tmp3);
                  asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
                            "outside of expected range (%%ld:%%ld)", 
                            info->dim[n]+1, ss->expr->symtree->name);
                  gfc_trans_runtime_check (true, false, tmp2, &inner,
                                           &ss->expr->where, msg,
                     fold_convert (long_integer_type_node, tmp),
                     fold_convert (long_integer_type_node, ubound), 
                     fold_convert (long_integer_type_node, lbound));
                  gfc_trans_runtime_check (true, false, tmp3, &inner,
                                           &ss->expr->where, msg,
                     fold_convert (long_integer_type_node, tmp),
                     fold_convert (long_integer_type_node, ubound), 
                     fold_convert (long_integer_type_node, lbound));
                  gfc_free (msg);
                }
              else
                {
                  asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
                            "below lower bound of %%ld", 
                            info->dim[n]+1, ss->expr->symtree->name);
                  gfc_trans_runtime_check (true, false, tmp2, &inner,
                                           &ss->expr->where, msg,
                     fold_convert (long_integer_type_node, tmp),
                     fold_convert (long_integer_type_node, lbound));
                  gfc_free (msg);
                }
              
              /* Check the section sizes match.  */
              tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
                                 info->start[n]);
              tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
                                 info->stride[n]);
              tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
                                 gfc_index_one_node, tmp);
              tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
                                 build_int_cst (gfc_array_index_type, 0));
              /* We remember the size of the first section, and check all the
                 others against this.  */
              if (size[n])
                {
                  tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
                  asprintf (&msg, "Array bound mismatch for dimension %d "
                            "of array '%s' (%%ld/%%ld)",
                            info->dim[n]+1, ss->expr->symtree->name);

                  gfc_trans_runtime_check (true, false, tmp3, &inner,
                                           &ss->expr->where, msg,
                        fold_convert (long_integer_type_node, tmp),
                        fold_convert (long_integer_type_node, size[n]));

                  gfc_free (msg);
                }
              else