2010-05-17 Janus Weil <janus@gcc.gnu.org>

	* class.c (gfc_add_component_ref,gfc_class_null_initializer,
	gfc_build_class_symbol,add_proc_component,add_proc_comps, 
	add_procs_to_declared_vtab1,copy_vtab_proc_comps,
	add_procs_to_declared_vtab,add_generic_specifics, 
	add_generics_to_declared_vtab,gfc_find_derived_vtab,
	find_typebound_proc_uop,gfc_find_typebound_proc,
	gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op, 
	gfc_get_tbp_symtree): Moved here from other places.
	* expr.c (gfc_add_component_ref,gfc_class_null_initializer): Move to
	class.c.
	* gfortran.h (gfc_build_class_symbol,gfc_find_derived_vtab,
	gfc_find_typebound_proc,gfc_find_typebound_user_op,
	gfc_find_typebound_intrinsic_op,gfc_get_tbp_symtree,
	gfc_add_component_ref, gfc_class_null_initializer): Moved to class.c.
	* Make-lang.in: Add class.o.
	* symbol.c (gfc_build_class_symbol,add_proc_component,add_proc_comps,
	add_procs_to_declared_vtab1,copy_vtab_proc_comps,
	add_procs_to_declared_vtab,add_generic_specifics,
	add_generics_to_declared_vtab,gfc_find_derived_vtab,
	find_typebound_proc_uop,gfc_find_typebound_proc,
	gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op,
	gfc_get_tbp_symtree): Move to class.c.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159506 138bc75d-0d04-0410-961f-82ee72b054a4

6 files changed, 844 insertions, 767 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6e632d1a0cb..45fe11a8e17 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,28 @@
+2010-05-17  Janus Weil  <janus@gcc.gnu.org>
+
+	* class.c (gfc_add_component_ref,gfc_class_null_initializer,
+	gfc_build_class_symbol,add_proc_component,add_proc_comps, 
+	add_procs_to_declared_vtab1,copy_vtab_proc_comps,
+	add_procs_to_declared_vtab,add_generic_specifics, 
+	add_generics_to_declared_vtab,gfc_find_derived_vtab,
+	find_typebound_proc_uop,gfc_find_typebound_proc,
+	gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op, 
+	gfc_get_tbp_symtree): Moved here from other places.
+	* expr.c (gfc_add_component_ref,gfc_class_null_initializer): Move to
+	class.c.
+	* gfortran.h (gfc_build_class_symbol,gfc_find_derived_vtab,
+	gfc_find_typebound_proc,gfc_find_typebound_user_op,
+	gfc_find_typebound_intrinsic_op,gfc_get_tbp_symtree,
+	gfc_add_component_ref, gfc_class_null_initializer): Moved to class.c.
+	* Make-lang.in: Add class.o.
+	* symbol.c (gfc_build_class_symbol,add_proc_component,add_proc_comps,
+	add_procs_to_declared_vtab1,copy_vtab_proc_comps,
+	add_procs_to_declared_vtab,add_generic_specifics,
+	add_generics_to_declared_vtab,gfc_find_derived_vtab,
+	find_typebound_proc_uop,gfc_find_typebound_proc,
+	gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op,
+	gfc_get_tbp_symtree): Move to class.c.
+
 2010-05-17  Nathan Froyd  <froydnj@codesourcery.com>
 
 	* trans-types.c (gfc_init_types): Use build_function_type_list.
diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in
index d9544a4e06e..49ffdf963bf 100644
--- a/gcc/fortran/Make-lang.in
+++ b/gcc/fortran/Make-lang.in
@@ -53,13 +53,13 @@ fortran-warn = $(STRICT_WARN)
 # from the parse tree to GENERIC
 
 F95_PARSER_OBJS = fortran/arith.o fortran/array.o fortran/bbt.o \
-    fortran/check.o fortran/constructor.o fortran/cpp.o fortran/data.o \
-    fortran/decl.o fortran/dump-parse-tree.o fortran/error.o fortran/expr.o \
-    fortran/interface.o fortran/intrinsic.o fortran/io.o fortran/iresolve.o \
-    fortran/match.o fortran/matchexp.o fortran/misc.o fortran/module.o \
-    fortran/openmp.o fortran/options.o fortran/parse.o fortran/primary.o \
-    fortran/resolve.o fortran/scanner.o fortran/simplify.o fortran/st.o \
-    fortran/symbol.o fortran/target-memory.o
+    fortran/check.o fortran/class.o fortran/constructor.o fortran/cpp.o \
+    fortran/data.o fortran/decl.o fortran/dump-parse-tree.o fortran/error.o \
+    fortran/expr.o fortran/interface.o fortran/intrinsic.o fortran/io.o \
+    fortran/iresolve.o fortran/match.o fortran/matchexp.o fortran/misc.o \
+    fortran/module.o fortran/openmp.o fortran/options.o fortran/parse.o \
+    fortran/primary.o fortran/resolve.o fortran/scanner.o fortran/simplify.o \
+    fortran/st.o fortran/symbol.o fortran/target-memory.o
 
 F95_OBJS = $(F95_PARSER_OBJS) $(FORTRAN_TARGET_OBJS) \
     fortran/convert.o fortran/dependency.o fortran/f95-lang.o \
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
new file mode 100644
index 00000000000..37b9cf01590
--- /dev/null
+++ b/gcc/fortran/class.c
@@ -0,0 +1,797 @@
+/* Implementation of Fortran 2003 Polymorphism.
+   Copyright (C) 2009, 2010
+   Free Software Foundation, Inc.
+   Contributed by Paul Richard Thomas & Janus Weil
+
+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.
+   In addition to these fields, each vtable entry contains additional procedure
+   pointer components, which contain pointers to the procedures which are bound
+   to the type's "methods" (type-bound procedures).  */
+
+
+#include "config.h"
+#include "system.h"
+#include "gfortran.h"
+#include "constructor.h"
+
+
+/* Insert a reference to the component of the given name.
+   Only to be used with CLASS containers.  */
+
+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)
+	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;
+}
+
+
+/* Build a NULL initializer for CLASS pointers,
+   initializing the $data and $vptr components to zero.  */
+
+gfc_expr *
+gfc_class_null_initializer (gfc_typespec *ts)
+{
+  gfc_expr *init;
+  gfc_component *comp;
+  
+  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();
+      ctor->expr = gfc_get_expr ();
+      ctor->expr->expr_type = EXPR_NULL;
+      ctor->expr->ts = comp->ts;
+      gfc_constructor_append (&init->value.constructor, ctor);
+    }
+
+  return init;
+}
+
+
+/* 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.  */
+
+gfc_try
+gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
+			gfc_array_spec **as, bool delayed_vtab)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 5];
+  gfc_symbol *fclass;
+  gfc_symbol *vtab;
+  gfc_component *c;
+
+  /* Determine the name of the encapsulating type.  */
+  if ((*as) && (*as)->rank && attr->allocatable)
+    sprintf (name, "class$%s_%d_a", ts->u.derived->name, (*as)->rank);
+  else if ((*as) && (*as)->rank)
+    sprintf (name, "class$%s_%d", ts->u.derived->name, (*as)->rank);
+  else if (attr->pointer)
+    sprintf (name, "class$%s_p", ts->u.derived->name);
+  else if (attr->allocatable)
+    sprintf (name, "class$%s_a", ts->u.derived->name);
+  else
+    sprintf (name, "class$%s", ts->u.derived->name);
+
+  gfc_find_symbol (name, ts->u.derived->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);
+      st->n.sym = fclass;
+      gfc_set_sym_referenced (fclass);
+      fclass->refs++;
+      fclass->ts.type = BT_UNKNOWN;
+      fclass->attr.abstract = ts->u.derived->attr.abstract;
+      if (ts->u.derived->f2k_derived)
+	fclass->f2k_derived = gfc_get_namespace (NULL, 0);
+      if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
+	  NULL, &gfc_current_locus) == FAILURE)
+	return FAILURE;
+
+      /* Add component '$data'.  */
+      if (gfc_add_component (fclass, "$data", &c) == FAILURE)
+	return FAILURE;
+      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;
+      c->attr.allocatable = attr->allocatable;
+      c->attr.dimension = attr->dimension;
+      c->attr.codimension = attr->codimension;
+      c->attr.abstract = ts->u.derived->attr.abstract;
+      c->as = (*as);
+      c->initializer = NULL;
+
+      /* Add component '$vptr'.  */
+      if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
+	return FAILURE;
+      c->ts.type = BT_DERIVED;
+      if (delayed_vtab)
+	c->ts.u.derived = NULL;
+      else
+	{
+	  vtab = gfc_find_derived_vtab (ts->u.derived, false);
+	  gcc_assert (vtab);
+	  c->ts.u.derived = vtab->ts.u.derived;
+	}
+      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)
+    {
+      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.is_class = 1;
+  ts->u.derived = fclass;
+  attr->allocatable = attr->pointer = attr->dimension = 0;
+  (*as) = NULL;  /* XXX */
+  return SUCCESS;
+}
+
+
+static void
+add_proc_component (gfc_component *c, gfc_symbol *vtype,
+		    gfc_symtree *st, gfc_symbol *specific,
+		    bool is_generic, bool is_generic_specific)
+{
+  /* Add procedure component.  */
+  if (is_generic)
+    {
+      if (gfc_add_component (vtype, specific->name, &c) == FAILURE)
+	return;
+      c->ts.interface = specific;
+    }
+  else if (c && is_generic_specific)
+    {
+      c->ts.interface = st->n.tb->u.specific->n.sym;
+    }
+  else
+    {
+      c = gfc_find_component (vtype, st->name, true, true);
+      if (!c && gfc_add_component (vtype, st->name, &c) == FAILURE)
+	return;
+      c->ts.interface = st->n.tb->u.specific->n.sym;
+    }
+
+  if (!c->tb)
+    c->tb = XCNEW (gfc_typebound_proc);
+  *c->tb = *st->n.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;
+
+  /* A static initializer cannot be used here because the specific
+     function is not a constant; internal compiler error: in
+     output_constant, at varasm.c:4623  */
+  c->initializer = NULL;
+}
+
+
+static void
+add_proc_comps (gfc_component *c, gfc_symbol *vtype,
+		gfc_symtree *st, bool is_generic)
+{
+  if (c == NULL && !is_generic)
+    {
+      add_proc_component (c, vtype, st, NULL, false, false);
+    }
+  else if (is_generic && st->n.tb && vtype->components == NULL)
+    {
+      gfc_tbp_generic* g;
+      gfc_symbol * specific;
+      for (g = st->n.tb->u.generic; g; g = g->next)
+	{
+	  if (!g->specific)
+	    continue;
+	  specific = g->specific->u.specific->n.sym;
+	  add_proc_component (NULL, vtype, st, specific, true, false);
+	}
+    }
+  else if (c->attr.proc_pointer && c->tb)
+    {
+      *c->tb = *st->n.tb;
+      c->tb->ppc = 1;
+      c->ts.interface = st->n.tb->u.specific->n.sym;	  
+    }
+}
+
+static void
+add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype,
+			     bool resolved)
+{
+  gfc_component *c;
+  gfc_symbol *generic;
+  char name[3 * GFC_MAX_SYMBOL_LEN + 10];
+
+  if (!st)
+    return;
+
+  if (st->left)
+    add_procs_to_declared_vtab1 (st->left, vtype, resolved);
+
+  if (st->right)
+    add_procs_to_declared_vtab1 (st->right, vtype, resolved);
+
+  if (!st->n.tb)
+    return;
+
+  if (!st->n.tb->is_generic && st->n.tb->u.specific)
+    {
+      c = gfc_find_component (vtype, st->name, true, true);
+      add_proc_comps (c, vtype, st, false);
+    }
+  else if (st->n.tb->is_generic)
+    {
+      c = gfc_find_component (vtype, st->name, true, true);
+
+      if (c == NULL)
+	{
+	  /* Add derived type component with generic name.  */
+	  if (gfc_add_component (vtype, st->name, &c) == FAILURE)
+	    return;
+	  c->ts.type = BT_DERIVED;
+	  c->attr.flavor = FL_VARIABLE;
+	  c->attr.pointer = 1;
+
+	  /* Add a special empty derived type as a placeholder.  */
+	  sprintf (name, "$empty");
+	  gfc_find_symbol (name, vtype->ns, 0, &generic);
+	  if (generic == NULL)
+	    {
+	      gfc_get_symbol (name, vtype->ns, &generic);
+	      generic->attr.flavor = FL_DERIVED;
+	      generic->refs++;
+	      gfc_set_sym_referenced (generic);
+	      generic->ts.type = BT_UNKNOWN;
+	      generic->attr.zero_comp = 1;
+	    }
+
+	  c->ts.u.derived = generic;
+	}
+    }
+}
+
+
+static void
+copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype,
+		      bool resolved)
+{
+  gfc_component *c, *cmp;
+  gfc_symbol *vtab;
+
+  vtab = gfc_find_derived_vtab (declared, resolved);
+
+  for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
+    {
+      if (gfc_find_component (vtype, cmp->name, true, true))
+	continue;
+
+      if (gfc_add_component (vtype, cmp->name, &c) == FAILURE)
+	return;
+
+      if (cmp->ts.type == BT_DERIVED)
+	{
+	  c->ts = cmp->ts;
+	  c->ts.u.derived = cmp->ts.u.derived;
+	  c->attr.flavor = FL_VARIABLE;
+	  c->attr.pointer = 1;
+	  c->initializer = NULL;
+	  continue;
+	}
+
+      c->tb = XCNEW (gfc_typebound_proc);
+      *c->tb = *cmp->tb;
+      c->attr.procedure = 1;
+      c->attr.proc_pointer = 1;
+      c->attr.flavor = FL_PROCEDURE;
+      c->attr.access = ACCESS_PRIVATE;
+      c->attr.external = 1;
+      c->ts.interface = cmp->ts.interface;
+      c->attr.untyped = 1;
+      c->attr.if_source = IFSRC_IFBODY;
+      c->initializer = NULL;
+    }
+}
+
+static void
+add_procs_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
+			    gfc_symbol *derived, bool resolved)
+{
+  gfc_symbol* super_type;
+
+  super_type = gfc_get_derived_super_type (declared);
+
+  if (super_type && (super_type != declared))
+    add_procs_to_declared_vtab (super_type, vtype, derived, resolved);
+
+  if (declared != derived)
+    copy_vtab_proc_comps (declared, vtype, resolved);
+
+  if (declared->f2k_derived && declared->f2k_derived->tb_sym_root)
+    add_procs_to_declared_vtab1 (declared->f2k_derived->tb_sym_root,
+				 vtype, resolved);
+
+  if (declared->f2k_derived && declared->f2k_derived->tb_uop_root)
+    add_procs_to_declared_vtab1 (declared->f2k_derived->tb_uop_root,
+				 vtype, resolved);
+}
+
+
+static
+void add_generic_specifics (gfc_symbol *declared, gfc_symbol *vtab,
+			    const char *name)
+{
+  gfc_tbp_generic* g;
+  gfc_symbol * specific1;
+  gfc_symbol * specific2;
+  gfc_symtree *st = NULL;
+  gfc_component *c;
+
+  /* Find the generic procedure using the component name.  */
+  st = gfc_find_typebound_proc (declared, NULL, name, true, NULL);
+  if (st == NULL)
+    st = gfc_find_typebound_user_op (declared, NULL, name, true, NULL);
+
+  if (st == NULL)
+    return;
+
+  /* Add procedure pointer components for the specific procedures. */
+  for (g = st->n.tb->u.generic; g; g = g->next)
+    {
+      if (!g->specific)
+	continue;
+      specific1 = g->specific_st->n.tb->u.specific->n.sym;
+
+      c = vtab->ts.u.derived->components;
+      specific2 = NULL;
+
+      /* Override identical specific interface.  */
+      if (vtab->ts.u.derived->components)
+	{
+	  for (; c; c= c->next)
+	    {
+	      specific2 = c->ts.interface;
+	      if (gfc_compare_interfaces (specific2, specific1,
+					  specific1->name, 0, 0, NULL, 0))
+		break;
+	    }
+	}
+
+      add_proc_component (c, vtab->ts.u.derived, g->specific_st,
+			  NULL, false, true);
+      vtab->ts.u.derived->attr.zero_comp = 0;
+    }
+}
+
+
+static void
+add_generics_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
+			       gfc_symbol *derived, bool resolved)
+{
+  gfc_component *cmp;
+  gfc_symtree *st = NULL;
+  gfc_symbol * vtab;
+  char name[2 * GFC_MAX_SYMBOL_LEN + 8];
+  gfc_symbol* super_type;
+
+  gcc_assert (resolved);
+
+  for (cmp = vtype->components; cmp; cmp = cmp->next)
+    {
+      if (cmp->ts.type != BT_DERIVED)
+	continue;
+
+      /* The only derived type that does not represent a generic
+	 procedure is the pointer to the parent vtab.  */
+      if (cmp->ts.u.derived
+	    && strcmp (cmp->ts.u.derived->name, "$extends") == 0)
+	continue;
+
+      /* Find the generic procedure using the component name.  */
+      st = gfc_find_typebound_proc (declared, NULL, cmp->name,
+				    true, NULL);
+      if (st == NULL)
+	st = gfc_find_typebound_user_op (declared, NULL, cmp->name,
+					 true, NULL);
+
+      /* Should be an error but we pass on it for now.  */
+      if (st == NULL || !st->n.tb->is_generic)
+	continue;
+
+      vtab = NULL;
+
+      /* Build a vtab and a special vtype, with only the procedure
+	 pointer fields, to carry the pointers to the specific
+	 procedures.  Should this name ever be changed, the same
+	 should be done in trans-expr.c(gfc_trans_assign_vtab_procs). */
+      sprintf (name, "vtab$%s$%s", vtype->name, cmp->name);
+      gfc_find_symbol (name, derived->ns, 0, &vtab);
+      if (vtab == NULL)
+	{
+	  gfc_get_symbol (name, derived->ns, &vtab);
+	  vtab->ts.type = BT_DERIVED;
+	  vtab->attr.flavor = FL_VARIABLE;
+	  vtab->attr.target = 1;
+	  vtab->attr.save = SAVE_EXPLICIT;
+	  vtab->attr.vtab = 1;
+	  vtab->refs++;
+	  gfc_set_sym_referenced (vtab);
+	  sprintf (name, "%s$%s", vtype->name, cmp->name);
+	  
+	  gfc_find_symbol (name, derived->ns, 0, &cmp->ts.u.derived);
+	  if (cmp->ts.u.derived == NULL
+		|| (strcmp (cmp->ts.u.derived->name, "$empty") == 0))
+	    {
+	      gfc_get_symbol (name, derived->ns, &cmp->ts.u.derived);
+	      if (gfc_add_flavor (&cmp->ts.u.derived->attr, FL_DERIVED,
+				  NULL, &gfc_current_locus) == FAILURE)
+		return;
+	      cmp->ts.u.derived->refs++;
+	      gfc_set_sym_referenced (cmp->ts.u.derived);
+	      cmp->ts.u.derived->attr.vtype = 1;
+	      cmp->ts.u.derived->attr.zero_comp = 1;
+	    }
+	  vtab->ts.u.derived = cmp->ts.u.derived;
+	}
+
+      /* Store this for later use in setting the pointer.  */
+      cmp->ts.interface = vtab;
+
+      if (vtab->ts.u.derived->components)
+	continue;
+
+      super_type = gfc_get_derived_super_type (declared);
+
+      if (super_type && (super_type != declared))
+	add_generic_specifics (super_type, vtab, cmp->name);
+
+      add_generic_specifics (declared, vtab, cmp->name);
+    }
+}
+
+
+/* Find the symbol for a derived type's vtab.  A vtab has the following
+   fields:
+   $hash	a hash value used to identify the derived type
+   $size	the size in bytes of the derived type
+   $extends	a pointer to the vtable of the parent derived type
+   then:
+   procedure pointer components for the specific typebound procedures
+   structure pointers to reduced vtabs that contain procedure
+   pointers to the specific procedures.  */
+
+gfc_symbol *
+gfc_find_derived_vtab (gfc_symbol *derived, bool resolved)
+{
+  gfc_namespace *ns;
+  gfc_symbol *vtab = NULL, *vtype = NULL;
+  char name[2 * GFC_MAX_SYMBOL_LEN + 8];
+
+  ns = gfc_current_ns;
+
+  for (; ns; ns = ns->parent)
+    if (!ns->parent)
+      break;
+
+  if (ns)
+    {
+      sprintf (name, "vtab$%s", derived->name);
+      gfc_find_symbol (name, ns, 0, &vtab);
+
+      if (vtab == NULL)
+	{
+	  gfc_get_symbol (name, ns, &vtab);
+	  vtab->ts.type = BT_DERIVED;
+	  vtab->attr.flavor = FL_VARIABLE;
+	  vtab->attr.target = 1;
+	  vtab->attr.save = SAVE_EXPLICIT;
+	  vtab->attr.vtab = 1;
+	  vtab->refs++;
+	  gfc_set_sym_referenced (vtab);
+	  sprintf (name, "vtype$%s", derived->name);
+	  
+	  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) == FAILURE)
+		return NULL;
+	      vtype->refs++;
+	      gfc_set_sym_referenced (vtype);
+
+	      /* Add component '$hash'.  */
+	      if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
+		return NULL;
+	      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) == FAILURE)
+		return NULL;
+	      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) == FAILURE)
+		return NULL;
+	      c->attr.pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      parent = gfc_get_derived_super_type (derived);
+	      if (parent)
+		{
+		  parent_vtab = gfc_find_derived_vtab (parent, resolved);
+		  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);
+		}
+
+	      add_procs_to_declared_vtab (derived, vtype, derived, resolved);
+	      vtype->attr.vtype = 1;
+	    }
+
+	  vtab->ts.u.derived = vtype;
+	  vtab->value = gfc_default_initializer (&vtab->ts);
+	}
+    }
+
+  /* Catch the call just before the backend declarations are built, so that
+     the generic procedures have been resolved and the specific procedures
+     have formal interfaces that can be compared.  */
+  if (resolved
+	&& vtab->ts.u.derived
+	&& vtab->ts.u.derived->backend_decl == NULL)
+    add_generics_to_declared_vtab (derived, vtab->ts.u.derived,
+				   derived, resolved);
+
+  return vtab;
+}
+
+
+/* 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, gfc_try* t,
+			 const char* name, bool noaccess, bool uop,
+			 locus* where)
+{
+  gfc_symtree* res;
+  gfc_symtree* root;
+
+  /* Set correct symbol-root.  */
+  gcc_assert (derived->f2k_derived);
+  root = (uop ? derived->f2k_derived->tb_uop_root
+	      : derived->f2k_derived->tb_sym_root);
+
+  /* Set default to failure.  */
+  if (t)
+    *t = FAILURE;
+
+  /* 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 = SUCCESS;
+
+      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 = FAILURE;
+	}
+
+      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, gfc_try* 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, gfc_try* 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, gfc_try* t,
+				 gfc_intrinsic_op op, bool noaccess,
+				 locus* where)
+{
+  gfc_typebound_proc* res;
+
+  /* Set default to failure.  */
+  if (t)
+    *t = FAILURE;
+
+  /* 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 = SUCCESS;
+
+      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 = FAILURE;
+	}
+
+      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;
+}
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 382d1fe6452..75f27be80ee 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -676,36 +676,6 @@ gfc_has_vector_index (gfc_expr *e)
 }
 
 
-/* Insert a reference to the component of the given name.
-   Only to be used with CLASS containers.  */
-
-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)
-	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;
-}
-
-
 /* Copy a shape array.  */
 
 mpz_t *
@@ -3628,32 +3598,6 @@ gfc_default_initializer (gfc_typespec *ts)
 }
 
 
-/* Build a NULL initializer for CLASS pointers,
-   initializing the $data and $vptr components to zero.  */
-
-gfc_expr *
-gfc_class_null_initializer (gfc_typespec *ts)
-{
-  gfc_expr *init;
-  gfc_component *comp;
-  
-  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();
-      ctor->expr = gfc_get_expr ();
-      ctor->expr->expr_type = EXPR_NULL;
-      ctor->expr->ts = comp->ts;
-      gfc_constructor_append (&init->value.constructor, ctor);
-    }
-
-  return init;
-}
-
-
 /* Given a symbol, create an expression node with that symbol as a
    variable. If the symbol is array valued, setup a reference of the
    whole array.  */
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 96acaa4574e..c14bcce9423 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2512,22 +2512,11 @@ void gfc_free_dt_list (void);
 gfc_gsymbol *gfc_get_gsymbol (const char *);
 gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
 
-gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
-				gfc_array_spec **, bool);
-gfc_symbol *gfc_find_derived_vtab (gfc_symbol *, bool);
 gfc_typebound_proc* gfc_get_typebound_proc (void);
 gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
 gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*);
 bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *);
 bool gfc_type_compatible (gfc_typespec *, gfc_typespec *);
-gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
-				      const char*, bool, locus*);
-gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
-					 const char*, bool, locus*);
-gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*,
-						     gfc_intrinsic_op, bool,
-						     locus*);
-gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
 
 void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *);
 void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
@@ -2593,7 +2582,6 @@ gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
 const char *gfc_extract_int (gfc_expr *, int *);
 bool is_subref_array (gfc_expr *);
 
-void gfc_add_component_ref (gfc_expr *, const char *);
 gfc_expr *gfc_build_conversion (gfc_expr *);
 void gfc_free_ref_list (gfc_ref *);
 void gfc_type_convert_binary (gfc_expr *, int);
@@ -2630,7 +2618,6 @@ gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
 
 gfc_expr *gfc_default_initializer (gfc_typespec *);
-gfc_expr *gfc_class_null_initializer (gfc_typespec *);
 gfc_expr *gfc_get_variable_expr (gfc_symtree *);
 
 gfc_array_spec *gfc_get_full_arrayspec_from_expr (gfc_expr *expr);
@@ -2785,4 +2772,19 @@ int gfc_is_data_pointer (gfc_expr *);
 /* check.c */
 gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*);
 
+/* class.c */
+void gfc_add_component_ref (gfc_expr *, const char *);
+gfc_expr *gfc_class_null_initializer (gfc_typespec *);
+gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
+				gfc_array_spec **, bool);
+gfc_symbol *gfc_find_derived_vtab (gfc_symbol *, bool);
+gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
+				      const char*, bool, locus*);
+gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
+					 const char*, bool, locus*);
+gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*,
+						     gfc_intrinsic_op, bool,
+						     locus*);
+gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
+
 #endif /* GCC_GFORTRAN_H  */
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index ceb45bfa6ec..b719de11044 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4699,694 +4699,3 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
   else
     return 0;
 }
-
-
-/* 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.  */
-
-gfc_try
-gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
-			gfc_array_spec **as, bool delayed_vtab)
-{
-  char name[GFC_MAX_SYMBOL_LEN + 5];
-  gfc_symbol *fclass;
-  gfc_symbol *vtab;
-  gfc_component *c;
-
-  /* Determine the name of the encapsulating type.  */
-  if ((*as) && (*as)->rank && attr->allocatable)
-    sprintf (name, "class$%s_%d_a", ts->u.derived->name, (*as)->rank);
-  else if ((*as) && (*as)->rank)
-    sprintf (name, "class$%s_%d", ts->u.derived->name, (*as)->rank);
-  else if (attr->pointer)
-    sprintf (name, "class$%s_p", ts->u.derived->name);
-  else if (attr->allocatable)
-    sprintf (name, "class$%s_a", ts->u.derived->name);
-  else
-    sprintf (name, "class$%s", ts->u.derived->name);
-
-  gfc_find_symbol (name, ts->u.derived->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);
-      st->n.sym = fclass;
-      gfc_set_sym_referenced (fclass);
-      fclass->refs++;
-      fclass->ts.type = BT_UNKNOWN;
-      fclass->attr.abstract = ts->u.derived->attr.abstract;
-      if (ts->u.derived->f2k_derived)
-	fclass->f2k_derived = gfc_get_namespace (NULL, 0);
-      if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
-	  NULL, &gfc_current_locus) == FAILURE)
-	return FAILURE;
-
-      /* Add component '$data'.  */
-      if (gfc_add_component (fclass, "$data", &c) == FAILURE)
-	return FAILURE;
-      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;
-      c->attr.allocatable = attr->allocatable;
-      c->attr.dimension = attr->dimension;
-      c->attr.codimension = attr->codimension;
-      c->attr.abstract = ts->u.derived->attr.abstract;
-      c->as = (*as);
-      c->initializer = NULL;
-
-      /* Add component '$vptr'.  */
-      if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
-	return FAILURE;
-      c->ts.type = BT_DERIVED;
-      if (delayed_vtab)
-	c->ts.u.derived = NULL;
-      else
-	{
-	  vtab = gfc_find_derived_vtab (ts->u.derived, false);
-	  gcc_assert (vtab);
-	  c->ts.u.derived = vtab->ts.u.derived;
-	}
-      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)
-    {
-      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.is_class = 1;
-  ts->u.derived = fclass;
-  attr->allocatable = attr->pointer = attr->dimension = 0;
-  (*as) = NULL;  /* XXX */
-  return SUCCESS;
-}
-
-
-static void
-add_proc_component (gfc_component *c, gfc_symbol *vtype,
-		    gfc_symtree *st, gfc_symbol *specific,
-		    bool is_generic, bool is_generic_specific)
-{
-  /* Add procedure component.  */
-  if (is_generic)
-    {
-      if (gfc_add_component (vtype, specific->name, &c) == FAILURE)
-	return;
-      c->ts.interface = specific;
-    }
-  else if (c && is_generic_specific)
-    {
-      c->ts.interface = st->n.tb->u.specific->n.sym;
-    }
-  else
-    {
-      c = gfc_find_component (vtype, st->name, true, true);
-      if (!c && gfc_add_component (vtype, st->name, &c) == FAILURE)
-	return;
-      c->ts.interface = st->n.tb->u.specific->n.sym;
-    }
-
-  if (!c->tb)
-    c->tb = XCNEW (gfc_typebound_proc);
-  *c->tb = *st->n.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;
-
-  /* A static initializer cannot be used here because the specific
-     function is not a constant; internal compiler error: in
-     output_constant, at varasm.c:4623  */
-  c->initializer = NULL;
-}
-
-
-static void
-add_proc_comps (gfc_component *c, gfc_symbol *vtype,
-		gfc_symtree *st, bool is_generic)
-{
-  if (c == NULL && !is_generic)
-    {
-      add_proc_component (c, vtype, st, NULL, false, false);
-    }
-  else if (is_generic && st->n.tb && vtype->components == NULL)
-    {
-      gfc_tbp_generic* g;
-      gfc_symbol * specific;
-      for (g = st->n.tb->u.generic; g; g = g->next)
-	{
-	  if (!g->specific)
-	    continue;
-	  specific = g->specific->u.specific->n.sym;
-	  add_proc_component (NULL, vtype, st, specific, true, false);
-	}
-    }
-  else if (c->attr.proc_pointer && c->tb)
-    {
-      *c->tb = *st->n.tb;
-      c->tb->ppc = 1;
-      c->ts.interface = st->n.tb->u.specific->n.sym;	  
-    }
-}
-
-static void
-add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype,
-			     bool resolved)
-{
-  gfc_component *c;
-  gfc_symbol *generic;
-  char name[3 * GFC_MAX_SYMBOL_LEN + 10];
-
-  if (!st)
-    return;
-
-  if (st->left)
-    add_procs_to_declared_vtab1 (st->left, vtype, resolved);
-
-  if (st->right)
-    add_procs_to_declared_vtab1 (st->right, vtype, resolved);
-
-  if (!st->n.tb)
-    return;
-
-  if (!st->n.tb->is_generic && st->n.tb->u.specific)
-    {
-      c = gfc_find_component (vtype, st->name, true, true);
-      add_proc_comps (c, vtype, st, false);
-    }
-  else if (st->n.tb->is_generic)
-    {
-      c = gfc_find_component (vtype, st->name, true, true);
-
-      if (c == NULL)
-	{
-	  /* Add derived type component with generic name.  */
-	  if (gfc_add_component (vtype, st->name, &c) == FAILURE)
-	    return;
-	  c->ts.type = BT_DERIVED;
-	  c->attr.flavor = FL_VARIABLE;
-	  c->attr.pointer = 1;
-
-	  /* Add a special empty derived type as a placeholder.  */
-	  sprintf (name, "$empty");
-	  gfc_find_symbol (name, vtype->ns, 0, &generic);
-	  if (generic == NULL)
-	    {
-	      gfc_get_symbol (name, vtype->ns, &generic);
-	      generic->attr.flavor = FL_DERIVED;
-	      generic->refs++;
-	      gfc_set_sym_referenced (generic);
-	      generic->ts.type = BT_UNKNOWN;
-	      generic->attr.zero_comp = 1;
-	    }
-
-	  c->ts.u.derived = generic;
-	}
-    }
-}
-
-
-static void
-copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype,
-		      bool resolved)
-{
-  gfc_component *c, *cmp;
-  gfc_symbol *vtab;
-
-  vtab = gfc_find_derived_vtab (declared, resolved);
-
-  for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
-    {
-      if (gfc_find_component (vtype, cmp->name, true, true))
-	continue;
-
-      if (gfc_add_component (vtype, cmp->name, &c) == FAILURE)
-	return;
-
-      if (cmp->ts.type == BT_DERIVED)
-	{
-	  c->ts = cmp->ts;
-	  c->ts.u.derived = cmp->ts.u.derived;
-	  c->attr.flavor = FL_VARIABLE;
-	  c->attr.pointer = 1;
-	  c->initializer = NULL;
-	  continue;
-	}
-
-      c->tb = XCNEW (gfc_typebound_proc);
-      *c->tb = *cmp->tb;
-      c->attr.procedure = 1;
-      c->attr.proc_pointer = 1;
-      c->attr.flavor = FL_PROCEDURE;
-      c->attr.access = ACCESS_PRIVATE;
-      c->attr.external = 1;
-      c->ts.interface = cmp->ts.interface;
-      c->attr.untyped = 1;
-      c->attr.if_source = IFSRC_IFBODY;
-      c->initializer = NULL;
-    }
-}
-
-static void
-add_procs_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
-			    gfc_symbol *derived, bool resolved)
-{
-  gfc_symbol* super_type;
-
-  super_type = gfc_get_derived_super_type (declared);
-
-  if (super_type && (super_type != declared))
-    add_procs_to_declared_vtab (super_type, vtype, derived, resolved);
-
-  if (declared != derived)
-    copy_vtab_proc_comps (declared, vtype, resolved);
-
-  if (declared->f2k_derived && declared->f2k_derived->tb_sym_root)
-    add_procs_to_declared_vtab1 (declared->f2k_derived->tb_sym_root,
-				 vtype, resolved);
-
-  if (declared->f2k_derived && declared->f2k_derived->tb_uop_root)
-    add_procs_to_declared_vtab1 (declared->f2k_derived->tb_uop_root,
-				 vtype, resolved);
-}
-
-
-static
-void add_generic_specifics (gfc_symbol *declared, gfc_symbol *vtab,
-			    const char *name)
-{
-  gfc_tbp_generic* g;
-  gfc_symbol * specific1;
-  gfc_symbol * specific2;
-  gfc_symtree *st = NULL;
-  gfc_component *c;
-
-  /* Find the generic procedure using the component name.  */
-  st = gfc_find_typebound_proc (declared, NULL, name, true, NULL);
-  if (st == NULL)
-    st = gfc_find_typebound_user_op (declared, NULL, name, true, NULL);
-
-  if (st == NULL)
-    return;
-
-  /* Add procedure pointer components for the specific procedures. */
-  for (g = st->n.tb->u.generic; g; g = g->next)
-    {
-      if (!g->specific)
-	continue;
-      specific1 = g->specific_st->n.tb->u.specific->n.sym;
-
-      c = vtab->ts.u.derived->components;
-      specific2 = NULL;
-
-      /* Override identical specific interface.  */
-      if (vtab->ts.u.derived->components)
-	{
-	  for (; c; c= c->next)
-	    {
-	      specific2 = c->ts.interface;
-	      if (gfc_compare_interfaces (specific2, specific1,
-					  specific1->name, 0, 0, NULL, 0))
-		break;
-	    }
-	}
-
-      add_proc_component (c, vtab->ts.u.derived, g->specific_st,
-			  NULL, false, true);
-      vtab->ts.u.derived->attr.zero_comp = 0;
-    }
-}
-
-
-static void
-add_generics_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
-			       gfc_symbol *derived, bool resolved)
-{
-  gfc_component *cmp;
-  gfc_symtree *st = NULL;
-  gfc_symbol * vtab;
-  char name[2 * GFC_MAX_SYMBOL_LEN + 8];
-  gfc_symbol* super_type;
-
-  gcc_assert (resolved);
-
-  for (cmp = vtype->components; cmp; cmp = cmp->next)
-    {
-      if (cmp->ts.type != BT_DERIVED)
-	continue;
-
-      /* The only derived type that does not represent a generic
-	 procedure is the pointer to the parent vtab.  */
-      if (cmp->ts.u.derived
-	    && strcmp (cmp->ts.u.derived->name, "$extends") == 0)
-	continue;
-
-      /* Find the generic procedure using the component name.  */
-      st = gfc_find_typebound_proc (declared, NULL, cmp->name,
-				    true, NULL);
-      if (st == NULL)
-	st = gfc_find_typebound_user_op (declared, NULL, cmp->name,
-					 true, NULL);
-
-      /* Should be an error but we pass on it for now.  */
-      if (st == NULL || !st->n.tb->is_generic)
-	continue;
-
-      vtab = NULL;
-
-      /* Build a vtab and a special vtype, with only the procedure
-	 pointer fields, to carry the pointers to the specific
-	 procedures.  Should this name ever be changed, the same
-	 should be done in trans-expr.c(gfc_trans_assign_vtab_procs). */
-      sprintf (name, "vtab$%s$%s", vtype->name, cmp->name);
-      gfc_find_symbol (name, derived->ns, 0, &vtab);
-      if (vtab == NULL)
-	{
-	  gfc_get_symbol (name, derived->ns, &vtab);
-	  vtab->ts.type = BT_DERIVED;
-	  vtab->attr.flavor = FL_VARIABLE;
-	  vtab->attr.target = 1;
-	  vtab->attr.save = SAVE_EXPLICIT;
-	  vtab->attr.vtab = 1;
-	  vtab->refs++;
-	  gfc_set_sym_referenced (vtab);
-	  sprintf (name, "%s$%s", vtype->name, cmp->name);
-	  
-	  gfc_find_symbol (name, derived->ns, 0, &cmp->ts.u.derived);
-	  if (cmp->ts.u.derived == NULL
-		|| (strcmp (cmp->ts.u.derived->name, "$empty") == 0))
-	    {
-	      gfc_get_symbol (name, derived->ns, &cmp->ts.u.derived);
-	      if (gfc_add_flavor (&cmp->ts.u.derived->attr, FL_DERIVED,
-				  NULL, &gfc_current_locus) == FAILURE)
-		return;
-	      cmp->ts.u.derived->refs++;
-	      gfc_set_sym_referenced (cmp->ts.u.derived);
-	      cmp->ts.u.derived->attr.vtype = 1;
-	      cmp->ts.u.derived->attr.zero_comp = 1;
-	    }
-	  vtab->ts.u.derived = cmp->ts.u.derived;
-	}
-
-      /* Store this for later use in setting the pointer.  */
-      cmp->ts.interface = vtab;
-
-      if (vtab->ts.u.derived->components)
-	continue;
-
-      super_type = gfc_get_derived_super_type (declared);
-
-      if (super_type && (super_type != declared))
-	add_generic_specifics (super_type, vtab, cmp->name);
-
-      add_generic_specifics (declared, vtab, cmp->name);
-    }
-}
-
-
-/* Find the symbol for a derived type's vtab.  A vtab has the following
-   fields:
-   $hash	a hash value used to identify the derived type
-   $size	the size in bytes of the derived type
-   $extends	a pointer to the vtable of the parent derived type
-   then:
-   procedure pointer components for the specific typebound procedures
-   structure pointers to reduced vtabs that contain procedure
-   pointers to the specific procedures.  */
-
-gfc_symbol *
-gfc_find_derived_vtab (gfc_symbol *derived, bool resolved)
-{
-  gfc_namespace *ns;
-  gfc_symbol *vtab = NULL, *vtype = NULL;
-  char name[2 * GFC_MAX_SYMBOL_LEN + 8];
-
-  ns = gfc_current_ns;
-
-  for (; ns; ns = ns->parent)
-    if (!ns->parent)
-      break;
-
-  if (ns)
-    {
-      sprintf (name, "vtab$%s", derived->name);
-      gfc_find_symbol (name, ns, 0, &vtab);
-
-      if (vtab == NULL)
-	{
-	  gfc_get_symbol (name, ns, &vtab);
-	  vtab->ts.type = BT_DERIVED;
-	  vtab->attr.flavor = FL_VARIABLE;
-	  vtab->attr.target = 1;
-	  vtab->attr.save = SAVE_EXPLICIT;
-	  vtab->attr.vtab = 1;
-	  vtab->refs++;
-	  gfc_set_sym_referenced (vtab);
-	  sprintf (name, "vtype$%s", derived->name);
-	  
-	  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) == FAILURE)
-		return NULL;
-	      vtype->refs++;
-	      gfc_set_sym_referenced (vtype);
-
-	      /* Add component '$hash'.  */
-	      if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
-		return NULL;
-	      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) == FAILURE)
-		return NULL;
-	      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) == FAILURE)
-		return NULL;
-	      c->attr.pointer = 1;
-	      c->attr.access = ACCESS_PRIVATE;
-	      parent = gfc_get_derived_super_type (derived);
-	      if (parent)
-		{
-		  parent_vtab = gfc_find_derived_vtab (parent, resolved);
-		  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);
-		}
-
-	      add_procs_to_declared_vtab (derived, vtype, derived, resolved);
-	      vtype->attr.vtype = 1;
-	    }
-
-	  vtab->ts.u.derived = vtype;
-	  vtab->value = gfc_default_initializer (&vtab->ts);
-	}
-    }
-
-  /* Catch the call just before the backend declarations are built, so that
-     the generic procedures have been resolved and the specific procedures
-     have formal interfaces that can be compared.  */
-  if (resolved
-	&& vtab->ts.u.derived
-	&& vtab->ts.u.derived->backend_decl == NULL)
-    add_generics_to_declared_vtab (derived, vtab->ts.u.derived,
-				   derived, resolved);
-
-  return vtab;
-}
-
-
-/* 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, gfc_try* t,
-			 const char* name, bool noaccess, bool uop,
-			 locus* where)
-{
-  gfc_symtree* res;
-  gfc_symtree* root;
-
-  /* Set correct symbol-root.  */
-  gcc_assert (derived->f2k_derived);
-  root = (uop ? derived->f2k_derived->tb_uop_root
-	      : derived->f2k_derived->tb_sym_root);
-
-  /* Set default to failure.  */
-  if (t)
-    *t = FAILURE;
-
-  /* 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 = SUCCESS;
-
-      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 = FAILURE;
-	}
-
-      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, gfc_try* 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, gfc_try* 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, gfc_try* t,
-				 gfc_intrinsic_op op, bool noaccess,
-				 locus* where)
-{
-  gfc_typebound_proc* res;
-
-  /* Set default to failure.  */
-  if (t)
-    *t = FAILURE;
-
-  /* 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 = SUCCESS;
-
-      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 = FAILURE;
-	}
-
-      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;
-}