array.c (resolve_array_list): Apply C4106.

2012-12-19  Paul Thomas  <pault@gcc.gnu.org>

	* array.c (resolve_array_list): Apply C4106.
	* check.c (gfc_check_same_type_as): Exclude polymorphic
	entities from check for extensible types. Improved error
	for disallowed argument types to name the offending type.
	* class.c : Update copyright date.
	(gfc_class_null_initializer): Add argument for initialization
	expression and deal with unlimited polymorphic typespecs.
	(get_unique_type_string): Give unlimited polymorphic
	entities a type string.
	(gfc_intrinsic_hash_value): New function.
	(gfc_build_class_symbol): Incorporate unlimited polymorphic
	entities.
	(gfc_find_derived_vtab): Deal with unlimited polymorphic
	entities.
	(gfc_find_intrinsic_vtab): New function.
	* decl.c (gfc_match_decl_type_spec): Match typespec for
	unlimited polymorphic type.
	(gfc_match_data_decl): Skip to 'ok' if unlimited polymorphic.
	expr.c (gfc_check_pointer_assign): Apply C717.  If unlimited
	polymorphic lvalue, find rvalue vtable for all typespecs,
	except unlimited polymorphic expressions.
	(gfc_check_vardef_context): Handle unlimited polymorphic
	entities.
	* gfortran.h : Add unlimited polymorphic attribute. Add
	second arg to gfc_class_null_initializer primitive and
	primitive for gfc_find_intrinsic_vtab.  Add UNLIMITED_POLY
	to detect unlimited polymorphic expressions.
	* interface.c (gfc_compare_types): If expr1 is unlimited
	polymorphic, always return 1. If expr2 is unlimited polymorphic
	enforce C717.
	(gfc_compare_interfaces): Skip past conditions that do not
	apply for unlimited polymorphic entities.
	(compare_parameter): Make sure that an unlimited polymorphic,
	allocatable or pointer, formal argument is matched by an
	unlimited polymorphic actual argument.
	(compare_actual_formal): Ensure that an intrinsic vtable exists
	to match an unlimited polymorphic formal argument.
	* match.c (gfc_match_allocate): Type kind parameter does not
	need to match an unlimited polymorphic allocate-object.
	(alloc_opt_list): An unlimited polymorphic allocate-object
	requires a typespec or a SOURCE tag.
	(select_intrinsic_set_tmp): New function.
	(select_type_set_tmp): Call new function.  If it returns NULL,
	build a derived type or class temporary instead.
	(gfc_match_type_is): Remove restriction to derived types only.
	Bind(C) or sequence derived types not permitted.
	* misc (gfc_typename):  Printed CLASS(*) for unlimited
	polymorphism.
	* module.c : Add AB_UNLIMITED_POLY to pass unlimited
	polymorphic attribute to and from modules.
	* resolve.c (resolve_common_vars): Unlimited polymorphic
	entities cannot appear in common blocks.
	(resolve_deallocate_expr): Deallocate unlimited polymorphic
	enities.
	(resolve_allocate_expr): Likewise for allocation.  Make sure
	vtable exists.
	(gfc_type_is_extensible): Unlimited polymorphic entities are
	not extensible.
	(resolve_select_type): Handle unlimited polymorphic selectors.
	Ensure that length type parameters are assumed and that names
	for intrinsic types are generated.
	(resolve_fl_var_and_proc): Exclude select type temporaries
	from test of extensibility of type.
	(resolve_fl_variable): Likewise for test that assumed character
	length must be a dummy or a parameter.
	(resolve_fl_derived0): Return SUCCESS unconditionally for
	unlimited polymorphic entities. Also, allow unlimited
	polymorphic components.
	(resolve_fl_derived): Return SUCCESS unconditionally for
	unlimited polymorphic entities.
	(resolve_symbol): Return early with unlimited polymorphic
	entities.
	* simplifiy.c : Update copyright year.
	(gfc_simplify_extends_type_of): No simplification possible
	for unlimited polymorphic arguments.
	* symbol.c (gfc_use_derived): Nothing to do for unlimited
	polymorphic "derived type".
	(gfc_type_compatible): Return unity if ts1 is unlimited
	polymorphic.
	* trans-decl.c (create_function_arglist) Formal arguments
	without a character length should be treated in the same way
	as passed lengths.
	(gfc_trans_deferred_vars): Nullify the vptr of unlimited
	polymorphic pointers. Avoid unlimited polymorphic entities
	triggering gcc_unreachable.
	* trans-expr.c (gfc_conv_intrinsic_to_class): New function.
	(gfc_trans_class_init_assign): Make indirect reference of
	src.expr.
	(gfc_trans_class_assign): Expression NULL of unknown type
	should set NULL vptr on lhs. Treat C717 cases where lhs is
	a derived type and the rhs is unlimited polymorphic.
	(gfc_conv_procedure_call): Handle the conversion of a non-class
	actual argument to match an unlimited polymorphic formal
	argument.  Suppress the passing of a character string length
	in this case.  Make sure that calls to the character __copy
	function have two character string length arguments.
	(gfc_conv_initializer): Pass the initialization expression to
	gfc_class_null_initializer.
	(gfc_trans_subcomponent_assign): Ditto.
	(gfc_conv_structure): Move handling of _size component.
	trans-intrinsic.c: (gfc_conv_same_type_as): Handle conditions
	where unlimited polymorphic arguments have null vptr.
	* trans-stmt.c (trans_associate_var): Correctly treat array
	temporaries associated with unlimited polymorphic selectors.
	Recover the overwritten dtype for the descriptor. Use the _size
	field of the vptr for character string lengths.
	(gfc_trans_allocate): Cope with unlimited polymorphic allocate
	objects; especially with character source tags.
	(reset_vptr): New function.
	(gfc_trans_deallocate): Call it.
	* trans-types.c (gfc_get_derived_type): Detect unlimited
	polymorphic types and deal with cases where the derived type of
	components is null.
	* trans.c : Update copyright year.
	(trans_code): Call gfc_trans_class_assign for C717 cases where
	the lhs is not unlimited polymorphic.

2012-12-19  Paul Thomas  <pault@gcc.gnu.org>

	* intrinsics/extends_type_of.c : Return correct results for
	null vptrs.

2012-12-19  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/unlimited_polymorphic_1.f03: New test.
	* gfortran.dg/unlimited_polymorphic_2.f03: New test.
	* gfortran.dg/unlimited_polymorphic_3.f03: New test.
	* gfortran.dg/same_type_as.f03: Correct for improved message.

From-SVN: r194622

1 files changed, 325 insertions, 38 deletions

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 8a8a54a..61d65e7 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -1,5 +1,5 @@
 /* Implementation of Fortran 2003 Polymorphism.
-   Copyright (C) 2009, 2010
+   Copyright (C) 2009, 2010, 2011, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
    and Janus Weil <janus@gcc.gnu.org>
@@ -55,7 +55,6 @@ along with GCC; see the file COPYING3.  If not see
 #include "gfortran.h"
 #include "constructor.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
@@ -237,7 +236,7 @@ gfc_add_class_array_ref (gfc_expr *e)
       ref = ref->next;
       ref->type = REF_ARRAY;
       ref->u.ar.type = AR_FULL;
-      ref->u.ar.as = as;	  
+      ref->u.ar.as = as;
     }
 }
 
@@ -389,7 +388,7 @@ gfc_is_class_container_ref (gfc_expr *e)
       if (ref->type != REF_COMPONENT)
 	result = false;
       else if (ref->u.c.component->ts.type == BT_CLASS)
-	result = true; 
+	result = true;
       else
 	result = false;
     }
@@ -403,20 +402,31 @@ gfc_is_class_container_ref (gfc_expr *e)
    the _vptr component to the declared type.  */
 
 gfc_expr *
-gfc_class_null_initializer (gfc_typespec *ts)
+gfc_class_null_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 (&(init_expr->ts));
+  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)
-	ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived));
+      if (strcmp (comp->name, "_vptr") == 0 && vtab)
+	ctor->expr = gfc_lval_expr_from_sym (vtab);
       else
 	ctor->expr = gfc_get_null_expr (NULL);
       gfc_constructor_append (&init->value.constructor, ctor);
@@ -434,9 +444,14 @@ static void
 get_unique_type_string (char *string, gfc_symbol *derived)
 {
   char dt_name[GFC_MAX_SYMBOL_LEN+1];
+  if (derived->attr.unlimited_polymorphic)
+    sprintf (dt_name, "%s", "$tar");
+  else
   sprintf (dt_name, "%s", derived->name);
   dt_name[0] = TOUPPER (dt_name[0]);
-  if (derived->module)
+  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);
@@ -475,10 +490,30 @@ 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];
 
@@ -501,6 +536,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
   gfc_symbol *fclass;
   gfc_symbol *vtab;
   gfc_component *c;
+  gfc_namespace *ns;
   int rank;
 
   gcc_assert (as);
@@ -518,7 +554,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 
   attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
 		   || attr->select_type_temporary;
-  
+
   if (!attr->class_ok)
     /* We can not build the class container yet.  */
     return SUCCESS;
@@ -539,17 +575,28 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
   else
     sprintf (name, "__class_%s", tname);
 
-  gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
+  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, ts->u.derived->ns);
-      st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
+      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,
@@ -569,7 +616,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->attr.allocatable = attr->allocatable;
       c->attr.dimension = attr->dimension;
       c->attr.codimension = attr->codimension;
-      c->attr.abstract = ts->u.derived->attr.abstract;
+      c->attr.abstract = fclass->attr.abstract;
       c->as = (*as);
       c->initializer = NULL;
 
@@ -591,17 +638,21 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->attr.pointer = 1;
     }
 
-  /* Since the extension field is 8 bit wide, we can only have
-     up to 255 extension levels.  */
-  if (ts->u.derived->attr.extension == 255)
+  if (!ts->u.derived->attr.unlimited_polymorphic)
     {
-      gfc_error ("Maximum extension level reached with type '%s' at %L",
-		 ts->u.derived->name, &ts->u.derived->declared_at);
-      return FAILURE;
+      /* 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 FAILURE;
+	}
+
+      fclass->attr.extension = ts->u.derived->attr.extension + 1;
+      fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp;
     }
-    
-  fclass->attr.extension = ts->u.derived->attr.extension + 1;
-  fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp;
+
   fclass->attr.is_class = 1;
   ts->u.derived = fclass;
   attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
@@ -620,7 +671,7 @@ add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
 
   if (tb->non_overridable)
     return;
-  
+
   c = gfc_find_component (vtype, name, true, true);
 
   if (c == NULL)
@@ -670,7 +721,7 @@ add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
   if (st->right)
     add_procs_to_declared_vtab1 (st->right, vtype);
 
-  if (st->n.tb && !st->n.tb->error 
+  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);
 }
@@ -1766,15 +1817,15 @@ gfc_find_derived_vtab (gfc_symbol *derived)
   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 (MODULE or PROGRAM).  */
+  /* 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.is_class)
+  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];
@@ -1844,7 +1895,11 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		goto cleanup;
 	      c->attr.pointer = 1;
 	      c->attr.access = ACCESS_PRIVATE;
-	      parent = gfc_get_derived_super_type (derived);
+	      if (!derived->attr.unlimited_polymorphic)
+		parent = gfc_get_derived_super_type (derived);
+	      else
+		parent = NULL;
+
 	      if (parent)
 		{
 		  parent_vtab = gfc_find_derived_vtab (parent);
@@ -1862,7 +1917,9 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  c->initializer = gfc_get_null_expr (NULL);
 		}
 
-	      if (derived->components == NULL && !derived->attr.zero_comp)
+	      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.  */
@@ -1878,7 +1935,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	      c->attr.access = ACCESS_PRIVATE;
 	      c->ts.type = BT_DERIVED;
 	      c->ts.u.derived = derived;
-	      if (derived->attr.abstract)
+	      if (derived->attr.unlimited_polymorphic
+		  || derived->attr.abstract)
 		c->initializer = gfc_get_null_expr (NULL);
 	      else
 		{
@@ -1905,7 +1963,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	      c->attr.access = ACCESS_PRIVATE;
 	      c->tb = XCNEW (gfc_typebound_proc);
 	      c->tb->ppc = 1;
-	      if (derived->attr.abstract)
+	      if (derived->attr.unlimited_polymorphic
+		  || derived->attr.abstract)
 		c->initializer = gfc_get_null_expr (NULL);
 	      else
 		{
@@ -1966,7 +2025,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		 Note: The actual wrapper function can only be generated
 		 at resolution time.  */
 	    /* FIXME: Enable ABI-breaking "_final" generation.  */
-	    if (0) 
+	    if (0)
 	    {
 	      if (gfc_add_component (vtype, "_final", &c) == FAILURE)
 		goto cleanup;
@@ -1978,7 +2037,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	    }
 
 	      /* Add procedure pointers for type-bound procedures.  */
-	      add_procs_to_declared_vtab (derived, vtype);
+	      if (!derived->attr.unlimited_polymorphic)
+		add_procs_to_declared_vtab (derived, vtype);
 	  }
 
 have_vtype:
@@ -2055,6 +2115,233 @@ yes:
 }
 
 
+/* 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, *def_init = 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) == FAILURE)
+	    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_get_symbol (name, ns, &vtype);
+	      if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
+				  NULL, &gfc_current_locus) == FAILURE)
+		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) == FAILURE)
+		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) == FAILURE)
+		goto cleanup;
+	      c->ts.type = BT_INTEGER;
+	      c->ts.kind = 4;
+	      c->attr.access = ACCESS_PRIVATE;
+	      if (ts->type == BT_CHARACTER)
+		c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+						   NULL, charlen*ts->kind);
+	      else
+		c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+						   NULL, ts->kind);
+
+	      /* Add component _extends.  */
+	      if (gfc_add_component (vtype, "_extends", &c) == FAILURE)
+		goto cleanup;
+	      c->attr.pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      /* Avoid segfaults because due to character length.   */
+	      c->ts.type = ts->type == BT_CHARACTER ? BT_VOID : ts->type;
+	      c->ts.kind = ts->kind;
+	      c->initializer = gfc_get_null_expr (NULL);
+
+	      /* Add component _def_init.  */
+	      if (gfc_add_component (vtype, "_def_init", &c) == FAILURE)
+		goto cleanup;
+	      c->attr.pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      /* Avoid segfaults due to missing character length.   */
+	      c->ts.type = ts->type == BT_CHARACTER ? BT_VOID : ts->type;
+	      c->ts.kind = ts->kind;
+	      c->initializer = gfc_get_null_expr (NULL);
+
+	      /* Add component _copy.  */
+	      if (gfc_add_component (vtype, "_copy", &c) == FAILURE)
+		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_OUT;
+	      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 ();
+	      sub_ns->code->op = 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;
+	    }
+	  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;
+}
+
+
 /* General worker function to find either a type-bound procedure or a
    type-bound user operator.  */
 
@@ -2147,7 +2434,7 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
   /* Try to find it in the current type's namespace.  */
   if (derived->f2k_derived)
     res = derived->f2k_derived->tb_op[op];
-  else  
+  else
     res = NULL;
 
   /* Check access.  */