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

/* Expression translation
   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
   2011, 2012
   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-expr.c-- generate GENERIC trees for gfc_expr.  */

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "diagnostic-core.h"    /* For fatal_error.  */
#include "langhooks.h"
#include "flags.h"
#include "gfortran.h"
#include "arith.h"
#include "constructor.h"
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
#include "trans-array.h"
/* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
#include "trans-stmt.h"
#include "dependency.h"


/* This is the seed for an eventual trans-class.c

   The following parameters should not be used directly since they might
   in future implementations.  Use the corresponding APIs.  */
#define CLASS_DATA_FIELD 0
#define CLASS_VPTR_FIELD 1
#define VTABLE_HASH_FIELD 0
#define VTABLE_SIZE_FIELD 1
#define VTABLE_EXTENDS_FIELD 2
#define VTABLE_DEF_INIT_FIELD 3
#define VTABLE_COPY_FIELD 4


tree
gfc_class_data_get (tree decl)
{
  tree data;
  if (POINTER_TYPE_P (TREE_TYPE (decl)))
    decl = build_fold_indirect_ref_loc (input_location, decl);
  data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
                            CLASS_DATA_FIELD);
  return fold_build3_loc (input_location, COMPONENT_REF,
                          TREE_TYPE (data), decl, data,
                          NULL_TREE);
}


tree
gfc_class_vptr_get (tree decl)
{
  tree vptr;
  if (POINTER_TYPE_P (TREE_TYPE (decl)))
    decl = build_fold_indirect_ref_loc (input_location, decl);
  vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
                            CLASS_VPTR_FIELD);
  return fold_build3_loc (input_location, COMPONENT_REF,
                          TREE_TYPE (vptr), decl, vptr,
                          NULL_TREE);
}


static tree
gfc_vtable_field_get (tree decl, int field)
{
  tree size;
  tree vptr;
  vptr = gfc_class_vptr_get (decl);
  vptr = build_fold_indirect_ref_loc (input_location, vptr);
  size = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
                            field);
  size = fold_build3_loc (input_location, COMPONENT_REF,
                          TREE_TYPE (size), vptr, size,
                          NULL_TREE);
  /* Always return size as an array index type.  */
  if (field == VTABLE_SIZE_FIELD)
    size = fold_convert (gfc_array_index_type, size);
  gcc_assert (size);
  return size;
}


tree
gfc_vtable_hash_get (tree decl)
{
  return gfc_vtable_field_get (decl, VTABLE_HASH_FIELD);
}


tree
gfc_vtable_size_get (tree decl)
{
  return gfc_vtable_field_get (decl, VTABLE_SIZE_FIELD);
}


tree
gfc_vtable_extends_get (tree decl)
{
  return gfc_vtable_field_get (decl, VTABLE_EXTENDS_FIELD);
}


tree
gfc_vtable_def_init_get (tree decl)
{
  return gfc_vtable_field_get (decl, VTABLE_DEF_INIT_FIELD);
}


tree
gfc_vtable_copy_get (tree decl)
{
  return gfc_vtable_field_get (decl, VTABLE_COPY_FIELD);
}


#undef CLASS_DATA_FIELD
#undef CLASS_VPTR_FIELD
#undef VTABLE_HASH_FIELD
#undef VTABLE_SIZE_FIELD
#undef VTABLE_EXTENDS_FIELD
#undef VTABLE_DEF_INIT_FIELD
#undef VTABLE_COPY_FIELD


/* Takes a derived type expression and returns the address of a temporary
   class object of the 'declared' type.  */ 
static void
gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
                           gfc_typespec class_ts)
{
  gfc_symbol *vtab;
  gfc_ss *ss;
  tree ctree;
  tree var;
  tree tmp;

  /* The derived type needs to be converted to a temporary
     CLASS object.  */
  tmp = gfc_typenode_for_spec (&class_ts);
  var = gfc_create_var (tmp, "class");

  /* Set the vptr.  */
  ctree =  gfc_class_vptr_get (var);

  /* Remember the vtab corresponds to the derived type
     not to the class declared type.  */
  vtab = gfc_find_derived_vtab (e->ts.u.derived);
  gcc_assert (vtab);
  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
  gfc_add_modify (&parmse->pre, ctree,
                  fold_convert (TREE_TYPE (ctree), tmp));

  /* Now set the data field.  */
  ctree =  gfc_class_data_get (var);

  if (parmse->ss && parmse->ss->info->useflags)
    {
      /* For an array reference in an elemental procedure call we need
         to retain the ss to provide the scalarized array reference.  */
      gfc_conv_expr_reference (parmse, e);
      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
      gfc_add_modify (&parmse->pre, ctree, tmp);
    }
  else
    {
      ss = gfc_walk_expr (e);
      if (ss == gfc_ss_terminator)
        {
          parmse->ss = NULL;
          gfc_conv_expr_reference (parmse, e);
          tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
          gfc_add_modify (&parmse->pre, ctree, tmp);
        }
      else
        {
          parmse->ss = ss;
          gfc_conv_expr_descriptor (parmse, e, ss);
          gfc_add_modify (&parmse->pre, ctree, parmse->expr);
        }
    }

  /* Pass the address of the class object.  */
  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
}


/* Takes a scalarized class array expression and returns the
   address of a temporary scalar class object of the 'declared'
   type.  
   OOP-TODO: This could be improved by adding code that branched on
   the dynamic type being the same as the declared type. In this case
   the original class expression can be passed directly.  */ 
void
gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
                         gfc_typespec class_ts, bool elemental)
{
  tree ctree;
  tree var;
  tree tmp;
  tree vptr;
  gfc_ref *ref;
  gfc_ref *class_ref;
  bool full_array = false;

  class_ref = NULL;
  for (ref = e->ref; ref; ref = ref->next)
    {
      if (ref->type == REF_COMPONENT
            && ref->u.c.component->ts.type == BT_CLASS)
        class_ref = ref;

      if (ref->next == NULL)
        break;
    }

  if (ref == NULL || class_ref == ref)
    return;

  /* Test for FULL_ARRAY.  */
  gfc_is_class_array_ref (e, &full_array);

  /* The derived type needs to be converted to a temporary
     CLASS object.  */
  tmp = gfc_typenode_for_spec (&class_ts);
  var = gfc_create_var (tmp, "class");

  /* Set the data.  */
  ctree = gfc_class_data_get (var);
  gfc_add_modify (&parmse->pre, ctree, parmse->expr);

  /* Return the data component, except in the case of scalarized array
     references, where nullification of the cannot occur and so there
     is no need.  */
  if (!elemental && full_array)
    gfc_add_modify (&parmse->post, parmse->expr, ctree);

  /* Set the vptr.  */
  ctree = gfc_class_vptr_get (var);

  /* The vptr is the second field of the actual argument.
     First we have to find the corresponding class reference. */

  tmp = NULL_TREE;
  if (class_ref == NULL
        && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) 
    tmp = e->symtree->n.sym->backend_decl;
  else
    {
      /* Remove everything after the last class reference, convert the
         expression and then recover its tailend once more.  */
      gfc_se tmpse;
      ref = class_ref->next;
      class_ref->next = NULL;
      gfc_init_se (&tmpse, NULL);
      gfc_conv_expr (&tmpse, e);
      class_ref->next = ref;
      tmp = tmpse.expr;
    }

  gcc_assert (tmp != NULL_TREE);

  /* Dereference if needs be.  */
  if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
    tmp = build_fold_indirect_ref_loc (input_location, tmp);

  vptr = gfc_class_vptr_get (tmp);
  gfc_add_modify (&parmse->pre, ctree,
                  fold_convert (TREE_TYPE (ctree), vptr));

  /* Return the vptr component, except in the case of scalarized array
     references, where the dynamic type cannot change.  */
  if (!elemental && full_array)
    gfc_add_modify (&parmse->post, vptr,
                    fold_convert (TREE_TYPE (vptr), ctree));

  /* Pass the address of the class object.  */
  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
}


/* Given a class array declaration and an index, returns the address
   of the referenced element.  */

tree
gfc_get_class_array_ref (tree index, tree class_decl)
{
  tree data = gfc_class_data_get (class_decl);
  tree size = gfc_vtable_size_get (class_decl);
  tree offset = fold_build2_loc (input_location, MULT_EXPR,
                                 gfc_array_index_type,
                                 index, size);
  tree ptr;
  data = gfc_conv_descriptor_data_get (data);
  ptr = fold_convert (pvoid_type_node, data);
  ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
  return fold_convert (TREE_TYPE (data), ptr);
}


/* Copies one class expression to another, assuming that if either
   'to' or 'from' are arrays they are packed.  Should 'from' be
   NULL_TREE, the inialization expression for 'to' is used, assuming
   that the _vptr is set.  */

tree
gfc_copy_class_to_class (tree from, tree to, tree nelems)
{
  tree fcn;
  tree fcn_type;
  tree from_data;
  tree to_data;
  tree to_ref;
  tree from_ref;
  VEC(tree,gc) *args;
  tree tmp;
  tree index;
  stmtblock_t loopbody;
  stmtblock_t body;
  gfc_loopinfo loop;

  args = NULL;

  if (from != NULL_TREE)
    fcn = gfc_vtable_copy_get (from);
  else
    fcn = gfc_vtable_copy_get (to);

  fcn_type = TREE_TYPE (TREE_TYPE (fcn));

  if (from != NULL_TREE)
    from_data = gfc_class_data_get (from);
  else
    from_data = gfc_vtable_def_init_get (to);

  to_data = gfc_class_data_get (to);

  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
    {
      gfc_init_block (&body);
      tmp = fold_build2_loc (input_location, MINUS_EXPR,
                             gfc_array_index_type, nelems,
                             gfc_index_one_node);
      nelems = gfc_evaluate_now (tmp, &body);
      index = gfc_create_var (gfc_array_index_type, "S");

      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)))
        {
          from_ref = gfc_get_class_array_ref (index, from);
          VEC_safe_push (tree, gc, args, from_ref);
        }
      else
        VEC_safe_push (tree, gc, args, from_data);

      to_ref = gfc_get_class_array_ref (index, to);
      VEC_safe_push (tree, gc, args, to_ref);

      tmp = build_call_vec (fcn_type, fcn, args);

      /* Build the body of the loop.  */
      gfc_init_block (&loopbody);
      gfc_add_expr_to_block (&loopbody, tmp);

      /* Build the loop and return.  */
      gfc_init_loopinfo (&loop);
      loop.dimen = 1;
      loop.from[0] = gfc_index_zero_node;
      loop.loopvar[0] = index;
      loop.to[0] = nelems;
      gfc_trans_scalarizing_loops (&loop, &loopbody);
      gfc_add_block_to_block (&body, &loop.pre);
      tmp = gfc_finish_block (&body);
    }
  else
    {
      gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)));
      VEC_safe_push (tree, gc, args, from_data);
      VEC_safe_push (tree, gc, args, to_data);
      tmp = build_call_vec (fcn_type, fcn, args);
    }

  return tmp;
}

static tree
gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
{
  gfc_actual_arglist *actual;
  gfc_expr *ppc;
  gfc_code *ppc_code;
  tree res;

  actual = gfc_get_actual_arglist ();
  actual->expr = gfc_copy_expr (rhs);
  actual->next = gfc_get_actual_arglist ();
  actual->next->expr = gfc_copy_expr (lhs);
  ppc = gfc_copy_expr (obj);
  gfc_add_vptr_component (ppc);
  gfc_add_component_ref (ppc, "_copy");
  ppc_code = gfc_get_code ();
  ppc_code->resolved_sym = ppc->symtree->n.sym;
  /* Although '_copy' is set to be elemental in class.c, it is
     not staying that way.  Find out why, sometime....  */
  ppc_code->resolved_sym->attr.elemental = 1;
  ppc_code->ext.actual = actual;
  ppc_code->expr1 = ppc;
  ppc_code->op = EXEC_CALL;
  /* Since '_copy' is elemental, the scalarizer will take care
     of arrays in gfc_trans_call.  */
  res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
  gfc_free_statements (ppc_code);
  return res;
}

/* Special case for initializing a polymorphic dummy with INTENT(OUT).
   A MEMCPY is needed to copy the full data from the default initializer
   of the dynamic type.  */

tree
gfc_trans_class_init_assign (gfc_code *code)
{
  stmtblock_t block;
  tree tmp;
  gfc_se dst,src,memsz;
  gfc_expr *lhs, *rhs, *sz;

  gfc_start_block (&block);

  lhs = gfc_copy_expr (code->expr1);
  gfc_add_data_component (lhs);

  rhs = gfc_copy_expr (code->expr1);
  gfc_add_vptr_component (rhs);

  /* Make sure that the component backend_decls have been built, which
     will not have happened if the derived types concerned have not
     been referenced.  */
  gfc_get_derived_type (rhs->ts.u.derived);
  gfc_add_def_init_component (rhs);

  if (code->expr1->ts.type == BT_CLASS
        && CLASS_DATA (code->expr1)->attr.dimension)
    tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
  else
    {
      sz = gfc_copy_expr (code->expr1);
      gfc_add_vptr_component (sz);
      gfc_add_size_component (sz);

      gfc_init_se (&dst, NULL);
      gfc_init_se (&src, NULL);
      gfc_init_se (&memsz, NULL);
      gfc_conv_expr (&dst, lhs);
      gfc_conv_expr (&src, rhs);
      gfc_conv_expr (&memsz, sz);
      gfc_add_block_to_block (&block, &src.pre);
      tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
    }
  gfc_add_expr_to_block (&block, tmp);
  
  return gfc_finish_block (&block);
}


/* Translate an assignment to a CLASS object
   (pointer or ordinary assignment).  */

tree
gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
{
  stmtblock_t block;
  tree tmp;
  gfc_expr *lhs;
  gfc_expr *rhs;
  gfc_ref *ref;

  gfc_start_block (&block);

  ref = expr1->ref;
  while (ref && ref->next)
     ref = ref->next;

  /* Class valued proc_pointer assignments do not need any further
     preparation.  */
  if (ref && ref->type == REF_COMPONENT
        && ref->u.c.component->attr.proc_pointer
        && expr2->expr_type == EXPR_VARIABLE
        && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE
        && op == EXEC_POINTER_ASSIGN)
    goto assign;

  if (expr2->ts.type != BT_CLASS)
    {
      /* Insert an additional assignment which sets the '_vptr' field.  */
      gfc_symbol *vtab = NULL;
      gfc_symtree *st;

      lhs = gfc_copy_expr (expr1);
      gfc_add_vptr_component (lhs);

      if (expr2->ts.type == BT_DERIVED)
        vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
      else if (expr2->expr_type == EXPR_NULL)
        vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
      gcc_assert (vtab);

      rhs = gfc_get_expr ();
      rhs->expr_type = EXPR_VARIABLE;
      gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
      rhs->symtree = st;
      rhs->ts = vtab->ts;

      tmp = gfc_trans_pointer_assignment (lhs, rhs);
      gfc_add_expr_to_block (&block, tmp);

      gfc_free_expr (lhs);
      gfc_free_expr (rhs);
    }
  else if (CLASS_DATA (expr2)->attr.dimension)
    {
      /* Insert an additional assignment which sets the '_vptr' field.  */
      lhs = gfc_copy_expr (expr1);
      gfc_add_vptr_component (lhs);

      rhs = gfc_copy_expr (expr2);
      gfc_add_vptr_component (rhs);

      tmp = gfc_trans_pointer_assignment (lhs, rhs);
      gfc_add_expr_to_block (&block, tmp);

      gfc_free_expr (lhs);
      gfc_free_expr (rhs);
    }

  /* Do the actual CLASS assignment.  */
  if (expr2->ts.type == BT_CLASS
        && !CLASS_DATA (expr2)->attr.dimension)
    op = EXEC_ASSIGN;
  else
    gfc_add_data_component (expr1);

assign:

  if (op == EXEC_ASSIGN)
    tmp = gfc_trans_assignment (expr1, expr2, false, true);
  else if (op == EXEC_POINTER_ASSIGN)
    tmp = gfc_trans_pointer_assignment (expr1, expr2);
  else
    gcc_unreachable();

  gfc_add_expr_to_block (&block, tmp);

  return gfc_finish_block (&block);
}


/* End of prototype trans-class.c  */


static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
                                                 gfc_expr *);

/* Copy the scalarization loop variables.  */

static void
gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
{
  dest->ss = src->ss;
  dest->loop = src->loop;
}


/* Initialize a simple expression holder.

   Care must be taken when multiple se are created with the same parent.
   The child se must be kept in sync.  The easiest way is to delay creation
   of a child se until after after the previous se has been translated.  */

void
gfc_init_se (gfc_se * se, gfc_se * parent)
{
  memset (se, 0, sizeof (gfc_se));
  gfc_init_block (&se->pre);
  gfc_init_block (&se->post);

  se->parent = parent;

  if (parent)
    gfc_copy_se_loopvars (se, parent);
}


/* Advances to the next SS in the chain.  Use this rather than setting
   se->ss = se->ss->next because all the parents needs to be kept in sync.
   See gfc_init_se.  */

void
gfc_advance_se_ss_chain (gfc_se * se)
{
  gfc_se *p;
  gfc_ss *ss;

  gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);

  p = se;
  /* Walk down the parent chain.  */
  while (p != NULL)
    {
      /* Simple consistency check.  */
      gcc_assert (p->parent == NULL || p->parent->ss == p->ss
                  || p->parent->ss->nested_ss == p->ss);

      /* If we were in a nested loop, the next scalarized expression can be
         on the parent ss' next pointer.  Thus we should not take the next
         pointer blindly, but rather go up one nest level as long as next
         is the end of chain.  */
      ss = p->ss;
      while (ss->next == gfc_ss_terminator && ss->parent != NULL)
        ss = ss->parent;

      p->ss = ss->next;

      p = p->parent;
    }
}


/* Ensures the result of the expression as either a temporary variable
   or a constant so that it can be used repeatedly.  */

void
gfc_make_safe_expr (gfc_se * se)
{
  tree var;

  if (CONSTANT_CLASS_P (se->expr))
    return;

  /* We need a temporary for this result.  */
  var = gfc_create_var (TREE_TYPE (se->expr), NULL);
  gfc_add_modify (&se->pre, var, se->expr);
  se->expr = var;
}


/* Return an expression which determines if a dummy parameter is present.
   Also used for arguments to procedures with multiple entry points.  */

tree
gfc_conv_expr_present (gfc_symbol * sym)
{
  tree decl, cond;

  gcc_assert (sym->attr.dummy);

  decl = gfc_get_symbol_decl (sym);
  if (TREE_CODE (decl) != PARM_DECL)
    {
      /* Array parameters use a temporary descriptor, we want the real
         parameter.  */
      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
             || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
      decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
    }

  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
                          fold_convert (TREE_TYPE (decl), null_pointer_node));

  /* Fortran 2008 allows to pass null pointers and non-associated pointers
     as actual argument to denote absent dummies. For array descriptors,
     we thus also need to check the array descriptor.  */
  if (!sym->attr.pointer && !sym->attr.allocatable
      && sym->as && sym->as->type == AS_ASSUMED_SHAPE
      && (gfc_option.allow_std & GFC_STD_F2008) != 0)
    {
      tree tmp;
      tmp = build_fold_indirect_ref_loc (input_location, decl);
      tmp = gfc_conv_array_data (tmp);
      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
                             fold_convert (TREE_TYPE (tmp), null_pointer_node));
      cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
                              boolean_type_node, cond, tmp);
    }

  return cond;
}


/* Converts a missing, dummy argument into a null or zero.  */

void
gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
{
  tree present;
  tree tmp;

  present = gfc_conv_expr_present (arg->symtree->n.sym);

  if (kind > 0)
    {
      /* Create a temporary and convert it to the correct type.  */
      tmp = gfc_get_int_type (kind);
      tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
                                                        se->expr));
    
      /* Test for a NULL value.  */
      tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
                        tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
      tmp = gfc_evaluate_now (tmp, &se->pre);
      se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
    }
  else
    {
      tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
                        present, se->expr,
                        build_zero_cst (TREE_TYPE (se->expr)));
      tmp = gfc_evaluate_now (tmp, &se->pre);
      se->expr = tmp;
    }

  if (ts.type == BT_CHARACTER)
    {
      tmp = build_int_cst (gfc_charlen_type_node, 0);
      tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
                             present, se->string_length, tmp);
      tmp = gfc_evaluate_now (tmp, &se->pre);
      se->string_length = tmp;
    }
  return;
}


/* Get the character length of an expression, looking through gfc_refs
   if necessary.  */

tree
gfc_get_expr_charlen (gfc_expr *e)
{
  gfc_ref *r;
  tree length;

  gcc_assert (e->expr_type == EXPR_VARIABLE 
              && e->ts.type == BT_CHARACTER);
  
  length = NULL; /* To silence compiler warning.  */

  if (is_subref_array (e) && e->ts.u.cl->length)
    {
      gfc_se tmpse;
      gfc_init_se (&tmpse, NULL);
      gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
      e->ts.u.cl->backend_decl = tmpse.expr;
      return tmpse.expr;
    }

  /* First candidate: if the variable is of type CHARACTER, the
     expression's length could be the length of the character
     variable.  */
  if (e->symtree->n.sym->ts.type == BT_CHARACTER)
    length = e->symtree->n.sym->ts.u.cl->backend_decl;

  /* Look through the reference chain for component references.  */
  for (r = e->ref; r; r = r->next)
    {
      switch (r->type)
        {
        case REF_COMPONENT:
          if (r->u.c.component->ts.type == BT_CHARACTER)
            length = r->u.c.component->ts.u.cl->backend_decl;
          break;

        case REF_ARRAY:
          /* Do nothing.  */
          break;

        default:
          /* We should never got substring references here.  These will be
             broken down by the scalarizer.  */
          gcc_unreachable ();
          break;
        }
    }

  gcc_assert (length != NULL);
  return length;
}


/* Return for an expression the backend decl of the coarray.  */

static tree
get_tree_for_caf_expr (gfc_expr *expr)
{
   tree caf_decl = NULL_TREE;
   gfc_ref *ref;

   gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
   if (expr->symtree->n.sym->attr.codimension)
     caf_decl = expr->symtree->n.sym->backend_decl;

   for (ref = expr->ref; ref; ref = ref->next)
     if (ref->type == REF_COMPONENT)
       {
        gfc_component *comp = ref->u.c.component;
        if (comp->attr.pointer || comp->attr.allocatable)
          caf_decl = NULL_TREE;
        if (comp->attr.codimension)
          caf_decl = comp->backend_decl;
       }

   gcc_assert (caf_decl != NULL_TREE);
   return caf_decl;
}


/* For each character array constructor subexpression without a ts.u.cl->length,
   replace it by its first element (if there aren't any elements, the length
   should already be set to zero).  */

static void
flatten_array_ctors_without_strlen (gfc_expr* e)
{
  gfc_actual_arglist* arg;
  gfc_constructor* c;

  if (!e)
    return;

  switch (e->expr_type)
    {

    case EXPR_OP:
      flatten_array_ctors_without_strlen (e->value.op.op1); 
      flatten_array_ctors_without_strlen (e->value.op.op2); 
      break;

    case EXPR_COMPCALL:
      /* TODO: Implement as with EXPR_FUNCTION when needed.  */
      gcc_unreachable ();

    case EXPR_FUNCTION:
      for (arg = e->value.function.actual; arg; arg = arg->next)
        flatten_array_ctors_without_strlen (arg->expr);
      break;

    case EXPR_ARRAY:

      /* We've found what we're looking for.  */
      if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
        {
          gfc_constructor *c;
          gfc_expr* new_expr;

          gcc_assert (e->value.constructor);

          c = gfc_constructor_first (e->value.constructor);
          new_expr = c->expr;
          c->expr = NULL;

          flatten_array_ctors_without_strlen (new_expr);
          gfc_replace_expr (e, new_expr);
          break;
        }

      /* Otherwise, fall through to handle constructor elements.  */
    case EXPR_STRUCTURE:
      for (c = gfc_constructor_first (e->value.constructor);
           c; c = gfc_constructor_next (c))
        flatten_array_ctors_without_strlen (c->expr);
      break;

    default:
      break;

    }
}


/* Generate code to initialize a string length variable. Returns the
   value.  For array constructors, cl->length might be NULL and in this case,
   the first element of the constructor is needed.  expr is the original
   expression so we can access it but can be NULL if this is not needed.  */

void
gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
{
  gfc_se se;

  gfc_init_se (&se, NULL);

  if (!cl->length
        && cl->backend_decl
        && TREE_CODE (cl->backend_decl) == VAR_DECL)
    return;

  /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
     "flatten" array constructors by taking their first element; all elements
     should be the same length or a cl->length should be present.  */
  if (!cl->length)
    {
      gfc_expr* expr_flat;
      gcc_assert (expr);
      expr_flat = gfc_copy_expr (expr);
      flatten_array_ctors_without_strlen (expr_flat);
      gfc_resolve_expr (expr_flat);

      gfc_conv_expr (&se, expr_flat);
      gfc_add_block_to_block (pblock, &se.pre);
      cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);

      gfc_free_expr (expr_flat);
      return;
    }

  /* Convert cl->length.  */

  gcc_assert (cl->length);

  gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
  se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
                             se.expr, build_int_cst (gfc_charlen_type_node, 0));
  gfc_add_block_to_block (pblock, &se.pre);

  if (cl->backend_decl)
    gfc_add_modify (pblock, cl->backend_decl, se.expr);
  else
    cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
}


static void
gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
                    const char *name, locus *where)
{
  tree tmp;
  tree type;
  tree fault;
  gfc_se start;
  gfc_se end;
  char *msg;

  type = gfc_get_character_type (kind, ref->u.ss.length);
  type = build_pointer_type (type);

  gfc_init_se (&start, se);
  gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
  gfc_add_block_to_block (&se->pre, &start.pre);

  if (integer_onep (start.expr))
    gfc_conv_string_parameter (se);
  else
    {
      tmp = start.expr;
      STRIP_NOPS (tmp);
      /* Avoid multiple evaluation of substring start.  */
      if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
        start.expr = gfc_evaluate_now (start.expr, &se->pre);

      /* Change the start of the string.  */
      if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
        tmp = se->expr;
      else
        tmp = build_fold_indirect_ref_loc (input_location,
                                       se->expr);
      tmp = gfc_build_array_ref (tmp, start.expr, NULL);
      se->expr = gfc_build_addr_expr (type, tmp);
    }

  /* Length = end + 1 - start.  */
  gfc_init_se (&end, se);
  if (ref->u.ss.end == NULL)
    end.expr = se->string_length;
  else
    {
      gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
      gfc_add_block_to_block (&se->pre, &end.pre);
    }
  tmp = end.expr;
  STRIP_NOPS (tmp);
  if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
    end.expr = gfc_evaluate_now (end.expr, &se->pre);

  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    {
      tree nonempty = fold_build2_loc (input_location, LE_EXPR,
                                       boolean_type_node, start.expr,
                                       end.expr);

      /* Check lower bound.  */
      fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
                               start.expr,
                               build_int_cst (gfc_charlen_type_node, 1));
      fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
                               boolean_type_node, nonempty, fault);
      if (name)
        asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
                  "is less than one", name);
      else
        asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
                  "is less than one");
      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
                               fold_convert (long_integer_type_node,
                                             start.expr));
      free (msg);

      /* Check upper bound.  */
      fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
                               end.expr, se->string_length);
      fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
                               boolean_type_node, nonempty, fault);
      if (name)
        asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
                  "exceeds string length (%%ld)", name);
      else
        asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
                  "exceeds string length (%%ld)");
      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
                               fold_convert (long_integer_type_node, end.expr),
                               fold_convert (long_integer_type_node,
                                             se->string_length));
      free (msg);
    }

  /* If the start and end expressions are equal, the length is one.  */
  if (ref->u.ss.end
      && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
    tmp = build_int_cst (gfc_charlen_type_node, 1);
  else
    {
      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
                             end.expr, start.expr);
      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
                             build_int_cst (gfc_charlen_type_node, 1), tmp);
      tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
                             tmp, build_int_cst (gfc_charlen_type_node, 0));
    }

  se->string_length = tmp;
}


/* Convert a derived type component reference.  */

static void
gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
{
  gfc_component *c;
  tree tmp;
  tree decl;
  tree field;

  c = ref->u.c.component;

  gcc_assert (c->backend_decl);

  field = c->backend_decl;
  gcc_assert (TREE_CODE (field) == FIELD_DECL);
  decl = se->expr;

  /* Components can correspond to fields of different containing
     types, as components are created without context, whereas
     a concrete use of a component has the type of decl as context.
     So, if the type doesn't match, we search the corresponding
     FIELD_DECL in the parent type.  To not waste too much time
     we cache this result in norestrict_decl.  */

  if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
    {
      tree f2 = c->norestrict_decl;
      if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
        for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
          if (TREE_CODE (f2) == FIELD_DECL
              && DECL_NAME (f2) == DECL_NAME (field))
            break;
      gcc_assert (f2);
      c->norestrict_decl = f2;
      field = f2;
    }
  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
                         decl, field, NULL_TREE);

  se->expr = tmp;

  if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
    {
      tmp = c->ts.u.cl->backend_decl;
      /* Components must always be constant length.  */
      gcc_assert (tmp && INTEGER_CST_P (tmp));
      se->string_length = tmp;
    }

  if (((c->attr.pointer || c->attr.allocatable)
       && (!c->attr.dimension && !c->attr.codimension)
       && c->ts.type != BT_CHARACTER)
      || c->attr.proc_pointer)
    se->expr = build_fold_indirect_ref_loc (input_location,
                                        se->expr);
}


/* This function deals with component references to components of the
   parent type for derived type extensons.  */
static void
conv_parent_component_references (gfc_se * se, gfc_ref * ref)
{
  gfc_component *c;
  gfc_component *cmp;
  gfc_symbol *dt;
  gfc_ref parent;

  dt = ref->u.c.sym;
  c = ref->u.c.component;

  /* Return if the component is not in the parent type.  */
  for (cmp = dt->components; cmp; cmp = cmp->next)
    if (strcmp (c->name, cmp->name) == 0)
      return;

  /* Build a gfc_ref to recursively call gfc_conv_component_ref.  */
  parent.type = REF_COMPONENT;
  parent.next = NULL;
  parent.u.c.sym = dt;
  parent.u.c.component = dt->components;

  if (dt->backend_decl == NULL)
    gfc_get_derived_type (dt);

  /* Build the reference and call self.  */
  gfc_conv_component_ref (se, &parent);
  parent.u.c.sym = dt->components->ts.u.derived;
  parent.u.c.component = c;
  conv_parent_component_references (se, &parent);
}

/* Return the contents of a variable. Also handles reference/pointer
   variables (all Fortran pointer references are implicit).  */

static void
gfc_conv_variable (gfc_se * se, gfc_expr * expr)
{
  gfc_ss *ss;
  gfc_ref *ref;
  gfc_symbol *sym;
  tree parent_decl = NULL_TREE;
  int parent_flag;
  bool return_value;
  bool alternate_entry;
  bool entry_master;

  sym = expr->symtree->n.sym;
  ss = se->ss;
  if (ss != NULL)
    {
      gfc_ss_info *ss_info = ss->info;

      /* Check that something hasn't gone horribly wrong.  */
      gcc_assert (ss != gfc_ss_terminator);
      gcc_assert (ss_info->expr == expr);

      /* A scalarized term.  We already know the descriptor.  */
      se->expr = ss_info->data.array.descriptor;
      se->string_length = ss_info->string_length;
      for (ref = ss_info->data.array.ref; ref; ref = ref->next)
        if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
          break;
    }
  else
    {
      tree se_expr = NULL_TREE;

      se->expr = gfc_get_symbol_decl (sym);

      /* Deal with references to a parent results or entries by storing
         the current_function_decl and moving to the parent_decl.  */
      return_value = sym->attr.function && sym->result == sym;
      alternate_entry = sym->attr.function && sym->attr.entry
                        && sym->result == sym;
      entry_master = sym->attr.result
                     && sym->ns->proc_name->attr.entry_master
                     && !gfc_return_by_reference (sym->ns->proc_name);
      if (current_function_decl)
        parent_decl = DECL_CONTEXT (current_function_decl);

      if ((se->expr == parent_decl && return_value)
           || (sym->ns && sym->ns->proc_name
               && parent_decl
               && sym->ns->proc_name->backend_decl == parent_decl
               && (alternate_entry || entry_master)))
        parent_flag = 1;
      else
        parent_flag = 0;

      /* Special case for assigning the return value of a function.
         Self recursive functions must have an explicit return value.  */
      if (return_value && (se->expr == current_function_decl || parent_flag))
        se_expr = gfc_get_fake_result_decl (sym, parent_flag);

      /* Similarly for alternate entry points.  */
      else if (alternate_entry 
               && (sym->ns->proc_name->backend_decl == current_function_decl
                   || parent_flag))
        {
          gfc_entry_list *el = NULL;

          for (el = sym->ns->entries; el; el = el->next)
            if (sym == el->sym)
              {
                se_expr = gfc_get_fake_result_decl (sym, parent_flag);
                break;
              }
        }

      else if (entry_master
               && (sym->ns->proc_name->backend_decl == current_function_decl
                   || parent_flag))
        se_expr = gfc_get_fake_result_decl (sym, parent_flag);

      if (se_expr)
        se->expr = se_expr;

      /* Procedure actual arguments.  */
      else if (sym->attr.flavor == FL_PROCEDURE
               && se->expr != current_function_decl)
        {
          if (!sym->attr.dummy && !sym->attr.proc_pointer)
            {
              gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
              se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
            }
          return;
        }


      /* Dereference the expression, where needed. Since characters
         are entirely different from other types, they are treated 
         separately.  */
      if (sym->ts.type == BT_CHARACTER)
        {
          /* Dereference character pointer dummy arguments
             or results.  */
          if ((sym->attr.pointer || sym->attr.allocatable)
              && (sym->attr.dummy
                  || sym->attr.function
                  || sym->attr.result))
            se->expr = build_fold_indirect_ref_loc (input_location,
                                                se->expr);

        }
      else if (!sym->attr.value)
        {
          /* Dereference non-character scalar dummy arguments.  */
          if (sym->attr.dummy && !sym->attr.dimension
              && !(sym->attr.codimension && sym->attr.allocatable))
            se->expr = build_fold_indirect_ref_loc (input_location,
                                                se->expr);

          /* Dereference scalar hidden result.  */
          if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
              && (sym->attr.function || sym->attr.result)
              && !sym->attr.dimension && !sym->attr.pointer
              && !sym->attr.always_explicit)
            se->expr = build_fold_indirect_ref_loc (input_location,
                                                se->expr);

          /* Dereference non-character pointer variables. 
             These must be dummies, results, or scalars.  */
          if ((sym->attr.pointer || sym->attr.allocatable
               || gfc_is_associate_pointer (sym))
              && (sym->attr.dummy
                  || sym->attr.function
                  || sym->attr.result
                  || (!sym->attr.dimension
                      && (!sym->attr.codimension || !sym->attr.allocatable))))
            se->expr = build_fold_indirect_ref_loc (input_location,
                                                se->expr);
        }

      ref = expr->ref;
    }

  /* For character variables, also get the length.  */
  if (sym->ts.type == BT_CHARACTER)
    {
      /* If the character length of an entry isn't set, get the length from
         the master function instead.  */
      if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
        se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
      else
        se->string_length = sym->ts.u.cl->backend_decl;
      gcc_assert (se->string_length);
    }

  while (ref)
    {
      switch (ref->type)
        {
        case REF_ARRAY:
          /* Return the descriptor if that's what we want and this is an array
             section reference.  */
          if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
            return;
/* TODO: Pointers to single elements of array sections, eg elemental subs.  */
          /* Return the descriptor for array pointers and allocations.  */
          if (se->want_pointer
              && ref->next == NULL && (se->descriptor_only))
            return;

          gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
          /* Return a pointer to an element.  */
          break;

        case REF_COMPONENT:
          if (ref->u.c.sym->attr.extension)
            conv_parent_component_references (se, ref);

          gfc_conv_component_ref (se, ref);

          break;

        case REF_SUBSTRING:
          gfc_conv_substring (se, ref, expr->ts.kind,
                              expr->symtree->name, &expr->where);
          break;

        default:
          gcc_unreachable ();
          break;
        }
      ref = ref->next;
    }
  /* Pointer assignment, allocation or pass by reference.  Arrays are handled
     separately.  */
  if (se->want_pointer)
    {
      if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
        gfc_conv_string_parameter (se);
      else 
        se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
    }
}


/* Unary ops are easy... Or they would be if ! was a valid op.  */

static void
gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
{
  gfc_se operand;
  tree type;

  gcc_assert (expr->ts.type != BT_CHARACTER);
  /* Initialize the operand.  */
  gfc_init_se (&operand, se);
  gfc_conv_expr_val (&operand, expr->value.op.op1);
  gfc_add_block_to_block (&se->pre, &operand.pre);

  type = gfc_typenode_for_spec (&expr->ts);

  /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
     We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
     All other unary operators have an equivalent GIMPLE unary operator.  */
  if (code == TRUTH_NOT_EXPR)
    se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
                                build_int_cst (type, 0));
  else
    se->expr = fold_build1_loc (input_location, code, type, operand.expr);

}

/* Expand power operator to optimal multiplications when a value is raised
   to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
   Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
   Programming", 3rd Edition, 1998.  */

/* This code is mostly duplicated from expand_powi in the backend.
   We establish the "optimal power tree" lookup table with the defined size.
   The items in the table are the exponents used to calculate the index
   exponents. Any integer n less than the value can get an "addition chain",
   with the first node being one.  */
#define POWI_TABLE_SIZE 256

/* The table is from builtins.c.  */
static const unsigned char powi_table[POWI_TABLE_SIZE] =
  {
      0,   1,   1,   2,   2,   3,   3,   4,  /*   0 -   7 */
      4,   6,   5,   6,   6,  10,   7,   9,  /*   8 -  15 */
      8,  16,   9,  16,  10,  12,  11,  13,  /*  16 -  23 */
     12,  17,  13,  18,  14,  24,  15,  26,  /*  24 -  31 */
     16,  17,  17,  19,  18,  33,  19,  26,  /*  32 -  39 */
     20,  25,  21,  40,  22,  27,  23,  44,  /*  40 -  47 */
     24,  32,  25,  34,  26,  29,  27,  44,  /*  48 -  55 */
     28,  31,  29,  34,  30,  60,  31,  36,  /*  56 -  63 */
     32,  64,  33,  34,  34,  46,  35,  37,  /*  64 -  71 */
     36,  65,  37,  50,  38,  48,  39,  69,  /*  72 -  79 */
     40,  49,  41,  43,  42,  51,  43,  58,  /*  80 -  87 */
     44,  64,  45,  47,  46,  59,  47,  76,  /*  88 -  95 */
     48,  65,  49,  66,  50,  67,  51,  66,  /*  96 - 103 */
     52,  70,  53,  74,  54, 104,  55,  74,  /* 104 - 111 */
     56,  64,  57,  69,  58,  78,  59,  68,  /* 112 - 119 */
     60,  61,  61,  80,  62,  75,  63,  68,  /* 120 - 127 */
     64,  65,  65, 128,  66, 129,  67,  90,  /* 128 - 135 */
     68,  73,  69, 131,  70,  94,  71,  88,  /* 136 - 143 */
     72, 128,  73,  98,  74, 132,  75, 121,  /* 144 - 151 */
     76, 102,  77, 124,  78, 132,  79, 106,  /* 152 - 159 */
     80,  97,  81, 160,  82,  99,  83, 134,  /* 160 - 167 */
     84,  86,  85,  95,  86, 160,  87, 100,  /* 168 - 175 */
     88, 113,  89,  98,  90, 107,  91, 122,  /* 176 - 183 */
     92, 111,  93, 102,  94, 126,  95, 150,  /* 184 - 191 */
     96, 128,  97, 130,  98, 133,  99, 195,  /* 192 - 199 */
    100, 128, 101, 123, 102, 164, 103, 138,  /* 200 - 207 */
    104, 145, 105, 146, 106, 109, 107, 149,  /* 208 - 215 */
    108, 200, 109, 146, 110, 170, 111, 157,  /* 216 - 223 */
    112, 128, 113, 130, 114, 182, 115, 132,  /* 224 - 231 */
    116, 200, 117, 132, 118, 158, 119, 206,  /* 232 - 239 */
    120, 240, 121, 162, 122, 147, 123, 152,  /* 240 - 247 */
    124, 166, 125, 214, 126, 138, 127, 153,  /* 248 - 255 */
  };

/* If n is larger than lookup table's max index, we use the "window 
   method".  */
#define POWI_WINDOW_SIZE 3

/* Recursive function to expand the power operator. The temporary 
   values are put in tmpvar. The function returns tmpvar[1] ** n.  */
static tree
gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
{
  tree op0;
  tree op1;
  tree tmp;
  int digit;

  if (n < POWI_TABLE_SIZE)
    {
      if (tmpvar[n])
        return tmpvar[n];

      op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
      op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
    }
  else if (n & 1)
    {
      digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
      op0 = gfc_conv_powi (se, n - digit, tmpvar);
      op1 = gfc_conv_powi (se, digit, tmpvar);
    }
  else
    {
      op0 = gfc_conv_powi (se, n >> 1, tmpvar);
      op1 = op0;
    }

  tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
  tmp = gfc_evaluate_now (tmp, &se->pre);

  if (n < POWI_TABLE_SIZE)
    tmpvar[n] = tmp;

  return tmp;
}


/* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
   return 1. Else return 0 and a call to runtime library functions
   will have to be built.  */
static int
gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
{
  tree cond;
  tree tmp;
  tree type;
  tree vartmp[POWI_TABLE_SIZE];
  HOST_WIDE_INT m;
  unsigned HOST_WIDE_INT n;
  int sgn;

  /* If exponent is too large, we won't expand it anyway, so don't bother
     with large integer values.  */
  if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
    return 0;

  m = double_int_to_shwi (TREE_INT_CST (rhs));
  /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
     of the asymmetric range of the integer type.  */
  n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
  
  type = TREE_TYPE (lhs);
  sgn = tree_int_cst_sgn (rhs);

  if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
       || optimize_size) && (m > 2 || m < -1))
    return 0;

  /* rhs == 0  */
  if (sgn == 0)
    {
      se->expr = gfc_build_const (type, integer_one_node);
      return 1;
    }

  /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1.  */
  if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
    {
      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
                             lhs, build_int_cst (TREE_TYPE (lhs), -1));
      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
                              lhs, build_int_cst (TREE_TYPE (lhs), 1));

      /* If rhs is even,
         result = (lhs == 1 || lhs == -1) ? 1 : 0.  */
      if ((n & 1) == 0)
        {
          tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
                                 boolean_type_node, tmp, cond);
          se->expr = fold_build3_loc (input_location, COND_EXPR, type,
                                      tmp, build_int_cst (type, 1),
                                      build_int_cst (type, 0));
          return 1;
        }
      /* If rhs is odd,
         result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0.  */
      tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
                             build_int_cst (type, -1),
                             build_int_cst (type, 0));
      se->expr = fold_build3_loc (input_location, COND_EXPR, type,
                                  cond, build_int_cst (type, 1), tmp);
      return 1;
    }

  memset (vartmp, 0, sizeof (vartmp));
  vartmp[1] = lhs;
  if (sgn == -1)
    {
      tmp = gfc_build_const (type, integer_one_node);
      vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
                                   vartmp[1]);
    }

  se->expr = gfc_conv_powi (se, n, vartmp);

  return 1;
}


/* Power op (**).  Constant integer exponent has special handling.  */

static void
gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
{
  tree gfc_int4_type_node;
  int kind;
  int ikind;
  int res_ikind_1, res_ikind_2;
  gfc_se lse;
  gfc_se rse;
  tree fndecl = NULL;

  gfc_init_se (&lse, se);
  gfc_conv_expr_val (&lse, expr->value.op.op1);
  lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
  gfc_add_block_to_block (&se->pre, &lse.pre);

  gfc_init_se (&rse, se);
  gfc_conv_expr_val (&rse, expr->value.op.op2);
  gfc_add_block_to_block (&se->pre, &rse.pre);

  if (expr->value.op.op2->ts.type == BT_INTEGER
      && expr->value.op.op2->expr_type == EXPR_CONSTANT)
    if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
      return;

  gfc_int4_type_node = gfc_get_int_type (4);

  /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
     library routine.  But in the end, we have to convert the result back
     if this case applies -- with res_ikind_K, we keep track whether operand K
     falls into this case.  */
  res_ikind_1 = -1;
  res_ikind_2 = -1;

  kind = expr->value.op.op1->ts.kind;
  switch (expr->value.op.op2->ts.type)
    {
    case BT_INTEGER:
      ikind = expr->value.op.op2->ts.kind;
      switch (ikind)
        {
        case 1:
        case 2:
          rse.expr = convert (gfc_int4_type_node, rse.expr);
          res_ikind_2 = ikind;
          /* Fall through.  */

        case 4:
          ikind = 0;
          break;
          
        case 8:
          ikind = 1;
          break;

        case 16:
          ikind = 2;
          break;

        default:
          gcc_unreachable ();
        }
      switch (kind)
        {
        case 1:
        case 2:
          if (expr->value.op.op1->ts.type == BT_INTEGER)
            {
              lse.expr = convert (gfc_int4_type_node, lse.expr);
              res_ikind_1 = kind;
            }
          else
            gcc_unreachable ();
          /* Fall through.  */

        case 4:
          kind = 0;
          break;
          
        case 8:
          kind = 1;
          break;

        case 10:
          kind = 2;
          break;

        case 16:
          kind = 3;
          break;

        default:
          gcc_unreachable ();
        }
      
      switch (expr->value.op.op1->ts.type)
        {
        case BT_INTEGER:
          if (kind == 3) /* Case 16 was not handled properly above.  */
            kind = 2;
          fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
          break;

        case BT_REAL:
          /* Use builtins for real ** int4.  */
          if (ikind == 0)
            {
              switch (kind)
                {
                case 0:
                  fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
                  break;
                
                case 1:
                  fndecl = builtin_decl_explicit (BUILT_IN_POWI);
                  break;

                case 2:
                  fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
                  break;

                case 3:
                  /* Use the __builtin_powil() only if real(kind=16) is 
                     actually the C long double type.  */
                  if (!gfc_real16_is_float128)
                    fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
                  break;

                default:
                  gcc_unreachable ();
                }
            }

          /* If we don't have a good builtin for this, go for the 
             library function.  */
          if (!fndecl)
            fndecl = gfor_fndecl_math_powi[kind][ikind].real;
          break;

        case BT_COMPLEX:
          fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
          break;

        default:
          gcc_unreachable ();
        }
      break;

    case BT_REAL:
      fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
      break;

    case BT_COMPLEX:
      fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
      break;

    default:
      gcc_unreachable ();
      break;
    }

  se->expr = build_call_expr_loc (input_location,
                              fndecl, 2, lse.expr, rse.expr);

  /* Convert the result back if it is of wrong integer kind.  */
  if (res_ikind_1 != -1 && res_ikind_2 != -1)
    {
      /* We want the maximum of both operand kinds as result.  */
      if (res_ikind_1 < res_ikind_2)
        res_ikind_1 = res_ikind_2;
      se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
    }
}


/* Generate code to allocate a string temporary.  */

tree
gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
{
  tree var;
  tree tmp;

  if (gfc_can_put_var_on_stack (len))
    {
      /* Create a temporary variable to hold the result.  */
      tmp = fold_build2_loc (input_location, MINUS_EXPR,
                             gfc_charlen_type_node, len,
                             build_int_cst (gfc_charlen_type_node, 1));
      tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);

      if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
        tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
      else
        tmp = build_array_type (TREE_TYPE (type), tmp);

      var = gfc_create_var (tmp, "str");
      var = gfc_build_addr_expr (type, var);
    }
  else
    {
      /* Allocate a temporary to hold the result.  */
      var = gfc_create_var (type, "pstr");
      tmp = gfc_call_malloc (&se->pre, type,
                             fold_build2_loc (input_location, MULT_EXPR,
                                              TREE_TYPE (len), len,
                                              fold_convert (TREE_TYPE (len),
                                                            TYPE_SIZE (type))));
      gfc_add_modify (&se->pre, var, tmp);

      /* Free the temporary afterwards.  */
      tmp = gfc_call_free (convert (pvoid_type_node, var));
      gfc_add_expr_to_block (&se->post, tmp);
    }

  return var;
}


/* Handle a string concatenation operation.  A temporary will be allocated to
   hold the result.  */

static void
gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
{
  gfc_se lse, rse;
  tree len, type, var, tmp, fndecl;

  gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
              && expr->value.op.op2->ts.type == BT_CHARACTER);
  gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);

  gfc_init_se (&lse, se);
  gfc_conv_expr (&lse, expr->value.op.op1);
  gfc_conv_string_parameter (&lse);
  gfc_init_se (&rse, se);
  gfc_conv_expr (&rse, expr->value.op.op2);
  gfc_conv_string_parameter (&rse);

  gfc_add_block_to_block (&se->pre, &lse.pre);
  gfc_add_block_to_block (&se->pre, &rse.pre);

  type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
  len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
  if (len == NULL_TREE)
    {
      len = fold_build2_loc (input_location, PLUS_EXPR,
                             TREE_TYPE (lse.string_length),
                             lse.string_length, rse.string_length);
    }

  type = build_pointer_type (type);

  var = gfc_conv_string_tmp (se, type, len);

  /* Do the actual concatenation.  */
  if (expr->ts.kind == 1)
    fndecl = gfor_fndecl_concat_string;
  else if (expr->ts.kind == 4)
    fndecl = gfor_fndecl_concat_string_char4;
  else
    gcc_unreachable ();

  tmp = build_call_expr_loc (input_location,
                         fndecl, 6, len, var, lse.string_length, lse.expr,
                         rse.string_length, rse.expr);
  gfc_add_expr_to_block (&se->pre, tmp);

  /* Add the cleanup for the operands.  */
  gfc_add_block_to_block (&se->pre, &rse.post);
  gfc_add_block_to_block (&se->pre, &lse.post);

  se->expr = var;
  se->string_length = len;
}

/* Translates an op expression. Common (binary) cases are handled by this
   function, others are passed on. Recursion is used in either case.
   We use the fact that (op1.ts == op2.ts) (except for the power
   operator **).
   Operators need no special handling for scalarized expressions as long as
   they call gfc_conv_simple_val to get their operands.
   Character strings get special handling.  */

static void
gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
{
  enum tree_code code;
  gfc_se lse;
  gfc_se rse;
  tree tmp, type;
  int lop;
  int checkstring;

  checkstring = 0;
  lop = 0;
  switch (expr->value.op.op)
    {
    case INTRINSIC_PARENTHESES:
      if ((expr->ts.type == BT_REAL
           || expr->ts.type == BT_COMPLEX)
          && gfc_option.flag_protect_parens)
        {
          gfc_conv_unary_op (PAREN_EXPR, se, expr);
          gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
          return;
        }

      /* Fallthrough.  */
    case INTRINSIC_UPLUS:
      gfc_conv_expr (se, expr->value.op.op1);
      return;

    case INTRINSIC_UMINUS:
      gfc_conv_unary_op (NEGATE_EXPR, se, expr);
      return;

    case INTRINSIC_NOT:
      gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
      return;

    case INTRINSIC_PLUS:
      code = PLUS_EXPR;
      break;

    case INTRINSIC_MINUS:
      code = MINUS_EXPR;
      break;

    case INTRINSIC_TIMES:
      code = MULT_EXPR;
      break;

    case INTRINSIC_DIVIDE:
      /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
         an integer, we must round towards zero, so we use a
         TRUNC_DIV_EXPR.  */
      if (expr->ts.type == BT_INTEGER)
        code = TRUNC_DIV_EXPR;
      else
        code = RDIV_EXPR;
      break;

    case INTRINSIC_POWER:
      gfc_conv_power_op (se, expr);
      return;

    case INTRINSIC_CONCAT:
      gfc_conv_concat_op (se, expr);
      return;

    case INTRINSIC_AND:
      code = TRUTH_ANDIF_EXPR;
      lop = 1;
      break;

    case INTRINSIC_OR:
      code = TRUTH_ORIF_EXPR;
      lop = 1;
      break;

      /* EQV and NEQV only work on logicals, but since we represent them
         as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE.  */
    case INTRINSIC_EQ:
    case INTRINSIC_EQ_OS:
    case INTRINSIC_EQV:
      code = EQ_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_NE:
    case INTRINSIC_NE_OS:
    case INTRINSIC_NEQV:
      code = NE_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_GT:
    case INTRINSIC_GT_OS:
      code = GT_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_GE:
    case INTRINSIC_GE_OS:
      code = GE_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_LT:
    case INTRINSIC_LT_OS:
      code = LT_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_LE:
    case INTRINSIC_LE_OS:
      code = LE_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_USER:
    case INTRINSIC_ASSIGN:
      /* These should be converted into function calls by the frontend.  */
      gcc_unreachable ();

    default:
      fatal_error ("Unknown intrinsic op");
      return;
    }

  /* The only exception to this is **, which is handled separately anyway.  */
  gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);

  if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
    checkstring = 0;

  /* lhs */
  gfc_init_se (&lse, se);
  gfc_conv_expr (&lse, expr->value.op.op1);
  gfc_add_block_to_block (&se->pre, &lse.pre);

  /* rhs */
  gfc_init_se (&rse, se);
  gfc_conv_expr (&rse, expr->value.op.op2);
  gfc_add_block_to_block (&se->pre, &rse.pre);

  if (checkstring)
    {
      gfc_conv_string_parameter (&lse);
      gfc_conv_string_parameter (&rse);

      lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
                                           rse.string_length, rse.expr,
                                           expr->value.op.op1->ts.kind,
                                           code);
      rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
      gfc_add_block_to_block (&lse.post, &rse.post);
    }

  type = gfc_typenode_for_spec (&expr->ts);

  if (lop)
    {
      /* The result of logical ops is always boolean_type_node.  */
      tmp = fold_build2_loc (input_location, code, boolean_type_node,
                             lse.expr, rse.expr);
      se->expr = convert (type, tmp);
    }
  else
    se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);

  /* Add the post blocks.  */
  gfc_add_block_to_block (&se->post, &rse.post);
  gfc_add_block_to_block (&se->post, &lse.post);
}

/* If a string's length is one, we convert it to a single character.  */

tree
gfc_string_to_single_character (tree len, tree str, int kind)
{

  if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
      || !POINTER_TYPE_P (TREE_TYPE (str)))
    return NULL_TREE;

  if (TREE_INT_CST_LOW (len) == 1)
    {
      str = fold_convert (gfc_get_pchar_type (kind), str);
      return build_fold_indirect_ref_loc (input_location, str);
    }

  if (kind == 1
      && TREE_CODE (str) == ADDR_EXPR
      && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
      && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
      && array_ref_low_bound (TREE_OPERAND (str, 0))
         == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
      && TREE_INT_CST_LOW (len) > 1
      && TREE_INT_CST_LOW (len)
         == (unsigned HOST_WIDE_INT)
            TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
    {
      tree ret = fold_convert (gfc_get_pchar_type (kind), str);
      ret = build_fold_indirect_ref_loc (input_location, ret);
      if (TREE_CODE (ret) == INTEGER_CST)
        {
          tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
          int i, length = TREE_STRING_LENGTH (string_cst);
          const char *ptr = TREE_STRING_POINTER (string_cst);

          for (i = 1; i < length; i++)
            if (ptr[i] != ' ')
              return NULL_TREE;

          return ret;
        }
    }

  return NULL_TREE;
}


void
gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
{

  if (sym->backend_decl)
    {
      /* This becomes the nominal_type in
         function.c:assign_parm_find_data_types.  */
      TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
      /* This becomes the passed_type in
         function.c:assign_parm_find_data_types.  C promotes char to
         integer for argument passing.  */
      DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;

      DECL_BY_REFERENCE (sym->backend_decl) = 0;
    }

  if (expr != NULL)
    {
      /* If we have a constant character expression, make it into an
         integer.  */
      if ((*expr)->expr_type == EXPR_CONSTANT)
        {
          gfc_typespec ts;
          gfc_clear_ts (&ts);

          *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
                                    (int)(*expr)->value.character.string[0]);
          if ((*expr)->ts.kind != gfc_c_int_kind)
            {
              /* The expr needs to be compatible with a C int.  If the 
                 conversion fails, then the 2 causes an ICE.  */
              ts.type = BT_INTEGER;
              ts.kind = gfc_c_int_kind;
              gfc_convert_type (*expr, &ts, 2);
            }
        }
      else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
        {
          if ((*expr)->ref == NULL)
            {
              se->expr = gfc_string_to_single_character
                (build_int_cst (integer_type_node, 1),
                 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
                                      gfc_get_symbol_decl
                                      ((*expr)->symtree->n.sym)),
                 (*expr)->ts.kind);
            }
          else
            {
              gfc_conv_variable (se, *expr);
              se->expr = gfc_string_to_single_character
                (build_int_cst (integer_type_node, 1),
                 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
                                      se->expr),
                 (*expr)->ts.kind);
            }
        }
    }
}

/* Helper function for gfc_build_compare_string.  Return LEN_TRIM value
   if STR is a string literal, otherwise return -1.  */

static int
gfc_optimize_len_trim (tree len, tree str, int kind)
{
  if (kind == 1
      && TREE_CODE (str) == ADDR_EXPR
      && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
      && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
      && array_ref_low_bound (TREE_OPERAND (str, 0))
         == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
      && TREE_INT_CST_LOW (len) >= 1
      && TREE_INT_CST_LOW (len)
         == (unsigned HOST_WIDE_INT)
            TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
    {
      tree folded = fold_convert (gfc_get_pchar_type (kind), str);
      folded = build_fold_indirect_ref_loc (input_location, folded);
      if (TREE_CODE (folded) == INTEGER_CST)
        {
          tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
          int length = TREE_STRING_LENGTH (string_cst);
          const char *ptr = TREE_STRING_POINTER (string_cst);

          for (; length > 0; length--)
            if (ptr[length - 1] != ' ')
              break;

          return length;
        }
    }
  return -1;
}

/* Compare two strings. If they are all single characters, the result is the
   subtraction of them. Otherwise, we build a library call.  */

tree
gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
                          enum tree_code code)
{
  tree sc1;
  tree sc2;
  tree fndecl;

  gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
  gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));

  sc1 = gfc_string_to_single_character (len1, str1, kind);
  sc2 = gfc_string_to_single_character (len2, str2, kind);

  if (sc1 != NULL_TREE && sc2 != NULL_TREE)
    {
      /* Deal with single character specially.  */
      sc1 = fold_convert (integer_type_node, sc1);
      sc2 = fold_convert (integer_type_node, sc2);
      return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
                              sc1, sc2);
    }

  if ((code == EQ_EXPR || code == NE_EXPR)
      && optimize
      && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
    {
      /* If one string is a string literal with LEN_TRIM longer
         than the length of the second string, the strings
         compare unequal.  */
      int len = gfc_optimize_len_trim (len1, str1, kind);
      if (len > 0 && compare_tree_int (len2, len) < 0)
        return integer_one_node;
      len = gfc_optimize_len_trim (len2, str2, kind);
      if (len > 0 && compare_tree_int (len1, len) < 0)
        return integer_one_node;
    }

  /* Build a call for the comparison.  */
  if (kind == 1)
    fndecl = gfor_fndecl_compare_string;
  else if (kind == 4)
    fndecl = gfor_fndecl_compare_string_char4;
  else
    gcc_unreachable ();

  return build_call_expr_loc (input_location, fndecl, 4,
                              len1, str1, len2, str2);
}


/* Return the backend_decl for a procedure pointer component.  */

static tree
get_proc_ptr_comp (gfc_expr *e)
{
  gfc_se comp_se;
  gfc_expr *e2;
  expr_t old_type;

  gfc_init_se (&comp_se, NULL);
  e2 = gfc_copy_expr (e);
  /* We have to restore the expr type later so that gfc_free_expr frees
     the exact same thing that was allocated.
     TODO: This is ugly.  */
  old_type = e2->expr_type;
  e2->expr_type = EXPR_VARIABLE;
  gfc_conv_expr (&comp_se, e2);
  e2->expr_type = old_type;
  gfc_free_expr (e2);
  return build_fold_addr_expr_loc (input_location, comp_se.expr);
}


/* Convert a typebound function reference from a class object.  */
static void
conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
{
  gfc_ref *ref;
  tree var;

  if (TREE_CODE (base_object) != VAR_DECL)
    {
      var = gfc_create_var (TREE_TYPE (base_object), NULL);
      gfc_add_modify (&se->pre, var, base_object);
    }
  se->expr = gfc_class_vptr_get (base_object);
  se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
  ref = expr->ref;
  while (ref && ref->next)
    ref = ref->next;
  gcc_assert (ref && ref->type == REF_COMPONENT);
  if (ref->u.c.sym->attr.extension)
    conv_parent_component_references (se, ref);
  gfc_conv_component_ref (se, ref);
  se->expr = build_fold_addr_expr_loc (input_location, se->expr);
}


static void
conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
{
  tree tmp;

  if (gfc_is_proc_ptr_comp (expr, NULL))
    tmp = get_proc_ptr_comp (expr);
  else if (sym->attr.dummy)
    {
      tmp = gfc_get_symbol_decl (sym);
      if (sym->attr.proc_pointer)
        tmp = build_fold_indirect_ref_loc (input_location,
                                       tmp);
      gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
              && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
    }
  else
    {
      if (!sym->backend_decl)
        sym->backend_decl = gfc_get_extern_function_decl (sym);

      tmp = sym->backend_decl;

      if (sym->attr.cray_pointee)
        {
          /* TODO - make the cray pointee a pointer to a procedure,
             assign the pointer to it and use it for the call.  This
             will do for now!  */
          tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
                         gfc_get_symbol_decl (sym->cp_pointer));
          tmp = gfc_evaluate_now (tmp, &se->pre);
        }

      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
        {
          gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
          tmp = gfc_build_addr_expr (NULL_TREE, tmp);
        }
    }
  se->expr = tmp;
}


/* Initialize MAPPING.  */

void
gfc_init_interface_mapping (gfc_interface_mapping * mapping)
{
  mapping->syms = NULL;
  mapping->charlens = NULL;
}


/* Free all memory held by MAPPING (but not MAPPING itself).  */

void
gfc_free_interface_mapping (gfc_interface_mapping * mapping)
{
  gfc_interface_sym_mapping *sym;
  gfc_interface_sym_mapping *nextsym;
  gfc_charlen *cl;
  gfc_charlen *nextcl;

  for (sym = mapping->syms; sym; sym = nextsym)
    {
      nextsym = sym->next;
      sym->new_sym->n.sym->formal = NULL;
      gfc_free_symbol (sym->new_sym->n.sym);
      gfc_free_expr (sym->expr);
      free (sym->new_sym);
      free (sym);
    }
  for (cl = mapping->charlens; cl; cl = nextcl)
    {
      nextcl = cl->next;
      gfc_free_expr (cl->length);
      free (cl);
    }
}


/* Return a copy of gfc_charlen CL.  Add the returned structure to
   MAPPING so that it will be freed by gfc_free_interface_mapping.  */

static gfc_charlen *
gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
                                   gfc_charlen * cl)
{
  gfc_charlen *new_charlen;

  new_charlen = gfc_get_charlen ();
  new_charlen->next = mapping->charlens;
  new_charlen->length = gfc_copy_expr (cl->length);

  mapping->charlens = new_charlen;
  return new_charlen;
}


/* A subroutine of gfc_add_interface_mapping.  Return a descriptorless
   array variable that can be used as the actual argument for dummy
   argument SYM.  Add any initialization code to BLOCK.  PACKED is as
   for gfc_get_nodesc_array_type and DATA points to the first element
   in the passed array.  */

static tree
gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
                                 gfc_packed packed, tree data)
{
  tree type;
  tree var;

  type = gfc_typenode_for_spec (&sym->ts);
  type = gfc_get_nodesc_array_type (type, sym->as, packed,
                                    !sym->attr.target && !sym->attr.pointer
                                    && !sym->attr.proc_pointer);

  var = gfc_create_var (type, "ifm");
  gfc_add_modify (block, var, fold_convert (type, data));

  return var;
}


/* A subroutine of gfc_add_interface_mapping.  Set the stride, upper bounds
   and offset of descriptorless array type TYPE given that it has the same
   size as DESC.  Add any set-up code to BLOCK.  */

static void
gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
{
  int n;
  tree dim;
  tree offset;
  tree tmp;

  offset = gfc_index_zero_node;
  for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
    {
      dim = gfc_rank_cst[n];
      GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
      if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
        {
          GFC_TYPE_ARRAY_LBOUND (type, n)
                = gfc_conv_descriptor_lbound_get (desc, dim);
          GFC_TYPE_ARRAY_UBOUND (type, n)
                = gfc_conv_descriptor_ubound_get (desc, dim);
        }
      else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
        {
          tmp = fold_build2_loc (input_location, MINUS_EXPR,
                                 gfc_array_index_type,
                                 gfc_conv_descriptor_ubound_get (desc, dim),
                                 gfc_conv_descriptor_lbound_get (desc, dim));
          tmp = fold_build2_loc (input_location, PLUS_EXPR,
                                 gfc_array_index_type,
                                 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
          tmp = gfc_evaluate_now (tmp, block);
          GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
        }
      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
                             GFC_TYPE_ARRAY_LBOUND (type, n),
                             GFC_TYPE_ARRAY_STRIDE (type, n));
      offset = fold_build2_loc (input_location, MINUS_EXPR,
                                gfc_array_index_type, offset, tmp);
    }
  offset = gfc_evaluate_now (offset, block);
  GFC_TYPE_ARRAY_OFFSET (type) = offset;
}


/* Extend MAPPING so that it maps dummy argument SYM to the value stored
   in SE.  The caller may still use se->expr and se->string_length after
   calling this function.  */

void
gfc_add_interface_mapping (gfc_interface_mapping * mapping,
                           gfc_symbol * sym, gfc_se * se,
                           gfc_expr *expr)
{
  gfc_interface_sym_mapping *sm;
  tree desc;
  tree tmp;
  tree value;
  gfc_symbol *new_sym;
  gfc_symtree *root;
  gfc_symtree *new_symtree;

  /* Create a new symbol to represent the actual argument.  */
  new_sym = gfc_new_symbol (sym->name, NULL);
  new_sym->ts = sym->ts;
  new_sym->as = gfc_copy_array_spec (sym->as);
  new_sym->attr.referenced = 1;
  new_sym->attr.dimension = sym->attr.dimension;
  new_sym->attr.contiguous = sym->attr.contiguous;
  new_sym->attr.codimension = sym->attr.codimension;
  new_sym->attr.pointer = sym->attr.pointer;
  new_sym->attr.allocatable = sym->attr.allocatable;
  new_sym->attr.flavor = sym->attr.flavor;
  new_sym->attr.function = sym->attr.function;

  /* Ensure that the interface is available and that
     descriptors are passed for array actual arguments.  */
  if (sym->attr.flavor == FL_PROCEDURE)
    {
      new_sym->formal = expr->symtree->n.sym->formal;
      new_sym->attr.always_explicit
            = expr->symtree->n.sym->attr.always_explicit;
    }

  /* Create a fake symtree for it.  */
  root = NULL;
  new_symtree = gfc_new_symtree (&root, sym->name);
  new_symtree->n.sym = new_sym;
  gcc_assert (new_symtree == root);

  /* Create a dummy->actual mapping.  */
  sm = XCNEW (gfc_interface_sym_mapping);
  sm->next = mapping->syms;
  sm->old = sym;
  sm->new_sym = new_symtree;
  sm->expr = gfc_copy_expr (expr);
  mapping->syms = sm;

  /* Stabilize the argument's value.  */
  if (!sym->attr.function && se)
    se->expr = gfc_evaluate_now (se->expr, &se->pre);

  if (sym->ts.type == BT_CHARACTER)
    {
      /* Create a copy of the dummy argument's length.  */
      new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
      sm->expr->ts.u.cl = new_sym->ts.u.cl;

      /* If the length is specified as "*", record the length that
         the caller is passing.  We should use the callee's length
         in all other cases.  */
      if (!new_sym->ts.u.cl->length && se)
        {
          se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
          new_sym->ts.u.cl->backend_decl = se->string_length;
        }
    }

  if (!se)
    return;

  /* Use the passed value as-is if the argument is a function.  */
  if (sym->attr.flavor == FL_PROCEDURE)
    value = se->expr;

  /* If the argument is either a string or a pointer to a string,
     convert it to a boundless character type.  */
  else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
    {
      tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
      tmp = build_pointer_type (tmp);
      if (sym->attr.pointer)
        value = build_fold_indirect_ref_loc (input_location,
                                         se->expr);
      else
        value = se->expr;
      value = fold_convert (tmp, value);
    }

  /* If the argument is a scalar, a pointer to an array or an allocatable,
     dereference it.  */
  else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
    value = build_fold_indirect_ref_loc (input_location,
                                     se->expr);
  
  /* For character(*), use the actual argument's descriptor.  */  
  else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
    value = build_fold_indirect_ref_loc (input_location,
                                     se->expr);

  /* If the argument is an array descriptor, use it to determine
     information about the actual argument's shape.  */
  else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
           && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
    {
      /* Get the actual argument's descriptor.  */
      desc = build_fold_indirect_ref_loc (input_location,
                                      se->expr);

      /* Create the replacement variable.  */
      tmp = gfc_conv_descriptor_data_get (desc);
      value = gfc_get_interface_mapping_array (&se->pre, sym,
                                               PACKED_NO, tmp);

      /* Use DESC to work out the upper bounds, strides and offset.  */
      gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
    }
  else
    /* Otherwise we have a packed array.  */
    value = gfc_get_interface_mapping_array (&se->pre, sym,
                                             PACKED_FULL, se->expr);

  new_sym->backend_decl = value;
}


/* Called once all dummy argument mappings have been added to MAPPING,
   but before the mapping is used to evaluate expressions.  Pre-evaluate
   the length of each argument, adding any initialization code to PRE and
   any finalization code to POST.  */

void
gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
                              stmtblock_t * pre, stmtblock_t * post)
{
  gfc_interface_sym_mapping *sym;
  gfc_expr *expr;
  gfc_se se;

  for (sym = mapping->syms; sym; sym = sym->next)
    if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
        && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
      {
        expr = sym->new_sym->n.sym->ts.u.cl->length;
        gfc_apply_interface_mapping_to_expr (mapping, expr);
        gfc_init_se (&se, NULL);
        gfc_conv_expr (&se, expr);
        se.expr = fold_convert (gfc_charlen_type_node, se.expr);
        se.expr = gfc_evaluate_now (se.expr, &se.pre);
        gfc_add_block_to_block (pre, &se.pre);
        gfc_add_block_to_block (post, &se.post);

        sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
      }
}


/* Like gfc_apply_interface_mapping_to_expr, but applied to
   constructor C.  */

static void
gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
                                     gfc_constructor_base base)
{
  gfc_constructor *c;
  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
    {
      gfc_apply_interface_mapping_to_expr (mapping, c->expr);
      if (c->iterator)
        {
          gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
          gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
          gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
        }
    }
}


/* Like gfc_apply_interface_mapping_to_expr, but applied to
   reference REF.  */

static void
gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
                                    gfc_ref * ref)
{
  int n;

  for (; ref; ref = ref->next)
    switch (ref->type)
      {
      case REF_ARRAY:
        for (n = 0; n < ref->u.ar.dimen; n++)
          {
            gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
            gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
            gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
          }
        gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
        break;

      case REF_COMPONENT:
        break;

      case REF_SUBSTRING:
        gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
        gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
        break;
      }
}


/* Convert intrinsic function calls into result expressions.  */

static bool
gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
{
  gfc_symbol *sym;
  gfc_expr *new_expr;
  gfc_expr *arg1;
  gfc_expr *arg2;
  int d, dup;

  arg1 = expr->value.function.actual->expr;
  if (expr->value.function.actual->next)
    arg2 = expr->value.function.actual->next->expr;
  else
    arg2 = NULL;

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

  if (sym->attr.dummy)
    return false;

  new_expr = NULL;

  switch (expr->value.function.isym->id)
    {
    case GFC_ISYM_LEN:
      /* TODO figure out why this condition is necessary.  */
      if (sym->attr.function
          && (arg1->ts.u.cl->length == NULL
              || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
                  && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
        return false;

      new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
      break;

    case GFC_ISYM_SIZE:
      if (!sym->as || sym->as->rank == 0)
        return false;

      if (arg2 && arg2->expr_type == EXPR_CONSTANT)
        {
          dup = mpz_get_si (arg2->value.integer);
          d = dup - 1;
        }
      else
        {
          dup = sym->as->rank;
          d = 0;
        }

      for (; d < dup; d++)
        {
          gfc_expr *tmp;

          if (!sym->as->upper[d] || !sym->as->lower[d])
            {
              gfc_free_expr (new_expr);
              return false;
            }

          tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
                                        gfc_get_int_expr (gfc_default_integer_kind,
                                                          NULL, 1));
          tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
          if (new_expr)
            new_expr = gfc_multiply (new_expr, tmp);
          else
            new_expr = tmp;
        }
      break;

    case GFC_ISYM_LBOUND:
    case GFC_ISYM_UBOUND:
        /* TODO These implementations of lbound and ubound do not limit if
           the size < 0, according to F95's 13.14.53 and 13.14.113.  */

      if (!sym->as || sym->as->rank == 0)
        return false;

      if (arg2 && arg2->expr_type == EXPR_CONSTANT)
        d = mpz_get_si (arg2->value.integer) - 1;
      else
        /* TODO: If the need arises, this could produce an array of
           ubound/lbounds.  */
        gcc_unreachable ();

      if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
        {
          if (sym->as->lower[d])
            new_expr = gfc_copy_expr (sym->as->lower[d]);
        }
      else
        {
          if (sym->as->upper[d])
            new_expr = gfc_copy_expr (sym->as->upper[d]);
        }
      break;

    default:
      break;
    }

  gfc_apply_interface_mapping_to_expr (mapping, new_expr);
  if (!new_expr)
    return false;

  gfc_replace_expr (expr, new_expr);
  return true;
}


static void
gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
                              gfc_interface_mapping * mapping)
{
  gfc_formal_arglist *f;
  gfc_actual_arglist *actual;

  actual = expr->value.function.actual;
  f = map_expr->symtree->n.sym->formal;

  for (; f && actual; f = f->next, actual = actual->next)
    {
      if (!actual->expr)
        continue;

      gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
    }

  if (map_expr->symtree->n.sym->attr.dimension)
    {
      int d;
      gfc_array_spec *as;

      as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);

      for (d = 0; d < as->rank; d++)
        {
          gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
          gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
        }

      expr->value.function.esym->as = as;
    }

  if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
    {
      expr->value.function.esym->ts.u.cl->length
        = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);

      gfc_apply_interface_mapping_to_expr (mapping,
                        expr->value.function.esym->ts.u.cl->length);
    }
}


/* EXPR is a copy of an expression that appeared in the interface
   associated with MAPPING.  Walk it recursively looking for references to
   dummy arguments that MAPPING maps to actual arguments.  Replace each such
   reference with a reference to the associated actual argument.  */

static void
gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
                                     gfc_expr * expr)
{
  gfc_interface_sym_mapping *sym;
  gfc_actual_arglist *actual;

  if (!expr)
    return;

  /* Copying an expression does not copy its length, so do that here.  */
  if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
    {
      expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
      gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
    }

  /* Apply the mapping to any references.  */
  gfc_apply_interface_mapping_to_ref (mapping, expr->ref);

  /* ...and to the expression's symbol, if it has one.  */
  /* TODO Find out why the condition on expr->symtree had to be moved into
     the loop rather than being outside it, as originally.  */
  for (sym = mapping->syms; sym; sym = sym->next)
    if (expr->symtree && sym->old == expr->symtree->n.sym)
      {
        if (sym->new_sym->n.sym->backend_decl)
          expr->symtree = sym->new_sym;
        else if (sym->expr)
          gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
        /* Replace base type for polymorphic arguments.  */
        if (expr->ref && expr->ref->type == REF_COMPONENT
            && sym->expr && sym->expr->ts.type == BT_CLASS)
          expr->ref->u.c.sym = sym->expr->ts.u.derived;
      }

      /* ...and to subexpressions in expr->value.  */
  switch (expr->expr_type)
    {
    case EXPR_VARIABLE:
    case EXPR_CONSTANT:
    case EXPR_NULL:
    case EXPR_SUBSTRING:
      break;

    case EXPR_OP:
      gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
      gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
      break;

    case EXPR_FUNCTION:
      for (actual = expr->value.function.actual; actual; actual = actual->next)
        gfc_apply_interface_mapping_to_expr (mapping, actual->expr);

      if (expr->value.function.esym == NULL
            && expr->value.function.isym != NULL
            && expr->value.function.actual->expr->symtree
            && gfc_map_intrinsic_function (expr, mapping))
        break;

      for (sym = mapping->syms; sym; sym = sym->next)
        if (sym->old == expr->value.function.esym)
          {
            expr->value.function.esym = sym->new_sym->n.sym;
            gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
            expr->value.function.esym->result = sym->new_sym->n.sym;
          }
      break;

    case EXPR_ARRAY:
    case EXPR_STRUCTURE:
      gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
      break;

    case EXPR_COMPCALL:
    case EXPR_PPC:
      gcc_unreachable ();
      break;
    }

  return;
}


/* Evaluate interface expression EXPR using MAPPING.  Store the result
   in SE.  */

void
gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
                             gfc_se * se, gfc_expr * expr)
{
  expr = gfc_copy_expr (expr);
  gfc_apply_interface_mapping_to_expr (mapping, expr);
  gfc_conv_expr (se, expr);
  se->expr = gfc_evaluate_now (se->expr, &se->pre);
  gfc_free_expr (expr);
}


/* Returns a reference to a temporary array into which a component of
   an actual argument derived type array is copied and then returned
   after the function call.  */
void
gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
                           sym_intent intent, bool formal_ptr)
{
  gfc_se lse;
  gfc_se rse;
  gfc_ss *lss;
  gfc_ss *rss;
  gfc_loopinfo loop;
  gfc_loopinfo loop2;
  gfc_array_info *info;
  tree offset;
  tree tmp_index;
  tree tmp;
  tree base_type;
  tree size;
  stmtblock_t body;
  int n;
  int dimen;

  gcc_assert (expr->expr_type == EXPR_VARIABLE);

  gfc_init_se (&lse, NULL);
  gfc_init_se (&rse, NULL);

  /* Walk the argument expression.  */
  rss = gfc_walk_expr (expr);

  gcc_assert (rss != gfc_ss_terminator);
 
  /* Initialize the scalarizer.  */
  gfc_init_loopinfo (&loop);
  gfc_add_ss_to_loop (&loop, rss);

  /* Calculate the bounds of the scalarization.  */
  gfc_conv_ss_startstride (&loop);

  /* Build an ss for the temporary.  */
  if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
    gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);

  base_type = gfc_typenode_for_spec (&expr->ts);
  if (GFC_ARRAY_TYPE_P (base_type)
                || GFC_DESCRIPTOR_TYPE_P (base_type))
    base_type = gfc_get_element_type (base_type);

  if (expr->ts.type == BT_CLASS)
    base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);

  loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
                                              ? expr->ts.u.cl->backend_decl
                                              : NULL),
                                  loop.dimen);

  parmse->string_length = loop.temp_ss->info->string_length;

  /* Associate the SS with the loop.  */
  gfc_add_ss_to_loop (&loop, loop.temp_ss);

  /* Setup the scalarizing loops.  */
  gfc_conv_loop_setup (&loop, &expr->where);

  /* Pass the temporary descriptor back to the caller.  */
  info = &loop.temp_ss->info->data.array;
  parmse->expr = info->descriptor;

  /* Setup the gfc_se structures.  */
  gfc_copy_loopinfo_to_se (&lse, &loop);
  gfc_copy_loopinfo_to_se (&rse, &loop);

  rse.ss = rss;
  lse.ss = loop.temp_ss;
  gfc_mark_ss_chain_used (rss, 1);
  gfc_mark_ss_chain_used (loop.temp_ss, 1);

  /* Start the scalarized loop body.  */
  gfc_start_scalarized_body (&loop, &body);

  /* Translate the expression.  */
  gfc_conv_expr (&rse, expr);

  gfc_conv_tmp_array_ref (&lse);

  if (intent != INTENT_OUT)
    {
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
      gfc_add_expr_to_block (&body, tmp);
      gcc_assert (rse.ss == gfc_ss_terminator);
      gfc_trans_scalarizing_loops (&loop, &body);
    }
  else
    {
      /* Make sure that the temporary declaration survives by merging
       all the loop declarations into the current context.  */
      for (n = 0; n < loop.dimen; n++)
        {
          gfc_merge_block_scope (&body);
          body = loop.code[loop.order[n]];
        }
      gfc_merge_block_scope (&body);
    }

  /* Add the post block after the second loop, so that any
     freeing of allocated memory is done at the right time.  */
  gfc_add_block_to_block (&parmse->pre, &loop.pre);

  /**********Copy the temporary back again.*********/

  gfc_init_se (&lse, NULL);
  gfc_init_se (&rse, NULL);

  /* Walk the argument expression.  */
  lss = gfc_walk_expr (expr);
  rse.ss = loop.temp_ss;
  lse.ss = lss;

  /* Initialize the scalarizer.  */
  gfc_init_loopinfo (&loop2);
  gfc_add_ss_to_loop (&loop2, lss);

  /* Calculate the bounds of the scalarization.  */
  gfc_conv_ss_startstride (&loop2);

  /* Setup the scalarizing loops.  */
  gfc_conv_loop_setup (&loop2, &expr->where);

  gfc_copy_loopinfo_to_se (&lse, &loop2);
  gfc_copy_loopinfo_to_se (&rse, &loop2);

  gfc_mark_ss_chain_used (lss, 1);
  gfc_mark_ss_chain_used (loop.temp_ss, 1);

  /* Declare the variable to hold the temporary offset and start the
     scalarized loop body.  */
  offset = gfc_create_var (gfc_array_index_type, NULL);
  gfc_start_scalarized_body (&loop2, &body);

  /* Build the offsets for the temporary from the loop variables.  The
     temporary array has lbounds of zero and strides of one in all
     dimensions, so this is very simple.  The offset is only computed
     outside the innermost loop, so the overall transfer could be
     optimized further.  */
  info = &rse.ss->info->data.array;
  dimen = rse.ss->dimen;

  tmp_index = gfc_index_zero_node;
  for (n = dimen - 1; n > 0; n--)
    {
      tree tmp_str;
      tmp = rse.loop->loopvar[n];
      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
                             tmp, rse.loop->from[n]);
      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
                             tmp, tmp_index);

      tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
                                 gfc_array_index_type,
                                 rse.loop->to[n-1], rse.loop->from[n-1]);
      tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
                                 gfc_array_index_type,
                                 tmp_str, gfc_index_one_node);

      tmp_index = fold_build2_loc (input_location, MULT_EXPR,
                                   gfc_array_index_type, tmp, tmp_str);
    }

  tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
                               gfc_array_index_type,
                               tmp_index, rse.loop->from[0]);
  gfc_add_modify (&rse.loop->code[0], offset, tmp_index);

  tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
                               gfc_array_index_type,
                               rse.loop->loopvar[0], offset);

  /* Now use the offset for the reference.  */
  tmp = build_fold_indirect_ref_loc (input_location,
                                 info->data);
  rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);

  if (expr->ts.type == BT_CHARACTER)
    rse.string_length = expr->ts.u.cl->backend_decl;

  gfc_conv_expr (&lse, expr);

  gcc_assert (lse.ss == gfc_ss_terminator);

  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
  gfc_add_expr_to_block (&body, tmp);
  
  /* Generate the copying loops.  */
  gfc_trans_scalarizing_loops (&loop2, &body);

  /* Wrap the whole thing up by adding the second loop to the post-block
     and following it by the post-block of the first loop.  In this way,
     if the temporary needs freeing, it is done after use!  */
  if (intent != INTENT_IN)
    {
      gfc_add_block_to_block (&parmse->post, &loop2.pre);
      gfc_add_block_to_block (&parmse->post, &loop2.post);
    }

  gfc_add_block_to_block (&parmse->post, &loop.post);

  gfc_cleanup_loop (&loop);
  gfc_cleanup_loop (&loop2);

  /* Pass the string length to the argument expression.  */
  if (expr->ts.type == BT_CHARACTER)
    parmse->string_length = expr->ts.u.cl->backend_decl;

  /* Determine the offset for pointer formal arguments and set the
     lbounds to one.  */
  if (formal_ptr)
    {
      size = gfc_index_one_node;
      offset = gfc_index_zero_node;  
      for (n = 0; n < dimen; n++)
        {
          tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
                                                gfc_rank_cst[n]);
          tmp = fold_build2_loc (input_location, PLUS_EXPR,
                                 gfc_array_index_type, tmp,
                                 gfc_index_one_node);
          gfc_conv_descriptor_ubound_set (&parmse->pre,
                                          parmse->expr,
                                          gfc_rank_cst[n],
                                          tmp);
          gfc_conv_descriptor_lbound_set (&parmse->pre,
                                          parmse->expr,
                                          gfc_rank_cst[n],
                                          gfc_index_one_node);
          size = gfc_evaluate_now (size, &parmse->pre);
          offset = fold_build2_loc (input_location, MINUS_EXPR,
                                    gfc_array_index_type,
                                    offset, size);
          offset = gfc_evaluate_now (offset, &parmse->pre);
          tmp = fold_build2_loc (input_location, MINUS_EXPR,
                                 gfc_array_index_type,
                                 rse.loop->to[n], rse.loop->from[n]);
          tmp = fold_build2_loc (input_location, PLUS_EXPR,
                                 gfc_array_index_type,
                                 tmp, gfc_index_one_node);
          size = fold_build2_loc (input_location, MULT_EXPR,
                                  gfc_array_index_type, size, tmp);
        }

      gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
                                      offset);
    }

  /* We want either the address for the data or the address of the descriptor,
     depending on the mode of passing array arguments.  */
  if (g77)
    parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
  else
    parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);

  return;
}


/* Generate the code for argument list functions.  */

static void
conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
{
  /* Pass by value for g77 %VAL(arg), pass the address
     indirectly for %LOC, else by reference.  Thus %REF
     is a "do-nothing" and %LOC is the same as an F95
     pointer.  */
  if (strncmp (name, "%VAL", 4) == 0)
    gfc_conv_expr (se, expr);
  else if (strncmp (name, "%LOC", 4) == 0)
    {
      gfc_conv_expr_reference (se, expr);
      se->expr = gfc_build_addr_expr (NULL, se->expr);
    }
  else if (strncmp (name, "%REF", 4) == 0)
    gfc_conv_expr_reference (se, expr);
  else
    gfc_error ("Unknown argument list function at %L", &expr->where);
}


/* The following routine generates code for the intrinsic
   procedures from the ISO_C_BINDING module:
    * C_LOC           (function)
    * C_FUNLOC        (function)
    * C_F_POINTER     (subroutine)
    * C_F_PROCPOINTER (subroutine)
    * C_ASSOCIATED    (function)
   One exception which is not handled here is C_F_POINTER with non-scalar
   arguments. Returns 1 if the call was replaced by inline code (else: 0).  */

static int
conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
                            gfc_actual_arglist * arg)
{
  gfc_symbol *fsym;
  gfc_ss *argss;
    
  if (sym->intmod_sym_id == ISOCBINDING_LOC)
    {
      if (arg->expr->rank == 0)
        gfc_conv_expr_reference (se, arg->expr);
      else
        {
          int f;
          /* This is really the actual arg because no formal arglist is
             created for C_LOC.  */
          fsym = arg->expr->symtree->n.sym;

          /* We should want it to do g77 calling convention.  */
          f = (fsym != NULL)
            && !(fsym->attr.pointer || fsym->attr.allocatable)
            && fsym->as->type != AS_ASSUMED_SHAPE;
          f = f || !sym->attr.always_explicit;
      
          argss = gfc_walk_expr (arg->expr);
          gfc_conv_array_parameter (se, arg->expr, argss, f,
                                    NULL, NULL, NULL);
        }

      /* TODO -- the following two lines shouldn't be necessary, but if
         they're removed, a bug is exposed later in the code path.
         This workaround was thus introduced, but will have to be
         removed; please see PR 35150 for details about the issue.  */
      se->expr = convert (pvoid_type_node, se->expr);
      se->expr = gfc_evaluate_now (se->expr, &se->pre);

      return 1;
    }
  else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
    {
      arg->expr->ts.type = sym->ts.u.derived->ts.type;
      arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
      arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
      gfc_conv_expr_reference (se, arg->expr);
  
      return 1;
    }
  else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
            && arg->next->expr->rank == 0)
           || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
    {
      /* Convert c_f_pointer if fptr is a scalar
         and convert c_f_procpointer.  */
      gfc_se cptrse;
      gfc_se fptrse;

      gfc_init_se (&cptrse, NULL);
      gfc_conv_expr (&cptrse, arg->expr);
      gfc_add_block_to_block (&se->pre, &cptrse.pre);
      gfc_add_block_to_block (&se->post, &cptrse.post);

      gfc_init_se (&fptrse, NULL);
      if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
          || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
        fptrse.want_pointer = 1;

      gfc_conv_expr (&fptrse, arg->next->expr);
      gfc_add_block_to_block (&se->pre, &fptrse.pre);
      gfc_add_block_to_block (&se->post, &fptrse.post);
      
      if (arg->next->expr->symtree->n.sym->attr.proc_pointer
          && arg->next->expr->symtree->n.sym->attr.dummy)
        fptrse.expr = build_fold_indirect_ref_loc (input_location,
                                                   fptrse.expr);
      
      se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
                                  TREE_TYPE (fptrse.expr),
                                  fptrse.expr,
                                  fold_convert (TREE_TYPE (fptrse.expr),
                                                cptrse.expr));

      return 1;
    }
  else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
    {
      gfc_se arg1se;
      gfc_se arg2se;

      /* Build the addr_expr for the first argument.  The argument is
         already an *address* so we don't need to set want_pointer in
         the gfc_se.  */
      gfc_init_se (&arg1se, NULL);
      gfc_conv_expr (&arg1se, arg->expr);
      gfc_add_block_to_block (&se->pre, &arg1se.pre);
      gfc_add_block_to_block (&se->post, &arg1se.post);

      /* See if we were given two arguments.  */
      if (arg->next == NULL)
        /* Only given one arg so generate a null and do a
           not-equal comparison against the first arg.  */
        se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
                                    arg1se.expr,
                                    fold_convert (TREE_TYPE (arg1se.expr),
                                                  null_pointer_node));
      else
        {
          tree eq_expr;
          tree not_null_expr;
          
          /* Given two arguments so build the arg2se from second arg.  */
          gfc_init_se (&arg2se, NULL);
          gfc_conv_expr (&arg2se, arg->next->expr);
          gfc_add_block_to_block (&se->pre, &arg2se.pre);
          gfc_add_block_to_block (&se->post, &arg2se.post);

          /* Generate test to compare that the two args are equal.  */
          eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
                                     arg1se.expr, arg2se.expr);
          /* Generate test to ensure that the first arg is not null.  */
          not_null_expr = fold_build2_loc (input_location, NE_EXPR,
                                           boolean_type_node,
                                           arg1se.expr, null_pointer_node);

          /* Finally, the generated test must check that both arg1 is not
             NULL and that it is equal to the second arg.  */
          se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
                                      boolean_type_node,
                                      not_null_expr, eq_expr);
        }

      return 1;
    }
    
  /* Nothing was done.  */
  return 0;
}


/* Generate code for a procedure call.  Note can return se->post != NULL.
   If se->direct_byref is set then se->expr contains the return parameter.
   Return nonzero, if the call has alternate specifiers.
   'expr' is only needed for procedure pointer components.  */

int
gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                         gfc_actual_arglist * args, gfc_expr * expr,
                         VEC(tree,gc) *append_args)
{
  gfc_interface_mapping mapping;
  VEC(tree,gc) *arglist;
  VEC(tree,gc) *retargs;
  tree tmp;
  tree fntype;
  gfc_se parmse;
  gfc_ss *argss;
  gfc_array_info *info;
  int byref;
  int parm_kind;
  tree type;
  tree var;
  tree len;
  tree base_object;
  VEC(tree,gc) *stringargs;
  tree result = NULL;
  gfc_formal_arglist *formal;
  gfc_actual_arglist *arg;
  int has_alternate_specifier = 0;
  bool need_interface_mapping;
  bool callee_alloc;
  gfc_typespec ts;
  gfc_charlen cl;
  gfc_expr *e;
  gfc_symbol *fsym;
  stmtblock_t post;
  enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
  gfc_component *comp = NULL;
  int arglen;

  arglist = NULL;
  retargs = NULL;
  stringargs = NULL;
  var = NULL_TREE;
  len = NULL_TREE;
  gfc_clear_ts (&ts);

  if (sym->from_intmod == INTMOD_ISO_C_BINDING
      && conv_isocbinding_procedure (se, sym, args))
    return 0;

  gfc_is_proc_ptr_comp (expr, &comp);

  if (se->ss != NULL)
    {
      if (!sym->attr.elemental && !(comp && comp->attr.elemental))
        {
          gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
          if (se->ss->info->useflags)
            {
              gcc_assert ((!comp && gfc_return_by_reference (sym)
                           && sym->result->attr.dimension)
                          || (comp && comp->attr.dimension));
              gcc_assert (se->loop != NULL);

              /* Access the previously obtained result.  */
              gfc_conv_tmp_array_ref (se);
              return 0;
            }
        }
      info = &se->ss->info->data.array;
    }
  else
    info = NULL;

  gfc_init_block (&post);
  gfc_init_interface_mapping (&mapping);
  if (!comp)
    {
      formal = sym->formal;
      need_interface_mapping = sym->attr.dimension ||
                               (sym->ts.type == BT_CHARACTER
                                && sym->ts.u.cl->length
                                && sym->ts.u.cl->length->expr_type
                                   != EXPR_CONSTANT);
    }
  else
    {
      formal = comp->formal;
      need_interface_mapping = comp->attr.dimension ||
                               (comp->ts.type == BT_CHARACTER
                                && comp->ts.u.cl->length
                                && comp->ts.u.cl->length->expr_type
                                   != EXPR_CONSTANT);
    }

  base_object = NULL_TREE;

  /* Evaluate the arguments.  */
  for (arg = args; arg != NULL;
       arg = arg->next, formal = formal ? formal->next : NULL)
    {
      e = arg->expr;
      fsym = formal ? formal->sym : NULL;
      parm_kind = MISSING;

      /* Class array expressions are sometimes coming completely unadorned
         with either arrayspec or _data component.  Correct that here.
         OOP-TODO: Move this to the frontend.  */
      if (e && e->expr_type == EXPR_VARIABLE
            && !e->ref
            && e->ts.type == BT_CLASS
            && CLASS_DATA (e)->attr.dimension)
        {
          gfc_typespec temp_ts = e->ts;
          gfc_add_class_array_ref (e);
          e->ts = temp_ts;
        }

      if (e == NULL)
        {
          if (se->ignore_optional)
            {
              /* Some intrinsics have already been resolved to the correct
                 parameters.  */
              continue;
            }
          else if (arg->label)
            {
              has_alternate_specifier = 1;
              continue;
            }
          else
            {
              /* Pass a NULL pointer for an absent arg.  */
              gfc_init_se (&parmse, NULL);
              parmse.expr = null_pointer_node;
              if (arg->missing_arg_type == BT_CHARACTER)
                parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
            }
        }
      else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
        {
          /* Pass a NULL pointer to denote an absent arg.  */
          gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
          gfc_init_se (&parmse, NULL);
          parmse.expr = null_pointer_node;
          if (arg->missing_arg_type == BT_CHARACTER)
            parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
        }
      else if (fsym && fsym->ts.type == BT_CLASS
                 && e->ts.type == BT_DERIVED)
        {
          /* The derived type needs to be converted to a temporary
             CLASS object.  */
          gfc_init_se (&parmse, se);
          gfc_conv_derived_to_class (&parmse, e, fsym->ts);
        }
      else if (se->ss && se->ss->info->useflags)
        {
          /* An elemental function inside a scalarized loop.  */
          gfc_init_se (&parmse, se);
          parm_kind = ELEMENTAL;

          if (se->ss->dimen > 0
              && se->ss->info->data.array.ref == NULL)
            {
              gfc_conv_tmp_array_ref (&parmse);
              if (e->ts.type == BT_CHARACTER)
                gfc_conv_string_parameter (&parmse);
              else
                parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
            }
          else
            gfc_conv_expr_reference (&parmse, e);

          /* The scalarizer does not repackage the reference to a class
             array - instead it returns a pointer to the data element.  */
          if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
            gfc_conv_class_to_class (&parmse, e, fsym->ts, true);
        }
      else
        {
          /* A scalar or transformational function.  */
          gfc_init_se (&parmse, NULL);
          argss = gfc_walk_expr (e);

          if (argss == gfc_ss_terminator)
            {
              if (e->expr_type == EXPR_VARIABLE
                    && e->symtree->n.sym->attr.cray_pointee
                    && fsym && fsym->attr.flavor == FL_PROCEDURE)
                {
                    /* The Cray pointer needs to be converted to a pointer to
                       a type given by the expression.  */
                    gfc_conv_expr (&parmse, e);
                    type = build_pointer_type (TREE_TYPE (parmse.expr));
                    tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
                    parmse.expr = convert (type, tmp);
                }
              else if (fsym && fsym->attr.value)
                {
                  if (fsym->ts.type == BT_CHARACTER
                      && fsym->ts.is_c_interop
                      && fsym->ns->proc_name != NULL
                      && fsym->ns->proc_name->attr.is_bind_c)
                    {
                      parmse.expr = NULL;
                      gfc_conv_scalar_char_value (fsym, &parmse, &e);
                      if (parmse.expr == NULL)
                        gfc_conv_expr (&parmse, e);
                    }
                  else
                    gfc_conv_expr (&parmse, e);
                }
              else if (arg->name && arg->name[0] == '%')
                /* Argument list functions %VAL, %LOC and %REF are signalled
                   through arg->name.  */
                conv_arglist_function (&parmse, arg->expr, arg->name);
              else if ((e->expr_type == EXPR_FUNCTION)
                        && ((e->value.function.esym
                             && e->value.function.esym->result->attr.pointer)
                            || (!e->value.function.esym
                                && e->symtree->n.sym->attr.pointer))
                        && fsym && fsym->attr.target)
                {
                  gfc_conv_expr (&parmse, e);
                  parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
                }
              else if (e->expr_type == EXPR_FUNCTION
                       && e->symtree->n.sym->result
                       && e->symtree->n.sym->result != e->symtree->n.sym
                       && e->symtree->n.sym->result->attr.proc_pointer)
                {
                  /* Functions returning procedure pointers.  */
                  gfc_conv_expr (&parmse, e);
                  if (fsym && fsym->attr.proc_pointer)
                    parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
                }
              else
                {
                  gfc_conv_expr_reference (&parmse, e);

                  /* Catch base objects that are not variables.  */
                  if (e->ts.type == BT_CLASS
                        && e->expr_type != EXPR_VARIABLE
                        && expr && e == expr->base_expr)
                    base_object = build_fold_indirect_ref_loc (input_location,
                                                               parmse.expr);

                  /* A class array element needs converting back to be a
                     class object, if the formal argument is a class object.  */
                  if (fsym && fsym->ts.type == BT_CLASS
                        && e->ts.type == BT_CLASS
                        && CLASS_DATA (e)->attr.dimension)
                    gfc_conv_class_to_class (&parmse, e, fsym->ts, false);

                  /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
                     allocated on entry, it must be deallocated.  */
                  if (fsym && fsym->attr.allocatable
                      && fsym->attr.intent == INTENT_OUT)
                    {
                      stmtblock_t block;

                      gfc_init_block  (&block);
                      tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
                                                        NULL_TREE, NULL_TREE,
                                                        NULL_TREE, true, NULL,
                                                        false);
                      gfc_add_expr_to_block (&block, tmp);
                      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
                                             void_type_node, parmse.expr,
                                             null_pointer_node);
                      gfc_add_expr_to_block (&block, tmp);

                      if (fsym->attr.optional
                          && e->expr_type == EXPR_VARIABLE
                          && e->symtree->n.sym->attr.optional)
                        {
                          tmp = fold_build3_loc (input_location, COND_EXPR,
                                     void_type_node,
                                     gfc_conv_expr_present (e->symtree->n.sym),
                                            gfc_finish_block (&block),
                                            build_empty_stmt (input_location));
                        }
                      else
                        tmp = gfc_finish_block (&block);

                      gfc_add_expr_to_block (&se->pre, tmp);
                    }

                  if (fsym && e->expr_type != EXPR_NULL
                      && ((fsym->attr.pointer
                           && fsym->attr.flavor != FL_PROCEDURE)
                          || (fsym->attr.proc_pointer
                              && !(e->expr_type == EXPR_VARIABLE
                                   && e->symtree->n.sym->attr.dummy))
                          || (fsym->attr.proc_pointer
                              && e->expr_type == EXPR_VARIABLE
                              && gfc_is_proc_ptr_comp (e, NULL))
                          || fsym->attr.allocatable))
                    {
                      /* Scalar pointer dummy args require an extra level of
                         indirection. The null pointer already contains
                         this level of indirection.  */
                      parm_kind = SCALAR_POINTER;
                      parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
                    }
                }
            }
          else if (e->ts.type == BT_CLASS
                    && fsym && fsym->ts.type == BT_CLASS
                    && CLASS_DATA (fsym)->attr.dimension)
            {
              /* Pass a class array.  */
              gfc_init_se (&parmse, se);
              gfc_conv_expr_descriptor (&parmse, e, argss);
              /* The conversion does not repackage the reference to a class
                 array - _data descriptor.  */
              gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
            }
          else
            {
              /* If the procedure requires an explicit interface, the actual
                 argument is passed according to the corresponding formal
                 argument.  If the corresponding formal argument is a POINTER,
                 ALLOCATABLE or assumed shape, we do not use g77's calling
                 convention, and pass the address of the array descriptor
                 instead. Otherwise we use g77's calling convention.  */
              bool f;
              f = (fsym != NULL)
                  && !(fsym->attr.pointer || fsym->attr.allocatable)
                  && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
              if (comp)
                f = f || !comp->attr.always_explicit;
              else
                f = f || !sym->attr.always_explicit;

              /* If the argument is a function call that may not create
                 a temporary for the result, we have to check that we
                 can do it, i.e. that there is no alias between this 
                 argument and another one.  */
              if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
                {
                  gfc_expr *iarg;
                  sym_intent intent;

                  if (fsym != NULL)
                    intent = fsym->attr.intent;
                  else
                    intent = INTENT_UNKNOWN;

                  if (gfc_check_fncall_dependency (e, intent, sym, args,
                                                   NOT_ELEMENTAL))
                    parmse.force_tmp = 1;

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

                  /* Temporary needed if aliasing due to host association.  */
                  if (sym->attr.contained
                        && !sym->attr.pure
                        && !sym->attr.implicit_pure
                        && !sym->attr.use_assoc
                        && iarg->expr_type == EXPR_VARIABLE
                        && sym->ns == iarg->symtree->n.sym->ns)
                    parmse.force_tmp = 1;

                  /* Ditto within module.  */
                  if (sym->attr.use_assoc
                        && !sym->attr.pure
                        && !sym->attr.implicit_pure
                        && iarg->expr_type == EXPR_VARIABLE
                        && sym->module == iarg->symtree->n.sym->module)
                    parmse.force_tmp = 1;
                }

              if (e->expr_type == EXPR_VARIABLE
                    && is_subref_array (e))
                /* The actual argument is a component reference to an
                   array of derived types.  In this case, the argument
                   is converted to a temporary, which is passed and then
                   written back after the procedure call.  */
                gfc_conv_subref_array_arg (&parmse, e, f,
                                fsym ? fsym->attr.intent : INTENT_INOUT,
                                fsym && fsym->attr.pointer);
              else if (gfc_is_class_array_ref (e, NULL)
                         && fsym && fsym->ts.type == BT_DERIVED)
                /* The actual argument is a component reference to an
                   array of derived types.  In this case, the argument
                   is converted to a temporary, which is passed and then
                   written back after the procedure call.
                   OOP-TODO: Insert code so that if the dynamic type is
                   the same as the declared type, copy-in/copy-out does
                   not occur.  */
                gfc_conv_subref_array_arg (&parmse, e, f,
                                fsym ? fsym->attr.intent : INTENT_INOUT,
                                fsym && fsym->attr.pointer);
              else
                gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
                                          sym->name, NULL);

              /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
                 allocated on entry, it must be deallocated.  */
              if (fsym && fsym->attr.allocatable
                  && fsym->attr.intent == INTENT_OUT)
                {
                  tmp = build_fold_indirect_ref_loc (input_location,
                                                     parmse.expr);
                  tmp = gfc_trans_dealloc_allocated (tmp, false);
                  if (fsym->attr.optional
                      && e->expr_type == EXPR_VARIABLE
                      && e->symtree->n.sym->attr.optional)
                    tmp = fold_build3_loc (input_location, COND_EXPR,
                                     void_type_node,
                                     gfc_conv_expr_present (e->symtree->n.sym),
                                       tmp, build_empty_stmt (input_location));
                  gfc_add_expr_to_block (&se->pre, tmp);
                }
            } 
        }

      /* The case with fsym->attr.optional is that of a user subroutine
         with an interface indicating an optional argument.  When we call
         an intrinsic subroutine, however, fsym is NULL, but we might still
         have an optional argument, so we proceed to the substitution
         just in case.  */
      if (e && (fsym == NULL || fsym->attr.optional))
        {
          /* If an optional argument is itself an optional dummy argument,
             check its presence and substitute a null if absent.  This is
             only needed when passing an array to an elemental procedure
             as then array elements are accessed - or no NULL pointer is
             allowed and a "1" or "0" should be passed if not present.
             When passing a non-array-descriptor full array to a
             non-array-descriptor dummy, no check is needed. For
             array-descriptor actual to array-descriptor dummy, see
             PR 41911 for why a check has to be inserted.
             fsym == NULL is checked as intrinsics required the descriptor
             but do not always set fsym.  */
          if (e->expr_type == EXPR_VARIABLE
              && e->symtree->n.sym->attr.optional
              && ((e->rank > 0 && sym->attr.elemental)
                  || e->representation.length || e->ts.type == BT_CHARACTER
                  || (e->rank > 0
                      && (fsym == NULL 
                          || (fsym-> as
                              && (fsym->as->type == AS_ASSUMED_SHAPE
                                  || fsym->as->type == AS_DEFERRED))))))
            gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
                                    e->representation.length);
        }

      if (fsym && e)
        {
          /* Obtain the character length of an assumed character length
             length procedure from the typespec.  */
          if (fsym->ts.type == BT_CHARACTER
              && parmse.string_length == NULL_TREE
              && e->ts.type == BT_PROCEDURE
              && e->symtree->n.sym->ts.type == BT_CHARACTER
              && e->symtree->n.sym->ts.u.cl->length != NULL
              && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
            {
              gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
              parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
            }
        }

      if (fsym && need_interface_mapping && e)
        gfc_add_interface_mapping (&mapping, fsym, &parmse, e);

      gfc_add_block_to_block (&se->pre, &parmse.pre);
      gfc_add_block_to_block (&post, &parmse.post);

      /* Allocated allocatable components of derived types must be
         deallocated for non-variable scalars.  Non-variable arrays are
         dealt with in trans-array.c(gfc_conv_array_parameter).  */
      if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
            && e->ts.u.derived->attr.alloc_comp
            && !(e->symtree && e->symtree->n.sym->attr.pointer)
            && (e->expr_type != EXPR_VARIABLE && !e->rank))
        {
          int parm_rank;
          tmp = build_fold_indirect_ref_loc (input_location,
                                         parmse.expr);
          parm_rank = e->rank;
          switch (parm_kind)
            {
            case (ELEMENTAL):
            case (SCALAR):
              parm_rank = 0;
              break;

            case (SCALAR_POINTER):
              tmp = build_fold_indirect_ref_loc (input_location,
                                             tmp);
              break;
            }

          if (e->expr_type == EXPR_OP
                && e->value.op.op == INTRINSIC_PARENTHESES
                && e->value.op.op1->expr_type == EXPR_VARIABLE)
            {
              tree local_tmp;
              local_tmp = gfc_evaluate_now (tmp, &se->pre);
              local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
              gfc_add_expr_to_block (&se->post, local_tmp);
            }

          if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
            {
              /* The derived type is passed to gfc_deallocate_alloc_comp.
                 Therefore, class actuals can handled correctly but derived
                 types passed to class formals need the _data component.  */
              tmp = gfc_class_data_get (tmp);
              if (!CLASS_DATA (fsym)->attr.dimension)
                tmp = build_fold_indirect_ref_loc (input_location, tmp);
            }

          tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);

          gfc_add_expr_to_block (&se->post, tmp);
        }

      /* Add argument checking of passing an unallocated/NULL actual to
         a nonallocatable/nonpointer dummy.  */

      if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
        {
          symbol_attribute attr;
          char *msg;
          tree cond;

          if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
            attr = gfc_expr_attr (e);
          else
            goto end_pointer_check;

          /*  In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
              allocatable to an optional dummy, cf. 12.5.2.12.  */
          if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
              && (gfc_option.allow_std & GFC_STD_F2008) != 0)
            goto end_pointer_check;

          if (attr.optional)
            {
              /* If the actual argument is an optional pointer/allocatable and
                 the formal argument takes an nonpointer optional value,
                 it is invalid to pass a non-present argument on, even
                 though there is no technical reason for this in gfortran.
                 See Fortran 2003, Section 12.4.1.6 item (7)+(8).  */
              tree present, null_ptr, type;

              if (attr.allocatable
                  && (fsym == NULL || !fsym->attr.allocatable))
                asprintf (&msg, "Allocatable actual argument '%s' is not "
                          "allocated or not present", e->symtree->n.sym->name);
              else if (attr.pointer
                       && (fsym == NULL || !fsym->attr.pointer))
                asprintf (&msg, "Pointer actual argument '%s' is not "
                          "associated or not present",
                          e->symtree->n.sym->name);
              else if (attr.proc_pointer
                       && (fsym == NULL || !fsym->attr.proc_pointer))
                asprintf (&msg, "Proc-pointer actual argument '%s' is not "
                          "associated or not present",
                          e->symtree->n.sym->name);
              else
                goto end_pointer_check;

              present = gfc_conv_expr_present (