2013-11-21 Edward Smith-Rowland <3dw4rd@verizon.net>

[official-gcc.git] / gcc / fortran / class.c

/* Implementation of Fortran 2003 Polymorphism.
   Copyright (C) 2009-2013 Free Software Foundation, Inc.
   Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
   and Janus Weil <janus@gcc.gnu.org>

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


/* class.c -- This file contains the front end functions needed to service
              the implementation of Fortran 2003 polymorphism and other
              object-oriented features.  */


/* Outline of the internal representation:

   Each CLASS variable is encapsulated by a class container, which is a
   structure with two fields:
    * _data: A pointer to the actual data of the variable. This field has the
             declared type of the class variable and its attributes
             (pointer/allocatable/dimension/...).
    * _vptr: A pointer to the vtable entry (see below) of the dynamic type.

   For each derived type we set up a "vtable" entry, i.e. a structure with the
   following fields:
    * _hash:     A hash value serving as a unique identifier for this type.
    * _size:     The size in bytes of the derived type.
    * _extends:  A pointer to the vtable entry of the parent derived type.
    * _def_init: A pointer to a default initialized variable of this type.
    * _copy:     A procedure pointer to a copying procedure.
    * _final:    A procedure pointer to a wrapper function, which frees
                 allocatable components and calls FINAL subroutines.

   After these follow procedure pointer components for the specific
   type-bound procedures.  */


#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "gfortran.h"
#include "constructor.h"
#include "target-memory.h"

/* Inserts a derived type component reference in a data reference chain.
    TS: base type of the ref chain so far, in which we will pick the component
    REF: the address of the GFC_REF pointer to update
    NAME: name of the component to insert
   Note that component insertion makes sense only if we are at the end of
   the chain (*REF == NULL) or if we are adding a missing "_data" component
   to access the actual contents of a class object.  */

static void
insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name)
{
  gfc_symbol *type_sym;
  gfc_ref *new_ref;

  gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS);
  type_sym = ts->u.derived;

  new_ref = gfc_get_ref ();
  new_ref->type = REF_COMPONENT;
  new_ref->next = *ref;
  new_ref->u.c.sym = type_sym;
  new_ref->u.c.component = gfc_find_component (type_sym, name, true, true);
  gcc_assert (new_ref->u.c.component);

  if (new_ref->next)
    {
      gfc_ref *next = NULL;

      /* We need to update the base type in the trailing reference chain to
         that of the new component.  */

      gcc_assert (strcmp (name, "_data") == 0);

      if (new_ref->next->type == REF_COMPONENT)
        next = new_ref->next;
      else if (new_ref->next->type == REF_ARRAY
               && new_ref->next->next
               && new_ref->next->next->type == REF_COMPONENT)
        next = new_ref->next->next;

      if (next != NULL)
        {
          gcc_assert (new_ref->u.c.component->ts.type == BT_CLASS
                      || new_ref->u.c.component->ts.type == BT_DERIVED);
          next->u.c.sym = new_ref->u.c.component->ts.u.derived;
        }
    }

  *ref = new_ref;
}


/* Tells whether we need to add a "_data" reference to access REF subobject
   from an object of type TS.  If FIRST_REF_IN_CHAIN is set, then the base
   object accessed by REF is a variable; in other words it is a full object,
   not a subobject.  */

static bool
class_data_ref_missing (gfc_typespec *ts, gfc_ref *ref, bool first_ref_in_chain)
{
  /* Only class containers may need the "_data" reference.  */
  if (ts->type != BT_CLASS)
    return false;

  /* Accessing a class container with an array reference is certainly wrong.  */
  if (ref->type != REF_COMPONENT)
    return true;

  /* Accessing the class container's fields is fine.  */
  if (ref->u.c.component->name[0] == '_')
    return false;

  /* At this point we have a class container with a non class container's field
     component reference.  We don't want to add the "_data" component if we are
     at the first reference and the symbol's type is an extended derived type.
     In that case, conv_parent_component_references will do the right thing so
     it is not absolutely necessary.  Omitting it prevents a regression (see
     class_41.f03) in the interface mapping mechanism.  When evaluating string
     lengths depending on dummy arguments, we create a fake symbol with a type
     equal to that of the dummy type.  However, because of type extension,
     the backend type (corresponding to the actual argument) can have a
     different (extended) type.  Adding the "_data" component explicitly, using
     the base type, confuses the gfc_conv_component_ref code which deals with
     the extended type.  */
  if (first_ref_in_chain && ts->u.derived->attr.extension)
    return false;

  /* We have a class container with a non class container's field component
     reference that doesn't fall into the above.  */
  return true;
}


/* Browse through a data reference chain and add the missing "_data" references
   when a subobject of a class object is accessed without it.
   Note that it doesn't add the "_data" reference when the class container
   is the last element in the reference chain.  */

void
gfc_fix_class_refs (gfc_expr *e)
{
  gfc_typespec *ts;
  gfc_ref **ref;

  if ((e->expr_type != EXPR_VARIABLE
       && e->expr_type != EXPR_FUNCTION)
      || (e->expr_type == EXPR_FUNCTION
          && e->value.function.isym != NULL))
    return;

  if (e->expr_type == EXPR_VARIABLE)
    ts = &e->symtree->n.sym->ts;
  else
    {
      gfc_symbol *func;

      gcc_assert (e->expr_type == EXPR_FUNCTION);
      if (e->value.function.esym != NULL)
        func = e->value.function.esym;
      else
        func = e->symtree->n.sym;

      if (func->result != NULL)
        ts = &func->result->ts;
      else
        ts = &func->ts;
    }

  for (ref = &e->ref; *ref != NULL; ref = &(*ref)->next)
    {
      if (class_data_ref_missing (ts, *ref, ref == &e->ref))
        insert_component_ref (ts, ref, "_data");

      if ((*ref)->type == REF_COMPONENT)
        ts = &(*ref)->u.c.component->ts;
    }
}


/* Insert a reference to the component of the given name.
   Only to be used with CLASS containers and vtables.  */

void
gfc_add_component_ref (gfc_expr *e, const char *name)
{
  gfc_ref **tail = &(e->ref);
  gfc_ref *next = NULL;
  gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
  while (*tail != NULL)
    {
      if ((*tail)->type == REF_COMPONENT)
        {
          if (strcmp ((*tail)->u.c.component->name, "_data") == 0
                && (*tail)->next
                && (*tail)->next->type == REF_ARRAY
                && (*tail)->next->next == NULL)
            return;
          derived = (*tail)->u.c.component->ts.u.derived;
        }
      if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
        break;
      tail = &((*tail)->next);
    }
  if (*tail != NULL && strcmp (name, "_data") == 0)
    next = *tail;
  (*tail) = gfc_get_ref();
  (*tail)->next = next;
  (*tail)->type = REF_COMPONENT;
  (*tail)->u.c.sym = derived;
  (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
  gcc_assert((*tail)->u.c.component);
  if (!next)
    e->ts = (*tail)->u.c.component->ts;
}


/* This is used to add both the _data component reference and an array
   reference to class expressions.  Used in translation of intrinsic
   array inquiry functions.  */

void
gfc_add_class_array_ref (gfc_expr *e)
{
  int rank = CLASS_DATA (e)->as->rank;
  gfc_array_spec *as = CLASS_DATA (e)->as;
  gfc_ref *ref = NULL;
  gfc_add_component_ref (e, "_data");
  e->rank = rank;
  for (ref = e->ref; ref; ref = ref->next)
    if (!ref->next)
      break;
  if (ref->type != REF_ARRAY)
    {
      ref->next = gfc_get_ref ();
      ref = ref->next;
      ref->type = REF_ARRAY;
      ref->u.ar.type = AR_FULL;
      ref->u.ar.as = as;
    }
}


/* Unfortunately, class array expressions can appear in various conditions;
   with and without both _data component and an arrayspec.  This function
   deals with that variability.  The previous reference to 'ref' is to a
   class array.  */

static bool
class_array_ref_detected (gfc_ref *ref, bool *full_array)
{
  bool no_data = false;
  bool with_data = false;

  /* An array reference with no _data component.  */
  if (ref && ref->type == REF_ARRAY
        && !ref->next
        && ref->u.ar.type != AR_ELEMENT)
    {
      if (full_array)
        *full_array = ref->u.ar.type == AR_FULL;
      no_data = true;
    }

  /* Cover cases where _data appears, with or without an array ref.  */
  if (ref && ref->type == REF_COMPONENT
        && strcmp (ref->u.c.component->name, "_data") == 0)
    {
      if (!ref->next)
        {
          with_data = true;
          if (full_array)
            *full_array = true;
        }
      else if (ref->next && ref->next->type == REF_ARRAY
            && !ref->next->next
            && ref->type == REF_COMPONENT
            && ref->next->type == REF_ARRAY
            && ref->next->u.ar.type != AR_ELEMENT)
        {
          with_data = true;
          if (full_array)
            *full_array = ref->next->u.ar.type == AR_FULL;
        }
    }

  return no_data || with_data;
}


/* Returns true if the expression contains a reference to a class
   array.  Notice that class array elements return false.  */

bool
gfc_is_class_array_ref (gfc_expr *e, bool *full_array)
{
  gfc_ref *ref;

  if (!e->rank)
    return false;

  if (full_array)
    *full_array= false;

  /* Is this a class array object? ie. Is the symbol of type class?  */
  if (e->symtree
        && e->symtree->n.sym->ts.type == BT_CLASS
        && CLASS_DATA (e->symtree->n.sym)
        && CLASS_DATA (e->symtree->n.sym)->attr.dimension
        && class_array_ref_detected (e->ref, full_array))
    return true;

  /* Or is this a class array component reference?  */
  for (ref = e->ref; ref; ref = ref->next)
    {
      if (ref->type == REF_COMPONENT
            && ref->u.c.component->ts.type == BT_CLASS
            && CLASS_DATA (ref->u.c.component)->attr.dimension
            && class_array_ref_detected (ref->next, full_array))
        return true;
    }

  return false;
}


/* Returns true if the expression is a reference to a class
   scalar.  This function is necessary because such expressions
   can be dressed with a reference to the _data component and so
   have a type other than BT_CLASS.  */

bool
gfc_is_class_scalar_expr (gfc_expr *e)
{
  gfc_ref *ref;

  if (e->rank)
    return false;

  /* Is this a class object?  */
  if (e->symtree
        && e->symtree->n.sym->ts.type == BT_CLASS
        && CLASS_DATA (e->symtree->n.sym)
        && !CLASS_DATA (e->symtree->n.sym)->attr.dimension
        && (e->ref == NULL
            || (strcmp (e->ref->u.c.component->name, "_data") == 0
                && e->ref->next == NULL)))
    return true;

  /* Or is the final reference BT_CLASS or _data?  */
  for (ref = e->ref; ref; ref = ref->next)
    {
      if (ref->type == REF_COMPONENT
            && ref->u.c.component->ts.type == BT_CLASS
            && CLASS_DATA (ref->u.c.component)
            && !CLASS_DATA (ref->u.c.component)->attr.dimension
            && (ref->next == NULL
                || (strcmp (ref->next->u.c.component->name, "_data") == 0
                    && ref->next->next == NULL)))
        return true;
    }

  return false;
}


/* Tells whether the expression E is a reference to a (scalar) class container.
   Scalar because array class containers usually have an array reference after
   them, and gfc_fix_class_refs will add the missing "_data" component reference
   in that case.  */

bool
gfc_is_class_container_ref (gfc_expr *e)
{
  gfc_ref *ref;
  bool result;

  if (e->expr_type != EXPR_VARIABLE)
    return e->ts.type == BT_CLASS;

  if (e->symtree->n.sym->ts.type == BT_CLASS)
    result = true;
  else
    result = false;

  for (ref = e->ref; ref; ref = ref->next)
    {
      if (ref->type != REF_COMPONENT)
        result = false;
      else if (ref->u.c.component->ts.type == BT_CLASS)
        result = true;
      else
        result = false;
    }

  return result;
}


/* Build an initializer for CLASS pointers,
   initializing the _data component to the init_expr (or NULL) and the _vptr
   component to the corresponding type (or the declared type, given by ts).  */

gfc_expr *
gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
{
  gfc_expr *init;
  gfc_component *comp;
  gfc_symbol *vtab = NULL;
  bool is_unlimited_polymorphic;

  is_unlimited_polymorphic = ts->u.derived
      && ts->u.derived->components->ts.u.derived
      && ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic;

  if (is_unlimited_polymorphic && init_expr)
    vtab = gfc_find_intrinsic_vtab (&ts->u.derived->components->ts);
  else if (init_expr && init_expr->expr_type != EXPR_NULL)
    vtab = gfc_find_derived_vtab (init_expr->ts.u.derived);
  else
    vtab = gfc_find_derived_vtab (ts->u.derived);

  init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
                                             &ts->u.derived->declared_at);
  init->ts = *ts;

  for (comp = ts->u.derived->components; comp; comp = comp->next)
    {
      gfc_constructor *ctor = gfc_constructor_get();
      if (strcmp (comp->name, "_vptr") == 0 && vtab)
        ctor->expr = gfc_lval_expr_from_sym (vtab);
      else if (init_expr && init_expr->expr_type != EXPR_NULL)
          ctor->expr = gfc_copy_expr (init_expr);
      else
        ctor->expr = gfc_get_null_expr (NULL);
      gfc_constructor_append (&init->value.constructor, ctor);
    }

  return init;
}


/* Create a unique string identifier for a derived type, composed of its name
   and module name. This is used to construct unique names for the class
   containers and vtab symbols.  */

static void
get_unique_type_string (char *string, gfc_symbol *derived)
{
  char dt_name[GFC_MAX_SYMBOL_LEN+1];
  if (derived->attr.unlimited_polymorphic)
    strcpy (dt_name, "STAR");
  else
    strcpy (dt_name, derived->name);
  dt_name[0] = TOUPPER (dt_name[0]);
  if (derived->attr.unlimited_polymorphic)
    sprintf (string, "_%s", dt_name);
  else if (derived->module)
    sprintf (string, "%s_%s", derived->module, dt_name);
  else if (derived->ns->proc_name)
    sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name);
  else
    sprintf (string, "_%s", dt_name);
}


/* A relative of 'get_unique_type_string' which makes sure the generated
   string will not be too long (replacing it by a hash string if needed).  */

static void
get_unique_hashed_string (char *string, gfc_symbol *derived)
{
  char tmp[2*GFC_MAX_SYMBOL_LEN+2];
  get_unique_type_string (&tmp[0], derived);
  /* If string is too long, use hash value in hex representation (allow for
     extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
     We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
     where %d is the (co)rank which can be up to n = 15.  */
  if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15)
    {
      int h = gfc_hash_value (derived);
      sprintf (string, "%X", h);
    }
  else
    strcpy (string, tmp);
}


/* Assign a hash value for a derived type. The algorithm is that of SDBM.  */

unsigned int
gfc_hash_value (gfc_symbol *sym)
{
  unsigned int hash = 0;
  char c[2*(GFC_MAX_SYMBOL_LEN+1)];
  int i, len;

  get_unique_type_string (&c[0], sym);
  len = strlen (c);

  for (i = 0; i < len; i++)
    hash = (hash << 6) + (hash << 16) - hash + c[i];

  /* Return the hash but take the modulus for the sake of module read,
     even though this slightly increases the chance of collision.  */
  return (hash % 100000000);
}


/* Assign a hash value for an intrinsic type. The algorithm is that of SDBM.  */

unsigned int
gfc_intrinsic_hash_value (gfc_typespec *ts)
{
  unsigned int hash = 0;
  const char *c = gfc_typename (ts);
  int i, len;

  len = strlen (c);

  for (i = 0; i < len; i++)
    hash = (hash << 6) + (hash << 16) - hash + c[i];

  /* Return the hash but take the modulus for the sake of module read,
     even though this slightly increases the chance of collision.  */
  return (hash % 100000000);
}


/* Build a polymorphic CLASS entity, using the symbol that comes from
   build_sym. A CLASS entity is represented by an encapsulating type,
   which contains the declared type as '_data' component, plus a pointer
   component '_vptr' which determines the dynamic type.  */

bool
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
                        gfc_array_spec **as, bool delayed_vtab)
{
  char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
  gfc_symbol *fclass;
  gfc_symbol *vtab;
  gfc_component *c;
  gfc_namespace *ns;
  int rank;

  gcc_assert (as);

  if (*as && (*as)->type == AS_ASSUMED_SIZE)
    {
      gfc_error ("Assumed size polymorphic objects or components, such "
                 "as that at %C, have not yet been implemented");
      return false;
    }

  if (attr->class_ok)
    /* Class container has already been built.  */
    return true;

  attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
                   || attr->select_type_temporary || attr->associate_var;

  if (!attr->class_ok)
    /* We can not build the class container yet.  */
    return true;

  /* Determine the name of the encapsulating type.  */
  rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
  get_unique_hashed_string (tname, ts->u.derived);
  if ((*as) && attr->allocatable)
    sprintf (name, "__class_%s_%d_%da", tname, rank, (*as)->corank);
  else if ((*as) && attr->pointer)
    sprintf (name, "__class_%s_%d_%dp", tname, rank, (*as)->corank);
  else if ((*as))
    sprintf (name, "__class_%s_%d_%d", tname, rank, (*as)->corank);
  else if (attr->pointer)
    sprintf (name, "__class_%s_p", tname);
  else if (attr->allocatable)
    sprintf (name, "__class_%s_a", tname);
  else
    sprintf (name, "__class_%s", tname);

  if (ts->u.derived->attr.unlimited_polymorphic)
    {
      /* Find the top-level namespace.  */
      for (ns = gfc_current_ns; ns; ns = ns->parent)
        if (!ns->parent)
          break;
    }
  else
    ns = ts->u.derived->ns;

  gfc_find_symbol (name, ns, 0, &fclass);
  if (fclass == NULL)
    {
      gfc_symtree *st;
      /* If not there, create a new symbol.  */
      fclass = gfc_new_symbol (name, ns);
      st = gfc_new_symtree (&ns->sym_root, name);
      st->n.sym = fclass;
      gfc_set_sym_referenced (fclass);
      fclass->refs++;
      fclass->ts.type = BT_UNKNOWN;
      if (!ts->u.derived->attr.unlimited_polymorphic)
        fclass->attr.abstract = ts->u.derived->attr.abstract;
      fclass->f2k_derived = gfc_get_namespace (NULL, 0);
      if (!gfc_add_flavor (&fclass->attr, FL_DERIVED, NULL,
                           &gfc_current_locus))
        return false;

      /* Add component '_data'.  */
      if (!gfc_add_component (fclass, "_data", &c))
        return false;
      c->ts = *ts;
      c->ts.type = BT_DERIVED;
      c->attr.access = ACCESS_PRIVATE;
      c->ts.u.derived = ts->u.derived;
      c->attr.class_pointer = attr->pointer;
      c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable)
                        || attr->select_type_temporary;
      c->attr.allocatable = attr->allocatable;
      c->attr.dimension = attr->dimension;
      c->attr.codimension = attr->codimension;
      c->attr.abstract = fclass->attr.abstract;
      c->as = (*as);
      c->initializer = NULL;

      /* Add component '_vptr'.  */
      if (!gfc_add_component (fclass, "_vptr", &c))
        return false;
      c->ts.type = BT_DERIVED;
      if (delayed_vtab
          || (ts->u.derived->f2k_derived
              && ts->u.derived->f2k_derived->finalizers))
        c->ts.u.derived = NULL;
      else
        {
          vtab = gfc_find_derived_vtab (ts->u.derived);
          gcc_assert (vtab);
          c->ts.u.derived = vtab->ts.u.derived;
        }
      c->attr.access = ACCESS_PRIVATE;
      c->attr.pointer = 1;
    }

  if (!ts->u.derived->attr.unlimited_polymorphic)
    {
      /* Since the extension field is 8 bit wide, we can only have
         up to 255 extension levels.  */
      if (ts->u.derived->attr.extension == 255)
        {
          gfc_error ("Maximum extension level reached with type '%s' at %L",
                     ts->u.derived->name, &ts->u.derived->declared_at);
        return false;
        }

      fclass->attr.extension = ts->u.derived->attr.extension + 1;
      fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp;
      fclass->attr.coarray_comp = ts->u.derived->attr.coarray_comp;
    }

  fclass->attr.is_class = 1;
  ts->u.derived = fclass;
  attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
  (*as) = NULL;
  return true;
}


/* Add a procedure pointer component to the vtype
   to represent a specific type-bound procedure.  */

static void
add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
{
  gfc_component *c;

  if (tb->non_overridable)
    return;

  c = gfc_find_component (vtype, name, true, true);

  if (c == NULL)
    {
      /* Add procedure component.  */
      if (!gfc_add_component (vtype, name, &c))
        return;

      if (!c->tb)
        c->tb = XCNEW (gfc_typebound_proc);
      *c->tb = *tb;
      c->tb->ppc = 1;
      c->attr.procedure = 1;
      c->attr.proc_pointer = 1;
      c->attr.flavor = FL_PROCEDURE;
      c->attr.access = ACCESS_PRIVATE;
      c->attr.external = 1;
      c->attr.untyped = 1;
      c->attr.if_source = IFSRC_IFBODY;
    }
  else if (c->attr.proc_pointer && c->tb)
    {
      *c->tb = *tb;
      c->tb->ppc = 1;
    }

  if (tb->u.specific)
    {
      c->ts.interface = tb->u.specific->n.sym;
      if (!tb->deferred)
        c->initializer = gfc_get_variable_expr (tb->u.specific);
    }
}


/* Add all specific type-bound procedures in the symtree 'st' to a vtype.  */

static void
add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
{
  if (!st)
    return;

  if (st->left)
    add_procs_to_declared_vtab1 (st->left, vtype);

  if (st->right)
    add_procs_to_declared_vtab1 (st->right, vtype);

  if (st->n.tb && !st->n.tb->error
      && !st->n.tb->is_generic && st->n.tb->u.specific)
    add_proc_comp (vtype, st->name, st->n.tb);
}


/* Copy procedure pointers components from the parent type.  */

static void
copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
{
  gfc_component *cmp;
  gfc_symbol *vtab;

  vtab = gfc_find_derived_vtab (declared);

  for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
    {
      if (gfc_find_component (vtype, cmp->name, true, true))
        continue;

      add_proc_comp (vtype, cmp->name, cmp->tb);
    }
}


/* Returns true if any of its nonpointer nonallocatable components or
   their nonpointer nonallocatable subcomponents has a finalization
   subroutine.  */

static bool
has_finalizer_component (gfc_symbol *derived)
{
   gfc_component *c;

  for (c = derived->components; c; c = c->next)
    {
      if (c->ts.type == BT_DERIVED && c->ts.u.derived->f2k_derived
          && c->ts.u.derived->f2k_derived->finalizers)
        return true;

      if (c->ts.type == BT_DERIVED
          && !c->attr.pointer && !c->attr.allocatable
          && has_finalizer_component (c->ts.u.derived))
        return true;
    }
  return false;
}


/* Call DEALLOCATE for the passed component if it is allocatable, if it is
   neither allocatable nor a pointer but has a finalizer, call it. If it
   is a nonpointer component with allocatable components or has finalizers, walk
   them. Either of them is required; other nonallocatables and pointers aren't
   handled gracefully.
   Note: If the component is allocatable, the DEALLOCATE handling takes care
   of calling the appropriate finalizers, coarray deregistering, and
   deallocation of allocatable subcomponents.  */

static void
finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
                    gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code)
{
  gfc_expr *e;
  gfc_ref *ref;

  if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS
      && !comp->attr.allocatable)
    return;

  if ((comp->ts.type == BT_DERIVED && comp->attr.pointer)
      || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
          && CLASS_DATA (comp)->attr.pointer))
    return;

  if (comp->ts.type == BT_DERIVED && !comp->attr.allocatable
      && (comp->ts.u.derived->f2k_derived == NULL
          || comp->ts.u.derived->f2k_derived->finalizers == NULL)
      && !has_finalizer_component (comp->ts.u.derived))
    return;

  e = gfc_copy_expr (expr);
  if (!e->ref)
    e->ref = ref = gfc_get_ref ();
  else
    {
      for (ref = e->ref; ref->next; ref = ref->next)
        ;
      ref->next = gfc_get_ref ();
      ref = ref->next;
    }
  ref->type = REF_COMPONENT;
  ref->u.c.sym = derived;
  ref->u.c.component = comp;
  e->ts = comp->ts;

  if (comp->attr.dimension || comp->attr.codimension
      || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
          && (CLASS_DATA (comp)->attr.dimension
              || CLASS_DATA (comp)->attr.codimension)))
    {
      ref->next = gfc_get_ref ();
      ref->next->type = REF_ARRAY;
      ref->next->u.ar.dimen = 0;
      ref->next->u.ar.as = comp->ts.type == BT_CLASS ? CLASS_DATA (comp)->as
                                                        : comp->as;
      e->rank = ref->next->u.ar.as->rank;
      ref->next->u.ar.type = e->rank ? AR_FULL : AR_ELEMENT;
    }

  /* Call DEALLOCATE (comp, stat=ignore).  */
  if (comp->attr.allocatable
      || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
          && CLASS_DATA (comp)->attr.allocatable))
    {
      gfc_code *dealloc, *block = NULL;

      /* Add IF (fini_coarray).  */
      if (comp->attr.codimension
          || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
              && CLASS_DATA (comp)->attr.allocatable))
        {
          block = gfc_get_code (EXEC_IF);
          if (*code)
            {
              (*code)->next = block;
              (*code) = (*code)->next;
            }
          else
              (*code) = block;

          block->block = gfc_get_code (EXEC_IF);
          block = block->block;
          block->expr1 = gfc_lval_expr_from_sym (fini_coarray);
        }

      dealloc = gfc_get_code (EXEC_DEALLOCATE);

      dealloc->ext.alloc.list = gfc_get_alloc ();
      dealloc->ext.alloc.list->expr = e;
      dealloc->expr1 = gfc_lval_expr_from_sym (stat);

      if (block)
        block->next = dealloc;
      else if (*code)
        {
          (*code)->next = dealloc;
          (*code) = (*code)->next;
        }
      else
        (*code) = dealloc;
    }
  else if (comp->ts.type == BT_DERIVED
            && comp->ts.u.derived->f2k_derived
            && comp->ts.u.derived->f2k_derived->finalizers)
    {
      /* Call FINAL_WRAPPER (comp);  */
      gfc_code *final_wrap;
      gfc_symbol *vtab;
      gfc_component *c;

      vtab = gfc_find_derived_vtab (comp->ts.u.derived);
      for (c = vtab->ts.u.derived->components; c; c = c->next)
        if (strcmp (c->name, "_final") == 0)
          break;

      gcc_assert (c);
      final_wrap = gfc_get_code (EXEC_CALL);
      final_wrap->symtree = c->initializer->symtree;
      final_wrap->resolved_sym = c->initializer->symtree->n.sym;
      final_wrap->ext.actual = gfc_get_actual_arglist ();
      final_wrap->ext.actual->expr = e;

      if (*code)
        {
          (*code)->next = final_wrap;
          (*code) = (*code)->next;
        }
      else
        (*code) = final_wrap;
    }
  else
    {
      gfc_component *c;

      for (c = comp->ts.u.derived->components; c; c = c->next)
        finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code);
      gfc_free_expr (e);
    }
}


/* Generate code equivalent to
   CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
                     + offset, c_ptr), ptr).  */

static gfc_code *
finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
                         gfc_expr *offset, gfc_namespace *sub_ns)
{
  gfc_code *block;
  gfc_expr *expr, *expr2;

  /* C_F_POINTER().  */
  block = gfc_get_code (EXEC_CALL);
  gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true);
  block->resolved_sym = block->symtree->n.sym;
  block->resolved_sym->attr.flavor = FL_PROCEDURE;
  block->resolved_sym->attr.intrinsic = 1;
  block->resolved_sym->attr.subroutine = 1;
  block->resolved_sym->from_intmod = INTMOD_ISO_C_BINDING;
  block->resolved_sym->intmod_sym_id = ISOCBINDING_F_POINTER;
  block->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER);
  gfc_commit_symbol (block->resolved_sym);

  /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t).  */
  block->ext.actual = gfc_get_actual_arglist ();
  block->ext.actual->next = gfc_get_actual_arglist ();
  block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind,
                                                    NULL, 0);
  block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE. */

  /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t).  */

  /* TRANSFER's first argument: C_LOC (array).  */
  expr = gfc_get_expr ();
  expr->expr_type = EXPR_FUNCTION;
  gfc_get_sym_tree ("c_loc", sub_ns, &expr->symtree, false);
  expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
  expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC;
  expr->symtree->n.sym->attr.intrinsic = 1;
  expr->symtree->n.sym->from_intmod = INTMOD_ISO_C_BINDING;
  expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC);
  expr->value.function.actual = gfc_get_actual_arglist ();
  expr->value.function.actual->expr
            = gfc_lval_expr_from_sym (array);
  expr->symtree->n.sym->result = expr->symtree->n.sym;
  gfc_commit_symbol (expr->symtree->n.sym);
  expr->ts.type = BT_INTEGER;
  expr->ts.kind = gfc_index_integer_kind;

  /* TRANSFER.  */
  expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_TRANSFER, "transfer",
                                    gfc_current_locus, 3, expr,
                                    gfc_get_int_expr (gfc_index_integer_kind,
                                                      NULL, 0), NULL);
  expr2->ts.type = BT_INTEGER;
  expr2->ts.kind = gfc_index_integer_kind;

  /* <array addr> + <offset>.  */
  block->ext.actual->expr = gfc_get_expr ();
  block->ext.actual->expr->expr_type = EXPR_OP;
  block->ext.actual->expr->value.op.op = INTRINSIC_PLUS;
  block->ext.actual->expr->value.op.op1 = expr2;
  block->ext.actual->expr->value.op.op2 = offset;
  block->ext.actual->expr->ts = expr->ts;

  /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=.  */
  block->ext.actual->next = gfc_get_actual_arglist ();
  block->ext.actual->next->expr = gfc_lval_expr_from_sym (ptr);
  block->ext.actual->next->next = gfc_get_actual_arglist ();

  return block;
}


/* Calculates the offset to the (idx+1)th element of an array, taking the
   stride into account. It generates the code:
     offset = 0
     do idx2 = 1, rank
       offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
     end do
     offset = offset * byte_stride.  */

static gfc_code*
finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
                         gfc_symbol *strides, gfc_symbol *sizes,
                         gfc_symbol *byte_stride, gfc_expr *rank,
                         gfc_code *block, gfc_namespace *sub_ns)
{
  gfc_iterator *iter;
  gfc_expr *expr, *expr2;

  /* offset = 0.  */
  block->next = gfc_get_code (EXEC_ASSIGN);
  block = block->next;
  block->expr1 = gfc_lval_expr_from_sym (offset);
  block->expr2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);

  /* Create loop.  */
  iter = gfc_get_iterator ();
  iter->var = gfc_lval_expr_from_sym (idx2);
  iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
  iter->end = gfc_copy_expr (rank);
  iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
  block->next = gfc_get_code (EXEC_DO);
  block = block->next;
  block->ext.iterator = iter;
  block->block = gfc_get_code (EXEC_DO);

  /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
                                  * strides(idx2).  */

  /* mod (idx, sizes(idx2)).  */
  expr = gfc_lval_expr_from_sym (sizes);
  expr->ref = gfc_get_ref ();
  expr->ref->type = REF_ARRAY;
  expr->ref->u.ar.as = sizes->as;
  expr->ref->u.ar.type = AR_ELEMENT;
  expr->ref->u.ar.dimen = 1;
  expr->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
  expr->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);

  expr = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_MOD, "mod",
                                   gfc_current_locus, 2,
                                   gfc_lval_expr_from_sym (idx), expr);
  expr->ts = idx->ts;

  /* (...) / sizes(idx2-1).  */
  expr2 = gfc_get_expr ();
  expr2->expr_type = EXPR_OP;
  expr2->value.op.op = INTRINSIC_DIVIDE;
  expr2->value.op.op1 = expr;
  expr2->value.op.op2 = gfc_lval_expr_from_sym (sizes);
  expr2->value.op.op2->ref = gfc_get_ref ();
  expr2->value.op.op2->ref->type = REF_ARRAY;
  expr2->value.op.op2->ref->u.ar.as = sizes->as;
  expr2->value.op.op2->ref->u.ar.type = AR_ELEMENT;
  expr2->value.op.op2->ref->u.ar.dimen = 1;
  expr2->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
  expr2->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
  expr2->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
  expr2->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
  expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1
        = gfc_lval_expr_from_sym (idx2);
  expr2->value.op.op2->ref->u.ar.start[0]->value.op.op2
        = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
  expr2->value.op.op2->ref->u.ar.start[0]->ts
        = expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
  expr2->ts = idx->ts;

  /* ... * strides(idx2).  */
  expr = gfc_get_expr ();
  expr->expr_type = EXPR_OP;
  expr->value.op.op = INTRINSIC_TIMES;
  expr->value.op.op1 = expr2;
  expr->value.op.op2 = gfc_lval_expr_from_sym (strides);
  expr->value.op.op2->ref = gfc_get_ref ();
  expr->value.op.op2->ref->type = REF_ARRAY;
  expr->value.op.op2->ref->u.ar.type = AR_ELEMENT;
  expr->value.op.op2->ref->u.ar.dimen = 1;
  expr->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
  expr->value.op.op2->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
  expr->value.op.op2->ref->u.ar.as = strides->as;
  expr->ts = idx->ts;

  /* offset = offset + ...  */
  block->block->next = gfc_get_code (EXEC_ASSIGN);
  block->block->next->expr1 = gfc_lval_expr_from_sym (offset);
  block->block->next->expr2 = gfc_get_expr ();
  block->block->next->expr2->expr_type = EXPR_OP;
  block->block->next->expr2->value.op.op = INTRINSIC_PLUS;
  block->block->next->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
  block->block->next->expr2->value.op.op2 = expr;
  block->block->next->expr2->ts = idx->ts;

  /* After the loop:  offset = offset * byte_stride.  */
  block->next = gfc_get_code (EXEC_ASSIGN);
  block = block->next;
  block->expr1 = gfc_lval_expr_from_sym (offset);
  block->expr2 = gfc_get_expr ();
  block->expr2->expr_type = EXPR_OP;
  block->expr2->value.op.op = INTRINSIC_TIMES;
  block->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
  block->expr2->value.op.op2 = gfc_lval_expr_from_sym (byte_stride);
  block->expr2->ts = block->expr2->value.op.op1->ts;
  return block;
}


/* Insert code of the following form:

   block
     integer(c_intptr_t) :: i

     if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
          && (is_contiguous || !final_rank3->attr.contiguous
              || final_rank3->as->type != AS_ASSUMED_SHAPE))
         || 0 == STORAGE_SIZE (array)) then
       call final_rank3 (array)
     else
       block
         integer(c_intptr_t) :: offset, j
         type(t) :: tmp(shape (array))

         do i = 0, size (array)-1
           offset = obtain_offset(i, strides, sizes, byte_stride)
           addr = transfer (c_loc (array), addr) + offset
           call c_f_pointer (transfer (addr, cptr), ptr)

           addr = transfer (c_loc (tmp), addr)
                            + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
           call c_f_pointer (transfer (addr, cptr), ptr2)
           ptr2 = ptr
         end do
         call final_rank3 (tmp)
       end block
     end if
   block  */

static void
finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
                              gfc_symbol *array, gfc_symbol *byte_stride,
                              gfc_symbol *idx, gfc_symbol *ptr,
                              gfc_symbol *nelem,
                              gfc_symbol *strides, gfc_symbol *sizes,
                              gfc_symbol *idx2, gfc_symbol *offset,
                              gfc_symbol *is_contiguous, gfc_expr *rank,
                              gfc_namespace *sub_ns)
{
  gfc_symbol *tmp_array, *ptr2;
  gfc_expr *size_expr, *offset2, *expr;
  gfc_namespace *ns;
  gfc_iterator *iter;
  gfc_code *block2;
  int i;

  block->next = gfc_get_code (EXEC_IF);
  block = block->next;

  block->block = gfc_get_code (EXEC_IF);
  block = block->block;

  /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE.  */
  size_expr = gfc_get_expr ();
  size_expr->where = gfc_current_locus;
  size_expr->expr_type = EXPR_OP;
  size_expr->value.op.op = INTRINSIC_DIVIDE;

  /* STORAGE_SIZE (array,kind=c_intptr_t).  */
  size_expr->value.op.op1
        = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
                                    "storage_size", gfc_current_locus, 2,
                                    gfc_lval_expr_from_sym (array),
                                    gfc_get_int_expr (gfc_index_integer_kind,
                                                      NULL, 0));

  /* NUMERIC_STORAGE_SIZE.  */
  size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
                                              gfc_character_storage_size);
  size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
  size_expr->ts = size_expr->value.op.op1->ts;

  /* IF condition: (stride == size_expr
                    && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
                        || is_contiguous)
                   || 0 == size_expr.  */
  block->expr1 = gfc_get_expr ();
  block->expr1->ts.type = BT_LOGICAL;
  block->expr1->ts.kind = gfc_default_logical_kind;
  block->expr1->expr_type = EXPR_OP;
  block->expr1->where = gfc_current_locus;

  block->expr1->value.op.op = INTRINSIC_OR;

  /* byte_stride == size_expr */
  expr = gfc_get_expr ();
  expr->ts.type = BT_LOGICAL;
  expr->ts.kind = gfc_default_logical_kind;
  expr->expr_type = EXPR_OP;
  expr->where = gfc_current_locus;
  expr->value.op.op = INTRINSIC_EQ;
  expr->value.op.op1
        = gfc_lval_expr_from_sym (byte_stride);
  expr->value.op.op2 = size_expr;

  /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
     add is_contiguous check.  */

  if (fini->proc_tree->n.sym->formal->sym->as->type != AS_ASSUMED_SHAPE
      || fini->proc_tree->n.sym->formal->sym->attr.contiguous)
    {
      gfc_expr *expr2;
      expr2 = gfc_get_expr ();
      expr2->ts.type = BT_LOGICAL;
      expr2->ts.kind = gfc_default_logical_kind;
      expr2->expr_type = EXPR_OP;
      expr2->where = gfc_current_locus;
      expr2->value.op.op = INTRINSIC_AND;
      expr2->value.op.op1 = expr;
      expr2->value.op.op2 = gfc_lval_expr_from_sym (is_contiguous);
      expr = expr2;
    }

  block->expr1->value.op.op1 = expr;

  /* 0 == size_expr */
  block->expr1->value.op.op2 = gfc_get_expr ();
  block->expr1->value.op.op2->ts.type = BT_LOGICAL;
  block->expr1->value.op.op2->ts.kind = gfc_default_logical_kind;
  block->expr1->value.op.op2->expr_type = EXPR_OP;
  block->expr1->value.op.op2->where = gfc_current_locus;
  block->expr1->value.op.op2->value.op.op = INTRINSIC_EQ;
  block->expr1->value.op.op2->value.op.op1 =
                        gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
  block->expr1->value.op.op2->value.op.op2 = gfc_copy_expr (size_expr);

  /* IF body: call final subroutine.  */
  block->next = gfc_get_code (EXEC_CALL);
  block->next->symtree = fini->proc_tree;
  block->next->resolved_sym = fini->proc_tree->n.sym;
  block->next->ext.actual = gfc_get_actual_arglist ();
  block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);

  /* ELSE.  */

  block->block = gfc_get_code (EXEC_IF);
  block = block->block;

  /* BLOCK ... END BLOCK.  */
  block->next = gfc_get_code (EXEC_BLOCK);
  block = block->next;

  ns = gfc_build_block_ns (sub_ns);
  block->ext.block.ns = ns;
  block->ext.block.assoc = NULL;

  gfc_get_symbol ("ptr2", ns, &ptr2);
  ptr2->ts.type = BT_DERIVED;
  ptr2->ts.u.derived = array->ts.u.derived;
  ptr2->attr.flavor = FL_VARIABLE;
  ptr2->attr.pointer = 1;
  ptr2->attr.artificial = 1;
  gfc_set_sym_referenced (ptr2);
  gfc_commit_symbol (ptr2);

  gfc_get_symbol ("tmp_array", ns, &tmp_array);
  tmp_array->ts.type = BT_DERIVED;
  tmp_array->ts.u.derived = array->ts.u.derived;
  tmp_array->attr.flavor = FL_VARIABLE;
  tmp_array->attr.dimension = 1;
  tmp_array->attr.artificial = 1;
  tmp_array->as = gfc_get_array_spec();
  tmp_array->attr.intent = INTENT_INOUT;
  tmp_array->as->type = AS_EXPLICIT;
  tmp_array->as->rank = fini->proc_tree->n.sym->formal->sym->as->rank;

  for (i = 0; i < tmp_array->as->rank; i++)
    {
      gfc_expr *shape_expr;
      tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
                                                  NULL, 1);
      /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind).  */
      shape_expr
        = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
                                    gfc_current_locus, 3,
                                    gfc_lval_expr_from_sym (array),
                                    gfc_get_int_expr (gfc_default_integer_kind,
                                                      NULL, i+1),
                                    gfc_get_int_expr (gfc_default_integer_kind,
                                                      NULL,
                                                      gfc_index_integer_kind));
      shape_expr->ts.kind = gfc_index_integer_kind;
      tmp_array->as->upper[i] = shape_expr;
    }
  gfc_set_sym_referenced (tmp_array);
  gfc_commit_symbol (tmp_array);

  /* Create loop.  */
  iter = gfc_get_iterator ();
  iter->var = gfc_lval_expr_from_sym (idx);
  iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
  iter->end = gfc_lval_expr_from_sym (nelem);
  iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);

  block = gfc_get_code (EXEC_DO);
  ns->code = block;
  block->ext.iterator = iter;
  block->block = gfc_get_code (EXEC_DO);

  /* Offset calculation for the new array: idx * size of type (in bytes).  */
  offset2 = gfc_get_expr ();
  offset2->expr_type = EXPR_OP;
  offset2->value.op.op = INTRINSIC_TIMES;
  offset2->value.op.op1 = gfc_lval_expr_from_sym (idx);
  offset2->value.op.op2 = gfc_copy_expr (size_expr);
  offset2->ts = byte_stride->ts;

  /* Offset calculation of "array".  */
  block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
                                    byte_stride, rank, block->block, sub_ns);

  /* Create code for
     CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
                       + idx * stride, c_ptr), ptr).  */
  block2->next = finalization_scalarizer (array, ptr,
                                          gfc_lval_expr_from_sym (offset),
                                          sub_ns);
  block2 = block2->next;
  block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns);
  block2 = block2->next;

  /* ptr2 = ptr.  */
  block2->next = gfc_get_code (EXEC_ASSIGN);
  block2 = block2->next;
  block2->expr1 = gfc_lval_expr_from_sym (ptr2);
  block2->expr2 = gfc_lval_expr_from_sym (ptr);

  /* Call now the user's final subroutine. */
  block->next  = gfc_get_code (EXEC_CALL);
  block = block->next;
  block->symtree = fini->proc_tree;
  block->resolved_sym = fini->proc_tree->n.sym;
  block->ext.actual = gfc_get_actual_arglist ();
  block->ext.actual->expr = gfc_lval_expr_from_sym (tmp_array);

  if (fini->proc_tree->n.sym->formal->sym->attr.intent == INTENT_IN)
    return;

  /* Copy back.  */

  /* Loop.  */
  iter = gfc_get_iterator ();
  iter->var = gfc_lval_expr_from_sym (idx);
  iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
  iter->end = gfc_lval_expr_from_sym (nelem);
  iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);

  block->next = gfc_get_code (EXEC_DO);
  block = block->next;
  block->ext.iterator = iter;
  block->block = gfc_get_code (EXEC_DO);

  /* Offset calculation of "array".  */
  block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
                                    byte_stride, rank, block->block, sub_ns);

  /* Create code for
     CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
                       + offset, c_ptr), ptr).  */
  block2->next = finalization_scalarizer (array, ptr,
                                          gfc_lval_expr_from_sym (offset),
                                          sub_ns);
  block2 = block2->next;
  block2->next = finalization_scalarizer (tmp_array, ptr2,
                                          gfc_copy_expr (offset2), sub_ns);
  block2 = block2->next;

  /* ptr = ptr2.  */
  block2->next = gfc_get_code (EXEC_ASSIGN);
  block2->next->expr1 = gfc_lval_expr_from_sym (ptr);
  block2->next->expr2 = gfc_lval_expr_from_sym (ptr2);
}


/* Generate the finalization/polymorphic freeing wrapper subroutine for the
   derived type "derived". The function first calls the approriate FINAL
   subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
   components (but not the inherited ones). Last, it calls the wrapper
   subroutine of the parent. The generated wrapper procedure takes as argument
   an assumed-rank array.
   If neither allocatable components nor FINAL subroutines exists, the vtab
   will contain a NULL pointer.
   The generated function has the form
     _final(assumed-rank array, stride, skip_corarray)
   where the array has to be contiguous (except of the lowest dimension). The
   stride (in bytes) is used to allow different sizes for ancestor types by
   skipping over the additionally added components in the scalarizer. If
   "fini_coarray" is false, coarray components are not finalized to allow for
   the correct semantic with intrinsic assignment.  */

static void
generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
                               const char *tname, gfc_component *vtab_final)
{
  gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides;
  gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem;
  gfc_component *comp;
  gfc_namespace *sub_ns;
  gfc_code *last_code, *block;
  char name[GFC_MAX_SYMBOL_LEN+1];
  bool finalizable_comp = false;
  bool expr_null_wrapper = false;
  gfc_expr *ancestor_wrapper = NULL, *rank;
  gfc_iterator *iter;

  if (derived->attr.unlimited_polymorphic)
    {
      vtab_final->initializer = gfc_get_null_expr (NULL);
      return;
    }

  /* Search for the ancestor's finalizers. */
  if (derived->attr.extension && derived->components
      && (!derived->components->ts.u.derived->attr.abstract
          || has_finalizer_component (derived)))
    {
      gfc_symbol *vtab;
      gfc_component *comp;

      vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
      for (comp = vtab->ts.u.derived->components; comp; comp = comp->next)
        if (comp->name[0] == '_' && comp->name[1] == 'f')
          {
            ancestor_wrapper = comp->initializer;
            break;
          }
    }

  /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
     components: Return a NULL() expression; we defer this a bit to have have
     an interface declaration.  */
  if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL)
      && !derived->attr.alloc_comp
      && (!derived->f2k_derived || !derived->f2k_derived->finalizers)
      && !has_finalizer_component (derived))
    expr_null_wrapper = true;
  else
    /* Check whether there are new allocatable components.  */
    for (comp = derived->components; comp; comp = comp->next)
      {
        if (comp == derived->components && derived->attr.extension
            && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
        continue;

        if (comp->ts.type != BT_CLASS && !comp->attr.pointer
            && (comp->attr.allocatable
                || (comp->ts.type == BT_DERIVED
                    && (comp->ts.u.derived->attr.alloc_comp
                        || has_finalizer_component (comp->ts.u.derived)
                        || (comp->ts.u.derived->f2k_derived
                            && comp->ts.u.derived->f2k_derived->finalizers)))))
          finalizable_comp = true;
        else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
                 && CLASS_DATA (comp)->attr.allocatable)
          finalizable_comp = true;
      }

  /* If there is no new finalizer and no new allocatable, return with
     an expr to the ancestor's one.  */
  if (!expr_null_wrapper && !finalizable_comp
      && (!derived->f2k_derived || !derived->f2k_derived->finalizers))
    {
      gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL
                  && ancestor_wrapper->expr_type == EXPR_VARIABLE);
      vtab_final->initializer = gfc_copy_expr (ancestor_wrapper);
      vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym;
      return;
    }

  /* We now create a wrapper, which does the following:
     1. Call the suitable finalization subroutine for this type
     2. Loop over all noninherited allocatable components and noninherited
        components with allocatable components and DEALLOCATE those; this will
        take care of finalizers, coarray deregistering and allocatable
        nested components.
     3. Call the ancestor's finalizer.  */

  /* Declare the wrapper function; it takes an assumed-rank array
     and a VALUE logical as arguments. */

  /* Set up the namespace.  */
  sub_ns = gfc_get_namespace (ns, 0);
  sub_ns->sibling = ns->contained;
  if (!expr_null_wrapper)
    ns->contained = sub_ns;
  sub_ns->resolved = 1;

  /* Set up the procedure symbol.  */
  sprintf (name, "__final_%s", tname);
  gfc_get_symbol (name, sub_ns, &final);
  sub_ns->proc_name = final;
  final->attr.flavor = FL_PROCEDURE;
  final->attr.function = 1;
  final->attr.pure = 0;
  final->result = final;
  final->ts.type = BT_INTEGER;
  final->ts.kind = 4;
  final->attr.artificial = 1;
  final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL;
  if (ns->proc_name->attr.flavor == FL_MODULE)
    final->module = ns->proc_name->name;
  gfc_set_sym_referenced (final);
  gfc_commit_symbol (final);

  /* Set up formal argument.  */
  gfc_get_symbol ("array", sub_ns, &array);
  array->ts.type = BT_DERIVED;
  array->ts.u.derived = derived;
  array->attr.flavor = FL_VARIABLE;
  array->attr.dummy = 1;
  array->attr.contiguous = 1;
  array->attr.dimension = 1;
  array->attr.artificial = 1;
  array->as = gfc_get_array_spec();
  array->as->type = AS_ASSUMED_RANK;
  array->as->rank = -1;
  array->attr.intent = INTENT_INOUT;
  gfc_set_sym_referenced (array);
  final->formal = gfc_get_formal_arglist ();
  final->formal->sym = array;
  gfc_commit_symbol (array);

  /* Set up formal argument.  */
  gfc_get_symbol ("byte_stride", sub_ns, &byte_stride);
  byte_stride->ts.type = BT_INTEGER;
  byte_stride->ts.kind = gfc_index_integer_kind;
  byte_stride->attr.flavor = FL_VARIABLE;
  byte_stride->attr.dummy = 1;
  byte_stride->attr.value = 1;
  byte_stride->attr.artificial = 1;
  gfc_set_sym_referenced (byte_stride);
  final->formal->next = gfc_get_formal_arglist ();
  final->formal->next->sym = byte_stride;
  gfc_commit_symbol (byte_stride);

  /* Set up formal argument.  */
  gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray);
  fini_coarray->ts.type = BT_LOGICAL;
  fini_coarray->ts.kind = 1;
  fini_coarray->attr.flavor = FL_VARIABLE;
  fini_coarray->attr.dummy = 1;
  fini_coarray->attr.value = 1;
  fini_coarray->attr.artificial = 1;
  gfc_set_sym_referenced (fini_coarray);
  final->formal->next->next = gfc_get_formal_arglist ();
  final->formal->next->next->sym = fini_coarray;
  gfc_commit_symbol (fini_coarray);

  /* Return with a NULL() expression but with an interface which has
     the formal arguments.  */
  if (expr_null_wrapper)
    {
      vtab_final->initializer = gfc_get_null_expr (NULL);
      vtab_final->ts.interface = final;
      return;
    }

  /* Local variables.  */

  gfc_get_symbol ("idx", sub_ns, &idx);
  idx->ts.type = BT_INTEGER;
  idx->ts.kind = gfc_index_integer_kind;
  idx->attr.flavor = FL_VARIABLE;
  idx->attr.artificial = 1;
  gfc_set_sym_referenced (idx);
  gfc_commit_symbol (idx);

  gfc_get_symbol ("idx2", sub_ns, &idx2);
  idx2->ts.type = BT_INTEGER;
  idx2->ts.kind = gfc_index_integer_kind;
  idx2->attr.flavor = FL_VARIABLE;
  idx2->attr.artificial = 1;
  gfc_set_sym_referenced (idx2);
  gfc_commit_symbol (idx2);

  gfc_get_symbol ("offset", sub_ns, &offset);
  offset->ts.type = BT_INTEGER;
  offset->ts.kind = gfc_index_integer_kind;
  offset->attr.flavor = FL_VARIABLE;
  offset->attr.artificial = 1;
  gfc_set_sym_referenced (offset);
  gfc_commit_symbol (offset);

  /* Create RANK expression.  */
  rank = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_RANK, "rank",
                                   gfc_current_locus, 1,
                                   gfc_lval_expr_from_sym (array));
  if (rank->ts.kind != idx->ts.kind)
    gfc_convert_type_warn (rank, &idx->ts, 2, 0);

  /* Create is_contiguous variable.  */
  gfc_get_symbol ("is_contiguous", sub_ns, &is_contiguous);
  is_contiguous->ts.type = BT_LOGICAL;
  is_contiguous->ts.kind = gfc_default_logical_kind;
  is_contiguous->attr.flavor = FL_VARIABLE;
  is_contiguous->attr.artificial = 1;
  gfc_set_sym_referenced (is_contiguous);
  gfc_commit_symbol (is_contiguous);

  /* Create "sizes(0..rank)" variable, which contains the multiplied
     up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
     sizes(2) = sizes(1) * extent(dim=2) etc.  */
  gfc_get_symbol ("sizes", sub_ns, &sizes);
  sizes->ts.type = BT_INTEGER;
  sizes->ts.kind = gfc_index_integer_kind;
  sizes->attr.flavor = FL_VARIABLE;
  sizes->attr.dimension = 1;
  sizes->attr.artificial = 1;
  sizes->as = gfc_get_array_spec();
  sizes->attr.intent = INTENT_INOUT;
  sizes->as->type = AS_EXPLICIT;
  sizes->as->rank = 1;
  sizes->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
  sizes->as->upper[0] = gfc_copy_expr (rank);
  gfc_set_sym_referenced (sizes);
  gfc_commit_symbol (sizes);

  /* Create "strides(1..rank)" variable, which contains the strides per
     dimension.  */
  gfc_get_symbol ("strides", sub_ns, &strides);
  strides->ts.type = BT_INTEGER;
  strides->ts.kind = gfc_index_integer_kind;
  strides->attr.flavor = FL_VARIABLE;
  strides->attr.dimension = 1;
  strides->attr.artificial = 1;
  strides->as = gfc_get_array_spec();
  strides->attr.intent = INTENT_INOUT;
  strides->as->type = AS_EXPLICIT;
  strides->as->rank = 1;
  strides->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
  strides->as->upper[0] = gfc_copy_expr (rank);
  gfc_set_sym_referenced (strides);
  gfc_commit_symbol (strides);


  /* Set return value to 0.  */
  last_code = gfc_get_code (EXEC_ASSIGN);
  last_code->expr1 = gfc_lval_expr_from_sym (final);
  last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
  sub_ns->code = last_code;

  /* Set:  is_contiguous = .true.  */
  last_code->next = gfc_get_code (EXEC_ASSIGN);
  last_code = last_code->next;
  last_code->expr1 = gfc_lval_expr_from_sym (is_contiguous);
  last_code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
                                           &gfc_current_locus, true);

  /* Set:  sizes(0) = 1.  */
  last_code->next = gfc_get_code (EXEC_ASSIGN);
  last_code = last_code->next;
  last_code->expr1 = gfc_lval_expr_from_sym (sizes);
  last_code->expr1->ref = gfc_get_ref ();
  last_code->expr1->ref->type = REF_ARRAY;
  last_code->expr1->ref->u.ar.type = AR_ELEMENT;
  last_code->expr1->ref->u.ar.dimen = 1;
  last_code->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
  last_code->expr1->ref->u.ar.start[0]
                = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
  last_code->expr1->ref->u.ar.as = sizes->as;
  last_code->expr2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);

  /* Create:
     DO idx = 1, rank
       strides(idx) = _F._stride (array, dim=idx)
       sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
       if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
     END DO.  */

  /* Create loop.  */
  iter = gfc_get_iterator ();
  iter->var = gfc_lval_expr_from_sym (idx);
  iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
  iter->end = gfc_copy_expr (rank);
  iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
  last_code->next = gfc_get_code (EXEC_DO);
  last_code = last_code->next;
  last_code->ext.iterator = iter;
  last_code->block = gfc_get_code (EXEC_DO);

  /* strides(idx) = _F._stride(array,dim=idx). */
  last_code->block->next = gfc_get_code (EXEC_ASSIGN);
  block = last_code->block->next;

  block->expr1 = gfc_lval_expr_from_sym (strides);
  block->expr1->ref = gfc_get_ref ();
  block->expr1->ref->type = REF_ARRAY;
  block->expr1->ref->u.ar.type = AR_ELEMENT;
  block->expr1->ref->u.ar.dimen = 1;
  block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
  block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
  block->expr1->ref->u.ar.as = strides->as;

  block->expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STRIDE, "stride",
                                           gfc_current_locus, 2,
                                           gfc_lval_expr_from_sym (array),
                                           gfc_lval_expr_from_sym (idx));

  /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
  block->next = gfc_get_code (EXEC_ASSIGN);
  block = block->next;

  /* sizes(idx) = ... */
  block->expr1 = gfc_lval_expr_from_sym (sizes);
  block->expr1->ref = gfc_get_ref ();
  block->expr1->ref->type = REF_ARRAY;
  block->expr1->ref->u.ar.type = AR_ELEMENT;
  block->expr1->ref->u.ar.dimen = 1;
  block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
  block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
  block->expr1->ref->u.ar.as = sizes->as;

  block->expr2 = gfc_get_expr ();
  block->expr2->expr_type = EXPR_OP;
  block->expr2->value.op.op = INTRINSIC_TIMES;

  /* sizes(idx-1). */
  block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
  block->expr2->value.op.op1->ref = gfc_get_ref ();
  block->expr2->value.op.op1->ref->type = REF_ARRAY;
  block->expr2->value.op.op1->ref->u.ar.as = sizes->as;
  block->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
  block->expr2->value.op.op1->ref->u.ar.dimen = 1;
  block->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
  block->expr2->value.op.op1->ref->u.ar.start[0] = gfc_get_expr ();
  block->expr2->value.op.op1->ref->u.ar.start[0]->expr_type = EXPR_OP;
  block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
  block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1
        = gfc_lval_expr_from_sym (idx);
  block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op2
        = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
  block->expr2->value.op.op1->ref->u.ar.start[0]->ts
        = block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1->ts;

  /* size(array, dim=idx, kind=index_kind).  */
  block->expr2->value.op.op2
        = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
                                    gfc_current_locus, 3,
                                    gfc_lval_expr_from_sym (array),
                                    gfc_lval_expr_from_sym (idx),
                                    gfc_get_int_expr (gfc_index_integer_kind,
                                                      NULL,
                                                      gfc_index_integer_kind));
  block->expr2->value.op.op2->ts.kind = gfc_index_integer_kind;
  block->expr2->ts = idx->ts;

  /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false.  */
  block->next = gfc_get_code (EXEC_IF);
  block = block->next;

  block->block = gfc_get_code (EXEC_IF);
  block = block->block;

  /* if condition: strides(idx) /= sizes(idx-1).  */
  block->expr1 = gfc_get_expr ();
  block->expr1->ts.type = BT_LOGICAL;
  block->expr1->ts.kind = gfc_default_logical_kind;
  block->expr1->expr_type = EXPR_OP;
  block->expr1->where = gfc_current_locus;
  block->expr1->value.op.op = INTRINSIC_NE;

  block->expr1->value.op.op1 = gfc_lval_expr_from_sym (strides);
  block->expr1->value.op.op1->ref = gfc_get_ref ();
  block->expr1->value.op.op1->ref->type = REF_ARRAY;
  block->expr1->value.op.op1->ref->u.ar.type = AR_ELEMENT;
  block->expr1->value.op.op1->ref->u.ar.dimen = 1;
  block->expr1->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
  block->expr1->value.op.op1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
  block->expr1->value.op.op1->ref->u.ar.as = strides->as;

  block->expr1->value.op.op2 = gfc_lval_expr_from_sym (sizes);
  block->expr1->value.op.op2->ref = gfc_get_ref ();
  block->expr1->value.op.op2->ref->type = REF_ARRAY;
  block->expr1->value.op.op2->ref->u.ar.as = sizes->as;
  block->expr1->value.op.op2->ref->u.ar.type = AR_ELEMENT;
  block->expr1->value.op.op2->ref->u.ar.dimen = 1;
  block->expr1->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
  block->expr1->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
  block->expr1->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
  block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
  block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1
        = gfc_lval_expr_from_sym (idx);
  block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op2
        = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
  block->expr1->value.op.op2->ref->u.ar.start[0]->ts
        = block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;

  /* if body: is_contiguous = .false.  */
  block->next = gfc_get_code (EXEC_ASSIGN);
  block = block->next;
  block->expr1 = gfc_lval_expr_from_sym (is_contiguous);
  block->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
                                       &gfc_current_locus, false);

  /* Obtain the size (number of elements) of "array" MINUS ONE,
     which is used in the scalarization.  */
  gfc_get_symbol ("nelem", sub_ns, &nelem);
  nelem->ts.type = BT_INTEGER;
  nelem->ts.kind = gfc_index_integer_kind;
  nelem->attr.flavor = FL_VARIABLE;
  nelem->attr.artificial = 1;
  gfc_set_sym_referenced (nelem);
  gfc_commit_symbol (nelem);

  /* nelem = sizes (rank) - 1.  */
  last_code->next = gfc_get_code (EXEC_ASSIGN);
  last_code = last_code->next;

  last_code->expr1 = gfc_lval_expr_from_sym (nelem);

  last_code->expr2 = gfc_get_expr ();
  last_code->expr2->expr_type = EXPR_OP;
  last_code->expr2->value.op.op = INTRINSIC_MINUS;
  last_code->expr2->value.op.op2
        = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
  last_code->expr2->ts = last_code->expr2->value.op.op2->ts;

  last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
  last_code->expr2->value.op.op1->ref = gfc_get_ref ();
  last_code->expr2->value.op.op1->ref->type = REF_ARRAY;
  last_code->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
  last_code->expr2->value.op.op1->ref->u.ar.dimen = 1;
  last_code->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
  last_code->expr2->value.op.op1->ref->u.ar.start[0] = gfc_copy_expr (rank);
  last_code->expr2->value.op.op1->ref->u.ar.as = sizes->as;

  /* Call final subroutines. We now generate code like:
     use iso_c_binding
     integer, pointer :: ptr
     type(c_ptr) :: cptr
     integer(c_intptr_t) :: i, addr

     select case (rank (array))
       case (3)
         ! If needed, the array is packed
         call final_rank3 (array)
       case default:
         do i = 0, size (array)-1
           addr = transfer (c_loc (array), addr) + i * stride
           call c_f_pointer (transfer (addr, cptr), ptr)
           call elemental_final (ptr)
         end do
     end select */

  if (derived->f2k_derived && derived->f2k_derived->finalizers)
    {
      gfc_finalizer *fini, *fini_elem = NULL;

      gfc_get_symbol ("ptr", sub_ns, &ptr);
      ptr->ts.type = BT_DERIVED;
      ptr->ts.u.derived = derived;
      ptr->attr.flavor = FL_VARIABLE;
      ptr->attr.pointer = 1;
      ptr->attr.artificial = 1;
      gfc_set_sym_referenced (ptr);
      gfc_commit_symbol (ptr);

      /* SELECT CASE (RANK (array)).  */
      last_code->next = gfc_get_code (EXEC_SELECT);
      last_code = last_code->next;
      last_code->expr1 = gfc_copy_expr (rank);
      block = NULL;

      for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next)
        {
          if (!fini->proc_tree)
            fini->proc_tree = gfc_find_sym_in_symtree (fini->proc_sym);
          if (fini->proc_tree->n.sym->attr.elemental)
            {
              fini_elem = fini;
              continue;
            }

          /* CASE (fini_rank).  */
          if (block)
            {
              block->block = gfc_get_code (EXEC_SELECT);
              block = block->block;
            }
          else
            {
              block = gfc_get_code (EXEC_SELECT);
              last_code->block = block;
            }
          block->ext.block.case_list = gfc_get_case ();
          block->ext.block.case_list->where = gfc_current_locus;
          if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
            block->ext.block.case_list->low
             = gfc_get_int_expr (gfc_default_integer_kind, NULL,
                                 fini->proc_tree->n.sym->formal->sym->as->rank);
          else
            block->ext.block.case_list->low
                = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
          block->ext.block.case_list->high
                = gfc_copy_expr (block->ext.block.case_list->low);

          /* CALL fini_rank (array) - possibly with packing.  */
          if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
            finalizer_insert_packed_call (block, fini, array, byte_stride,
                                          idx, ptr, nelem, strides,
                                          sizes, idx2, offset, is_contiguous,
                                          rank, sub_ns);
          else
            {
              block->next = gfc_get_code (EXEC_CALL);
              block->next->symtree = fini->proc_tree;
              block->next->resolved_sym = fini->proc_tree->n.sym;
              block->next->ext.actual = gfc_get_actual_arglist ();
              block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
            }
        }

      /* Elemental call - scalarized.  */
      if (fini_elem)
        {
          /* CASE DEFAULT.  */
          if (block)
            {
              block->block = gfc_get_code (EXEC_SELECT);
              block = block->block;
            }
          else
            {
              block = gfc_get_code (EXEC_SELECT);
              last_code->block = block;
            }
          block->ext.block.case_list = gfc_get_case ();

          /* Create loop.  */
          iter = gfc_get_iterator ();
          iter->var = gfc_lval_expr_from_sym (idx);
          iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
          iter->end = gfc_lval_expr_from_sym (nelem);
          iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
          block->next = gfc_get_code (EXEC_DO);
          block = block->next;
          block->ext.iterator = iter;
          block->block = gfc_get_code (EXEC_DO);

          /* Offset calculation.  */
          block = finalization_get_offset (idx, idx2, offset, strides, sizes,
                                           byte_stride, rank, block->block,
                                           sub_ns);

          /* Create code for
             CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
                               + offset, c_ptr), ptr).  */
          block->next
                = finalization_scalarizer (array, ptr,
                                           gfc_lval_expr_from_sym (offset),
                                           sub_ns);
          block = block->next;

          /* CALL final_elemental (array).  */
          block->next = gfc_get_code (EXEC_CALL);
          block = block->next;
          block->symtree = fini_elem->proc_tree;
          block->resolved_sym = fini_elem->proc_sym;
          block->ext.actual = gfc_get_actual_arglist ();
          block->ext.actual->expr = gfc_lval_expr_from_sym (ptr);
        }
    }

  /* Finalize and deallocate allocatable components. The same manual
     scalarization is used as above.  */

  if (finalizable_comp)
    {
      gfc_symbol *stat;
      gfc_code *block = NULL;

      if (!ptr)
        {
          gfc_get_symbol ("ptr", sub_ns, &ptr);
          ptr->ts.type = BT_DERIVED;
          ptr->ts.u.derived = derived;
          ptr->attr.flavor = FL_VARIABLE;
          ptr->attr.pointer = 1;
          ptr->attr.artificial = 1;
          gfc_set_sym_referenced (ptr);
          gfc_commit_symbol (ptr);
        }

      gfc_get_symbol ("ignore", sub_ns, &stat);
      stat->attr.flavor = FL_VARIABLE;
      stat->attr.artificial = 1;
      stat->ts.type = BT_INTEGER;
      stat->ts.kind = gfc_default_integer_kind;
      gfc_set_sym_referenced (stat);
      gfc_commit_symbol (stat);

      /* Create loop.  */
      iter = gfc_get_iterator ();
      iter->var = gfc_lval_expr_from_sym (idx);
      iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
      iter->end = gfc_lval_expr_from_sym (nelem);
      iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
      last_code->next = gfc_get_code (EXEC_DO);
      last_code = last_code->next;
      last_code->ext.iterator = iter;
      last_code->block = gfc_get_code (EXEC_DO);

      /* Offset calculation.  */
      block = finalization_get_offset (idx, idx2, offset, strides, sizes,
                                       byte_stride, rank, last_code->block,
                                       sub_ns);

      /* Create code for
         CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
                           + idx * stride, c_ptr), ptr).  */
      block->next = finalization_scalarizer (array, ptr,
                                             gfc_lval_expr_from_sym(offset),
                                             sub_ns);
      block = block->next;

      for (comp = derived->components; comp; comp = comp->next)
        {
          if (comp == derived->components && derived->attr.extension
              && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
            continue;

          finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp,
                              stat, fini_coarray, &block);
          if (!last_code->block->next)
            last_code->block->next = block;
        }

    }

  /* Call the finalizer of the ancestor.  */
  if (ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
    {
      last_code->next = gfc_get_code (EXEC_CALL);
      last_code = last_code->next;
      last_code->symtree = ancestor_wrapper->symtree;
      last_code->resolved_sym = ancestor_wrapper->symtree->n.sym;

      last_code->ext.actual = gfc_get_actual_arglist ();
      last_code->ext.actual->expr = gfc_lval_expr_from_sym (array);
      last_code->ext.actual->next = gfc_get_actual_arglist ();
      last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (byte_stride);
      last_code->ext.actual->next->next = gfc_get_actual_arglist ();
      last_code->ext.actual->next->next->expr
                        = gfc_lval_expr_from_sym (fini_coarray);
    }

  gfc_free_expr (rank);
  vtab_final->initializer = gfc_lval_expr_from_sym (final);
  vtab_final->ts.interface = final;
}


/* Add procedure pointers for all type-bound procedures to a vtab.  */

static void
add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
{
  gfc_symbol* super_type;

  super_type = gfc_get_derived_super_type (derived);

  if (super_type && (super_type != derived))
    {
      /* Make sure that the PPCs appear in the same order as in the parent.  */
      copy_vtab_proc_comps (super_type, vtype);
      /* Only needed to get the PPC initializers right.  */
      add_procs_to_declared_vtab (super_type, vtype);
    }

  if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
    add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);

  if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
    add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
}


/* Find or generate the symbol for a derived type's vtab.  */

gfc_symbol *
gfc_find_derived_vtab (gfc_symbol *derived)
{
  gfc_namespace *ns;
  gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
  gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;

  /* Find the top-level namespace.  */
  for (ns = gfc_current_ns; ns; ns = ns->parent)
    if (!ns->parent)
      break;

  /* If the type is a class container, use the underlying derived type.  */
  if (!derived->attr.unlimited_polymorphic && derived->attr.is_class)
    derived = gfc_get_derived_super_type (derived);

  if (ns)
    {
      char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];

      get_unique_hashed_string (tname, derived);
      sprintf (name, "__vtab_%s", tname);

      /* Look for the vtab symbol in various namespaces.  */
      gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
      if (vtab == NULL)
        gfc_find_symbol (name, ns, 0, &vtab);
      if (vtab == NULL)
        gfc_find_symbol (name, derived->ns, 0, &vtab);

      if (vtab == NULL)
        {
          gfc_get_symbol (name, ns, &vtab);
          vtab->ts.type = BT_DERIVED;
          if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
                               &gfc_current_locus))
            goto cleanup;
          vtab->attr.target = 1;
          vtab->attr.save = SAVE_IMPLICIT;
          vtab->attr.vtab = 1;
          vtab->attr.access = ACCESS_PUBLIC;
          gfc_set_sym_referenced (vtab);
          sprintf (name, "__vtype_%s", tname);

          gfc_find_symbol (name, ns, 0, &vtype);
          if (vtype == NULL)
            {
              gfc_component *c;
              gfc_symbol *parent = NULL, *parent_vtab = NULL;

              gfc_get_symbol (name, ns, &vtype);
              if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
                                   &gfc_current_locus))
                goto cleanup;
              vtype->attr.access = ACCESS_PUBLIC;
              vtype->attr.vtype = 1;
              gfc_set_sym_referenced (vtype);

              /* Add component '_hash'.  */
              if (!gfc_add_component (vtype, "_hash", &c))
                goto cleanup;
              c->ts.type = BT_INTEGER;
              c->ts.kind = 4;
              c->attr.access = ACCESS_PRIVATE;
              c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
                                                 NULL, derived->hash_value);

              /* Add component '_size'.  */
              if (!gfc_add_component (vtype, "_size", &c))
                goto cleanup;
              c->ts.type = BT_INTEGER;
              c->ts.kind = 4;
              c->attr.access = ACCESS_PRIVATE;
              /* Remember the derived type in ts.u.derived,
                 so that the correct initializer can be set later on
                 (in gfc_conv_structure).  */
              c->ts.u.derived = derived;
              c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
                                                 NULL, 0);

              /* Add component _extends.  */
              if (!gfc_add_component (vtype, "_extends", &c))
                goto cleanup;
              c->attr.pointer = 1;
              c->attr.access = ACCESS_PRIVATE;
              if (!derived->attr.unlimited_polymorphic)
                parent = gfc_get_derived_super_type (derived);
              else
                parent = NULL;

              if (parent)
                {
                  parent_vtab = gfc_find_derived_vtab (parent);
                  c->ts.type = BT_DERIVED;
                  c->ts.u.derived = parent_vtab->ts.u.derived;
                  c->initializer = gfc_get_expr ();
                  c->initializer->expr_type = EXPR_VARIABLE;
                  gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
                                     0, &c->initializer->symtree);
                }
              else
                {
                  c->ts.type = BT_DERIVED;
                  c->ts.u.derived = vtype;
                  c->initializer = gfc_get_null_expr (NULL);
                }

              if (!derived->attr.unlimited_polymorphic
                  && derived->components == NULL
                  && !derived->attr.zero_comp)
                {
                  /* At this point an error must have occurred.
                     Prevent further errors on the vtype components.  */
                  found_sym = vtab;
                  goto have_vtype;
                }

              /* Add component _def_init.  */
              if (!gfc_add_component (vtype, "_def_init", &c))
                goto cleanup;
              c->attr.pointer = 1;
              c->attr.artificial = 1;
              c->attr.access = ACCESS_PRIVATE;
              c->ts.type = BT_DERIVED;
              c->ts.u.derived = derived;
              if (derived->attr.unlimited_polymorphic
                  || derived->attr.abstract)
                c->initializer = gfc_get_null_expr (NULL);
              else
                {
                  /* Construct default initialization variable.  */
                  sprintf (name, "__def_init_%s", tname);
                  gfc_get_symbol (name, ns, &def_init);
                  def_init->attr.target = 1;
                  def_init->attr.artificial = 1;
                  def_init->attr.save = SAVE_IMPLICIT;
                  def_init->attr.access = ACCESS_PUBLIC;
                  def_init->attr.flavor = FL_VARIABLE;
                  gfc_set_sym_referenced (def_init);
                  def_init->ts.type = BT_DERIVED;
                  def_init->ts.u.derived = derived;
                  def_init->value = gfc_default_initializer (&def_init->ts);

                  c->initializer = gfc_lval_expr_from_sym (def_init);
                }

              /* Add component _copy.  */
              if (!gfc_add_component (vtype, "_copy", &c))
                goto cleanup;
              c->attr.proc_pointer = 1;
              c->attr.access = ACCESS_PRIVATE;
              c->tb = XCNEW (gfc_typebound_proc);
              c->tb->ppc = 1;
              if (derived->attr.unlimited_polymorphic
                  || derived->attr.abstract)
                c->initializer = gfc_get_null_expr (NULL);
              else
                {
                  /* Set up namespace.  */
                  gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
                  sub_ns->sibling = ns->contained;
                  ns->contained = sub_ns;
                  sub_ns->resolved = 1;
                  /* Set up procedure symbol.  */
                  sprintf (name, "__copy_%s", tname);
                  gfc_get_symbol (name, sub_ns, &copy);
                  sub_ns->proc_name = copy;
                  copy->attr.flavor = FL_PROCEDURE;
                  copy->attr.subroutine = 1;
                  copy->attr.pure = 1;
                  copy->attr.artificial = 1;
                  copy->attr.if_source = IFSRC_DECL;
                  /* This is elemental so that arrays are automatically
                     treated correctly by the scalarizer.  */
                  copy->attr.elemental = 1;
                  if (ns->proc_name->attr.flavor == FL_MODULE)
                    copy->module = ns->proc_name->name;
                  gfc_set_sym_referenced (copy);
                  /* Set up formal arguments.  */
                  gfc_get_symbol ("src", sub_ns, &src);
                  src->ts.type = BT_DERIVED;
                  src->ts.u.derived = derived;
                  src->attr.flavor = FL_VARIABLE;
                  src->attr.dummy = 1;
                  src->attr.artificial = 1;
                  src->attr.intent = INTENT_IN;
                  gfc_set_sym_referenced (src);
                  copy->formal = gfc_get_formal_arglist ();
                  copy->formal->sym = src;
                  gfc_get_symbol ("dst", sub_ns, &dst);
                  dst->ts.type = BT_DERIVED;
                  dst->ts.u.derived = derived;
                  dst->attr.flavor = FL_VARIABLE;
                  dst->attr.dummy = 1;
                  dst->attr.artificial = 1;
                  dst->attr.intent = INTENT_INOUT;
                  gfc_set_sym_referenced (dst);
                  copy->formal->next = gfc_get_formal_arglist ();
                  copy->formal->next->sym = dst;
                  /* Set up code.  */
                  sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN);
                  sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
                  sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
                  /* Set initializer.  */
                  c->initializer = gfc_lval_expr_from_sym (copy);
                  c->ts.interface = copy;
                }

              /* Add component _final, which contains a procedure pointer to
                 a wrapper which handles both the freeing of allocatable
                 components and the calls to finalization subroutines.
                 Note: The actual wrapper function can only be generated
                 at resolution time.  */
              if (!gfc_add_component (vtype, "_final", &c))
                goto cleanup;
              c->attr.proc_pointer = 1;
              c->attr.access = ACCESS_PRIVATE;
              c->tb = XCNEW (gfc_typebound_proc);
              c->tb->ppc = 1;
              generate_finalization_wrapper (derived, ns, tname, c);

              /* Add procedure pointers for type-bound procedures.  */
              if (!derived->attr.unlimited_polymorphic)
                add_procs_to_declared_vtab (derived, vtype);
          }

have_vtype:
          vtab->ts.u.derived = vtype;
          vtab->value = gfc_default_initializer (&vtab->ts);
        }
    }

  found_sym = vtab;

cleanup:
  /* It is unexpected to have some symbols added at resolution or code
     generation time. We commit the changes in order to keep a clean state.  */
  if (found_sym)
    {
      gfc_commit_symbol (vtab);
      if (vtype)
        gfc_commit_symbol (vtype);
      if (def_init)
        gfc_commit_symbol (def_init);
      if (copy)
        gfc_commit_symbol (copy);
      if (src)
        gfc_commit_symbol (src);
      if (dst)
        gfc_commit_symbol (dst);
    }
  else
    gfc_undo_symbols ();

  return found_sym;
}


/* Check if a derived type is finalizable. That is the case if it
   (1) has a FINAL subroutine or
   (2) has a nonpointer nonallocatable component of finalizable type.
   If it is finalizable, return an expression containing the
   finalization wrapper.  */

bool
gfc_is_finalizable (gfc_symbol *derived, gfc_expr **final_expr)
{
  gfc_symbol *vtab;
  gfc_component *c;

  /* (1) Check for FINAL subroutines.  */
  if (derived->f2k_derived && derived->f2k_derived->finalizers)
    goto yes;

  /* (2) Check for components of finalizable type.  */
  for (c = derived->components; c; c = c->next)
    if (c->ts.type == BT_DERIVED
        && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
        && gfc_is_finalizable (c->ts.u.derived, NULL))
      goto yes;

  return false;

yes:
  /* Make sure vtab is generated.  */
  vtab = gfc_find_derived_vtab (derived);
  if (final_expr)
    {
      /* Return finalizer expression.  */
      gfc_component *final;
      final = vtab->ts.u.derived->components->next->next->next->next->next;
      gcc_assert (strcmp (final->name, "_final") == 0);
      gcc_assert (final->initializer
                  && final->initializer->expr_type != EXPR_NULL);
      *final_expr = final->initializer;
    }
  return true;
}


/* Find (or generate) the symbol for an intrinsic type's vtab.  This is
   need to support unlimited polymorphism.  */

gfc_symbol *
gfc_find_intrinsic_vtab (gfc_typespec *ts)
{
  gfc_namespace *ns;
  gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
  gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
  int charlen = 0;

  if (ts->type == BT_CHARACTER && ts->deferred)
    {
      gfc_error ("TODO: Deferred character length variable at %C cannot "
                 "yet be associated with unlimited polymorphic entities");
      return NULL;
    }

  if (ts->type == BT_UNKNOWN)
    return NULL;

  /* Sometimes the typespec is passed from a single call.  */
  if (ts->type == BT_DERIVED)
    return gfc_find_derived_vtab (ts->u.derived);

  /* Find the top-level namespace.  */
  for (ns = gfc_current_ns; ns; ns = ns->parent)
    if (!ns->parent)
      break;

  if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
      && ts->u.cl->length->expr_type == EXPR_CONSTANT)
    charlen = mpz_get_si (ts->u.cl->length->value.integer);

  if (ns)
    {
      char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];

      if (ts->type == BT_CHARACTER)
        sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type),
                 charlen, ts->kind);
      else
        sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);

      sprintf (name, "__vtab_%s", tname);

      /* Look for the vtab symbol in various namespaces.  */
      gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
      if (vtab == NULL)
        gfc_find_symbol (name, ns, 0, &vtab);

      if (vtab == NULL)
        {
          gfc_get_symbol (name, ns, &vtab);
          vtab->ts.type = BT_DERIVED;
          if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
                               &gfc_current_locus))
            goto cleanup;
          vtab->attr.target = 1;
          vtab->attr.save = SAVE_IMPLICIT;
          vtab->attr.vtab = 1;
          vtab->attr.access = ACCESS_PUBLIC;
          gfc_set_sym_referenced (vtab);
          sprintf (name, "__vtype_%s", tname);

          gfc_find_symbol (name, ns, 0, &vtype);
          if (vtype == NULL)
            {
              gfc_component *c;
              int hash;
              gfc_namespace *sub_ns;
              gfc_namespace *contained;
              gfc_expr *e;

              gfc_get_symbol (name, ns, &vtype);
              if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
                                   &gfc_current_locus))
                goto cleanup;
              vtype->attr.access = ACCESS_PUBLIC;
              vtype->attr.vtype = 1;
              gfc_set_sym_referenced (vtype);

              /* Add component '_hash'.  */
              if (!gfc_add_component (vtype, "_hash", &c))
                goto cleanup;
              c->ts.type = BT_INTEGER;
              c->ts.kind = 4;
              c->attr.access = ACCESS_PRIVATE;
              hash = gfc_intrinsic_hash_value (ts);
              c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
                                                 NULL, hash);

              /* Add component '_size'.  */
              if (!gfc_add_component (vtype, "_size", &c))
                goto cleanup;
              c->ts.type = BT_INTEGER;
              c->ts.kind = 4;
              c->attr.access = ACCESS_PRIVATE;

              /* Build a minimal expression to make use of
                 target-memory.c/gfc_element_size for 'size'. */
              e = gfc_get_expr ();
              e->ts = *ts;
              e->expr_type = EXPR_VARIABLE;
              c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
                                                 NULL,
                                                 (int)gfc_element_size (e));
              gfc_free_expr (e);

              /* Add component _extends.  */
              if (!gfc_add_component (vtype, "_extends", &c))
                goto cleanup;
              c->attr.pointer = 1;
              c->attr.access = ACCESS_PRIVATE;
              c->ts.type = BT_VOID;
              c->initializer = gfc_get_null_expr (NULL);

              /* Add component _def_init.  */
              if (!gfc_add_component (vtype, "_def_init", &c))
                goto cleanup;
              c->attr.pointer = 1;
              c->attr.access = ACCESS_PRIVATE;
              c->ts.type = BT_VOID;
              c->initializer = gfc_get_null_expr (NULL);

              /* Add component _copy.  */
              if (!gfc_add_component (vtype, "_copy", &c))
                goto cleanup;
              c->attr.proc_pointer = 1;
              c->attr.access = ACCESS_PRIVATE;
              c->tb = XCNEW (gfc_typebound_proc);
              c->tb->ppc = 1;

              /* Check to see if copy function already exists.  Note
                 that this is only used for characters of different
                 lengths.  */
              contained = ns->contained;
              for (; contained; contained = contained->sibling)
                if (contained->proc_name
                    && strcmp (name, contained->proc_name->name) == 0)
                  {
                    copy = contained->proc_name;
                    goto got_char_copy;
                  }

              /* Set up namespace.  */
              sub_ns = gfc_get_namespace (ns, 0);
              sub_ns->sibling = ns->contained;
              ns->contained = sub_ns;
              sub_ns->resolved = 1;
              /* Set up procedure symbol.  */
              if (ts->type != BT_CHARACTER)
                sprintf (name, "__copy_%s", tname);
              else
                /* __copy is always the same for characters.  */
                sprintf (name, "__copy_character_%d", ts->kind);
              gfc_get_symbol (name, sub_ns, &copy);
              sub_ns->proc_name = copy;
              copy->attr.flavor = FL_PROCEDURE;
              copy->attr.subroutine = 1;
              copy->attr.pure = 1;
              copy->attr.if_source = IFSRC_DECL;
              /* This is elemental so that arrays are automatically
                 treated correctly by the scalarizer.  */
              copy->attr.elemental = 1;
              if (ns->proc_name->attr.flavor == FL_MODULE)
                copy->module = ns->proc_name->name;
                  gfc_set_sym_referenced (copy);
              /* Set up formal arguments.  */
              gfc_get_symbol ("src", sub_ns, &src);
              src->ts.type = ts->type;
              src->ts.kind = ts->kind;
              src->attr.flavor = FL_VARIABLE;
              src->attr.dummy = 1;
              src->attr.intent = INTENT_IN;
              gfc_set_sym_referenced (src);
              copy->formal = gfc_get_formal_arglist ();
              copy->formal->sym = src;
              gfc_get_symbol ("dst", sub_ns, &dst);
              dst->ts.type = ts->type;
              dst->ts.kind = ts->kind;
              dst->attr.flavor = FL_VARIABLE;
              dst->attr.dummy = 1;
              dst->attr.intent = INTENT_INOUT;
              gfc_set_sym_referenced (dst);
              copy->formal->next = gfc_get_formal_arglist ();
              copy->formal->next->sym = dst;
              /* Set up code.  */
              sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN);
              sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
              sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
            got_char_copy:
              /* Set initializer.  */
              c->initializer = gfc_lval_expr_from_sym (copy);
              c->ts.interface = copy;

              /* Add component _final.  */
              if (!gfc_add_component (vtype, "_final", &c))
                goto cleanup;
              c->attr.proc_pointer = 1;
              c->attr.access = ACCESS_PRIVATE;
              c->tb = XCNEW (gfc_typebound_proc);
              c->tb->ppc = 1;
              c->initializer = gfc_get_null_expr (NULL);
            }
          vtab->ts.u.derived = vtype;
          vtab->value = gfc_default_initializer (&vtab->ts);
        }
    }

  found_sym = vtab;

cleanup:
  /* It is unexpected to have some symbols added at resolution or code
     generation time. We commit the changes in order to keep a clean state.  */
  if (found_sym)
    {
      gfc_commit_symbol (vtab);
      if (vtype)
        gfc_commit_symbol (vtype);
      if (copy)
        gfc_commit_symbol (copy);
      if (src)
        gfc_commit_symbol (src);
      if (dst)
        gfc_commit_symbol (dst);
    }
  else
    gfc_undo_symbols ();

  return found_sym;
}


/* General worker function to find either a type-bound procedure or a
   type-bound user operator.  */

static gfc_symtree*
find_typebound_proc_uop (gfc_symbol* derived, bool* t,
                         const char* name, bool noaccess, bool uop,
                         locus* where)
{
  gfc_symtree* res;
  gfc_symtree* root;

  /* Set default to failure.  */
  if (t)
    *t = false;

  if (derived->f2k_derived)
    /* Set correct symbol-root.  */
    root = (uop ? derived->f2k_derived->tb_uop_root
                : derived->f2k_derived->tb_sym_root);
  else
    return NULL;

  /* Try to find it in the current type's namespace.  */
  res = gfc_find_symtree (root, name);
  if (res && res->n.tb && !res->n.tb->error)
    {
      /* We found one.  */
      if (t)
        *t = true;

      if (!noaccess && derived->attr.use_assoc
          && res->n.tb->access == ACCESS_PRIVATE)
        {
          if (where)
            gfc_error ("'%s' of '%s' is PRIVATE at %L",
                       name, derived->name, where);
          if (t)
            *t = false;
        }

      return res;
    }

  /* Otherwise, recurse on parent type if derived is an extension.  */
  if (derived->attr.extension)
    {
      gfc_symbol* super_type;
      super_type = gfc_get_derived_super_type (derived);
      gcc_assert (super_type);

      return find_typebound_proc_uop (super_type, t, name,
                                      noaccess, uop, where);
    }

  /* Nothing found.  */
  return NULL;
}


/* Find a type-bound procedure or user operator by name for a derived-type
   (looking recursively through the super-types).  */

gfc_symtree*
gfc_find_typebound_proc (gfc_symbol* derived, bool* t,
                         const char* name, bool noaccess, locus* where)
{
  return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
}

gfc_symtree*
gfc_find_typebound_user_op (gfc_symbol* derived, bool* t,
                            const char* name, bool noaccess, locus* where)
{
  return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
}


/* Find a type-bound intrinsic operator looking recursively through the
   super-type hierarchy.  */

gfc_typebound_proc*
gfc_find_typebound_intrinsic_op (gfc_symbol* derived, bool* t,
                                 gfc_intrinsic_op op, bool noaccess,
                                 locus* where)
{
  gfc_typebound_proc* res;

  /* Set default to failure.  */
  if (t)
    *t = false;

  /* Try to find it in the current type's namespace.  */
  if (derived->f2k_derived)
    res = derived->f2k_derived->tb_op[op];
  else
    res = NULL;

  /* Check access.  */
  if (res && !res->error)
    {
      /* We found one.  */
      if (t)
        *t = true;

      if (!noaccess && derived->attr.use_assoc
          && res->access == ACCESS_PRIVATE)
        {
          if (where)
            gfc_error ("'%s' of '%s' is PRIVATE at %L",
                       gfc_op2string (op), derived->name, where);
          if (t)
            *t = false;
        }

      return res;
    }

  /* Otherwise, recurse on parent type if derived is an extension.  */
  if (derived->attr.extension)
    {
      gfc_symbol* super_type;
      super_type = gfc_get_derived_super_type (derived);
      gcc_assert (super_type);

      return gfc_find_typebound_intrinsic_op (super_type, t, op,
                                              noaccess, where);
    }

  /* Nothing found.  */
  return NULL;
}


/* Get a typebound-procedure symtree or create and insert it if not yet
   present.  This is like a very simplified version of gfc_get_sym_tree for
   tbp-symtrees rather than regular ones.  */

gfc_symtree*
gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
{
  gfc_symtree *result;

  result = gfc_find_symtree (*root, name);
  if (!result)
    {
      result = gfc_new_symtree (root, name);
      gcc_assert (result);
      result->n.tb = NULL;
    }

  return result;
}