[multiple changes]

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/43896
	* symbol.c (add_proc_component,copy_vtab_proc_comps): Remove
	initializers for PPC members of the vtabs.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42274
	* symbol.c (add_proc_component,add_proc_comps): Correctly set the 'ppc'
	attribute for all PPC members of the vtypes.
	(copy_vtab_proc_comps): Copy the correct interface.
	* trans.h (gfc_trans_assign_vtab_procs): Modified prototype.
	* trans-expr.c (gfc_trans_assign_vtab_procs): Pass the derived type as
	a dummy argument and make sure all PPC members of the vtab are
	initialized correctly.
	(gfc_conv_derived_to_class,gfc_trans_class_assign): Additional argument
	in call to gfc_trans_assign_vtab_procs.
	* trans-stmt.c (gfc_trans_allocate): Ditto.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43326
	* resolve.c (resolve_typebound_function): Renamed
	resolve_class_compcall.Do all the detection of class references
	here.
	(resolve_typebound_subroutine): resolve_class_typebound_call
	renamed. Otherwise same as resolve_typebound_function.
	(gfc_resolve_expr): Call resolve_typebound_function.
	(resolve_code): Call resolve_typebound_subroutine.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/43492
	* resolve.c (resolve_typebound_generic_call): For CLASS methods
	pass back the specific symtree name, rather than the target
	name.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42353
	* resolve.c (resolve_structure_cons): Make the initializer of
	the vtab component 'extends' the same type as the component.

2010-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/42680
	* interface.c (check_interface1): Pass symbol name rather than NULL to
	gfc_compare_interfaces.(gfc_compare_interfaces): Add assert to
	trap MULL. (gfc_compare_derived_types): Revert previous change
	incorporated incorrectly during merge from trunk, r155778.
	* resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather
	than NULL to gfc_compare_interfaces.
	* symbol.c (add_generic_specifics): Likewise.

2010-02-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42353
	* interface.c (gfc_compare_derived_types): Add condition for vtype.
	* symbol.c (gfc_find_derived_vtab): Sey access to private.
	(gfc_find_derived_vtab): Likewise.
	* module.c (ab_attribute): Add enumerator AB_VTAB.
	(mio_symbol_attribute): Use new attribute, AB_VTAB.
	(check_for_ambiguous): Likewise.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
	    Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41829
	* trans-expr.c (select_class_proc): Remove function.
	(conv_function_val): Delete reference to previous.
	(gfc_conv_derived_to_class): Add second argument to the call to
	gfc_find_derived_vtab.
	(gfc_conv_structure): Exclude proc_pointer components when
	accessing $data field of class objects.
	(gfc_trans_assign_vtab_procs): New function.
	(gfc_trans_class_assign): Add second argument to the call to
	gfc_find_derived_vtab.
	* symbol.c (gfc_build_class_symbol): Add delayed_vtab arg and
	implement holding off searching for the vptr derived type.
	(add_proc_component): New function.
	(add_proc_comps): New function.
	(add_procs_to_declared_vtab1): New function.
	(copy_vtab_proc_comps): New function.
	(add_procs_to_declared_vtab): New function.
	(void add_generic_specifics): New function.
	(add_generics_to_declared_vtab): New function.
	(gfc_find_derived_vtab): Add second argument to the call to
	gfc_find_derived_vtab. Add the calls to
	add_procs_to_declared_vtab and add_generics_to_declared_vtab.
	* decl.c (build_sym, build_struct): Use new arg in calls to
	gfc_build_class_symbol.
	* gfortran.h : Add vtype bitfield to symbol_attr. Remove the
	definition of struct gfc_class_esym_list. Modify prototypes
	of gfc_build_class_symbol and gfc_find_derived_vtab.
	* trans-stmt.c (gfc_trans_allocate): Add second argument to the
	call to gfc_find_derived_vtab.
	* module.c : Add the vtype attribute.
	* trans.h : Add prototype for gfc_trans_assign_vtab_procs.
	* resolve.c (resolve_typebound_generic_call): Add second arg
	to pass along the generic name for class methods.
	(resolve_typebound_call): The same.
	(resolve_compcall): Use the second arg to carry the generic
	name from the above. Remove the reference to class_esym.
	(check_members, check_class_members, resolve_class_esym,
	hash_value_expr): Remove functions.
	(resolve_class_compcall, resolve_class_typebound_call): Modify
	to use vtable rather than member by member calls.
	(gfc_resolve_expr): Modify second arg in call to
	resolve_compcall.
	(resolve_select_type): Add second arg in call to
	gfc_find_derived_vtab.
	(resolve_code): Add second arg in call resolve_typebound_call.
	(resolve_fl_derived): Exclude vtypes from check for late
	procedure definitions. Likewise for checking of explicit
	interface and checking of pass arg.
	* iresolve.c (gfc_resolve_extends_type_of): Add second arg in
	calls to gfc_find_derived_vtab.
	* match.c (select_type_set_tmp): Use new arg in call to
	gfc_build_class_symbol.
	* trans-decl.c (gfc_get_symbol_decl): Complete vtable if
	necessary.
	* parse.c (endType): Finish incomplete classes.


2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42274
	* gfortran.dg/class_16.f03: New test.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42274
	* gfortran.dg/class_15.f03: New.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43326
	* gfortran.dg/dynamic_dispatch_9.f03: New test.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/43492
	* gfortran.dg/generic_22.f03 : New test.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42353
	* gfortran.dg/class_14.f03: New test.

2010-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/42680
	* gfortran.dg/interface_32.f90: New test.

2009-04-29  Paul Thomas  <pault@gcc.gnu.org>
	    Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41829
	* gfortran.dg/dynamic_dispatch_5.f03 : Change to "run".
	* gfortran.dg/dynamic_dispatch_7.f03 : New test.
	* gfortran.dg/dynamic_dispatch_8.f03 : New test.

From-SVN: r158910

24 files changed, 1231 insertions, 456 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5bde472..39368cb 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,127 @@
+2010-04-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43896
+	* symbol.c (add_proc_component,copy_vtab_proc_comps): Remove
+	initializers for PPC members of the vtabs.
+
+2010-04-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42274
+	* symbol.c (add_proc_component,add_proc_comps): Correctly set the 'ppc'
+	attribute for all PPC members of the vtypes.
+	(copy_vtab_proc_comps): Copy the correct interface.
+	* trans.h (gfc_trans_assign_vtab_procs): Modified prototype.
+	* trans-expr.c (gfc_trans_assign_vtab_procs): Pass the derived type as
+	a dummy argument and make sure all PPC members of the vtab are
+	initialized correctly.
+	(gfc_conv_derived_to_class,gfc_trans_class_assign): Additional argument
+	in call to gfc_trans_assign_vtab_procs.
+	* trans-stmt.c (gfc_trans_allocate): Ditto.
+
+2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43326
+	* resolve.c (resolve_typebound_function): Renamed
+	resolve_class_compcall.Do all the detection of class references
+	here.
+	(resolve_typebound_subroutine): resolve_class_typebound_call
+	renamed. Otherwise same as resolve_typebound_function.
+	(gfc_resolve_expr): Call resolve_typebound_function.
+	(resolve_code): Call resolve_typebound_subroutine.
+
+2010-04-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43492
+	* resolve.c (resolve_typebound_generic_call): For CLASS methods
+	pass back the specific symtree name, rather than the target
+	name.
+
+2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/42353
+	* resolve.c (resolve_structure_cons): Make the initializer of
+	the vtab component 'extends' the same type as the component.
+
+2010-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/42680
+	* interface.c (check_interface1): Pass symbol name rather than NULL to
+	gfc_compare_interfaces.(gfc_compare_interfaces): Add assert to
+	trap MULL. (gfc_compare_derived_types): Revert previous change
+	incorporated incorrectly during merge from trunk, r155778.
+	* resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather
+	than NULL to gfc_compare_interfaces.
+	* symbol.c (add_generic_specifics): Likewise.
+
+2010-02-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42353
+	* interface.c (gfc_compare_derived_types): Add condition for vtype.
+	* symbol.c (gfc_find_derived_vtab): Sey access to private.
+	(gfc_find_derived_vtab): Likewise.
+	* module.c (ab_attribute): Add enumerator AB_VTAB.
+	(mio_symbol_attribute): Use new attribute, AB_VTAB.
+	(check_for_ambiguous): Likewise.
+
+2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
+	    Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41829
+	* trans-expr.c (select_class_proc): Remove function.
+	(conv_function_val): Delete reference to previous.
+	(gfc_conv_derived_to_class): Add second argument to the call to
+	gfc_find_derived_vtab.
+	(gfc_conv_structure): Exclude proc_pointer components when
+	accessing $data field of class objects.
+	(gfc_trans_assign_vtab_procs): New function.
+	(gfc_trans_class_assign): Add second argument to the call to
+	gfc_find_derived_vtab.
+	* symbol.c (gfc_build_class_symbol): Add delayed_vtab arg and
+	implement holding off searching for the vptr derived type.
+	(add_proc_component): New function.
+	(add_proc_comps): New function.
+	(add_procs_to_declared_vtab1): New function.
+	(copy_vtab_proc_comps): New function.
+	(add_procs_to_declared_vtab): New function.
+	(void add_generic_specifics): New function.
+	(add_generics_to_declared_vtab): New function.
+	(gfc_find_derived_vtab): Add second argument to the call to
+	gfc_find_derived_vtab. Add the calls to
+	add_procs_to_declared_vtab and add_generics_to_declared_vtab.
+	* decl.c (build_sym, build_struct): Use new arg in calls to
+	gfc_build_class_symbol.
+	* gfortran.h : Add vtype bitfield to symbol_attr. Remove the
+	definition of struct gfc_class_esym_list. Modify prototypes
+	of gfc_build_class_symbol and gfc_find_derived_vtab.
+	* trans-stmt.c (gfc_trans_allocate): Add second argument to the
+	call to gfc_find_derived_vtab.
+	* module.c : Add the vtype attribute.
+	* trans.h : Add prototype for gfc_trans_assign_vtab_procs.
+	* resolve.c (resolve_typebound_generic_call): Add second arg
+	to pass along the generic name for class methods.
+	(resolve_typebound_call): The same.
+	(resolve_compcall): Use the second arg to carry the generic
+	name from the above. Remove the reference to class_esym.
+	(check_members, check_class_members, resolve_class_esym,
+	hash_value_expr): Remove functions.
+	(resolve_class_compcall, resolve_class_typebound_call): Modify
+	to use vtable rather than member by member calls.
+	(gfc_resolve_expr): Modify second arg in call to
+	resolve_compcall.
+	(resolve_select_type): Add second arg in call to
+	gfc_find_derived_vtab.
+	(resolve_code): Add second arg in call resolve_typebound_call.
+	(resolve_fl_derived): Exclude vtypes from check for late
+	procedure definitions. Likewise for checking of explicit
+	interface and checking of pass arg.
+	* iresolve.c (gfc_resolve_extends_type_of): Add second arg in
+	calls to gfc_find_derived_vtab.
+	* match.c (select_type_set_tmp): Use new arg in call to
+	gfc_build_class_symbol.
+	* trans-decl.c (gfc_get_symbol_decl): Complete vtable if
+	necessary.
+	* parse.c (endType): Finish incomplete classes.
+
 2010-04-28  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/18918
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 8851398..12dcf84 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1160,7 +1160,7 @@ build_sym (const char *name, gfc_charlen *cl,
       sym->attr.class_ok = (sym->attr.dummy
 			      || sym->attr.pointer
 			      || sym->attr.allocatable) ? 1 : 0;
-      gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
+      gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
     }
 
   return SUCCESS;
@@ -1570,7 +1570,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
 
 scalar:
   if (c->ts.type == BT_CLASS)
-    gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
+    gfc_build_class_symbol (&c->ts, &c->attr, &c->as, true);
 
   return t;
 }
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 48e80f6..11ce974 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -691,7 +691,8 @@ typedef struct
   unsigned extension:8;		/* extension level of a derived type.  */
   unsigned is_class:1;		/* is a CLASS container.  */
   unsigned class_ok:1;		/* is a CLASS object with correct attributes.  */
-  unsigned vtab:1;		/* is a derived type vtab.  */
+  unsigned vtab:1;		/* is a derived type vtab, pointed to by CLASS objects.  */
+  unsigned vtype:1;		/* is a derived type of a vtab.  */
 
   /* These flags are both in the typespec and attribute.  The attribute
      list is what gets read from/written to a module file.  The typespec
@@ -1615,17 +1616,6 @@ typedef struct gfc_intrinsic_sym
 gfc_intrinsic_sym;
 
 
-typedef struct gfc_class_esym_list
-{
-  gfc_symbol *derived;
-  gfc_symbol *esym;
-  struct gfc_expr *hash_value;
-  struct gfc_class_esym_list *next;
-}
-gfc_class_esym_list;
-
-#define gfc_get_class_esym_list() XCNEW (gfc_class_esym_list)
-
 /* Expression nodes.  The expression node types deserve explanations,
    since the last couple can be easily misconstrued:
 
@@ -1717,7 +1707,6 @@ typedef struct gfc_expr
       const char *name;	/* Points to the ultimate name of the function */
       gfc_intrinsic_sym *isym;
       gfc_symbol *esym;
-      gfc_class_esym_list *class_esym;
     }
     function;
 
@@ -2526,8 +2515,8 @@ 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 **);
-gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
+				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*);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 9dd797b..38adf9b 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1129,8 +1129,8 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
 	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
 	  continue;
 
-	if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag, 0,
-				    NULL, 0))
+	if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag,
+				    0, NULL, 0))
 	  {
 	    if (referenced)
 	      gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 0b75604..1c69f20 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -832,7 +832,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
     gfc_add_component_ref (a, "$vptr");
   else if (a->ts.type == BT_DERIVED)
     {
-      vtab = gfc_find_derived_vtab (a->ts.u.derived);
+      vtab = gfc_find_derived_vtab (a->ts.u.derived, false);
       /* Clear the old expr.  */
       gfc_free_ref_list (a->ref);
       memset (a, '\0', sizeof (gfc_expr));
@@ -848,7 +848,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
     gfc_add_component_ref (mo, "$vptr");
   else if (mo->ts.type == BT_DERIVED)
     {
-      vtab = gfc_find_derived_vtab (mo->ts.u.derived);
+      vtab = gfc_find_derived_vtab (mo->ts.u.derived, false);
       /* Clear the old expr.  */
       gfc_free_ref_list (mo->ref);
       memset (mo, '\0', sizeof (gfc_expr));
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 44e9f9d..5f25e96 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -4280,7 +4280,7 @@ select_type_set_tmp (gfc_typespec *ts)
   if (ts->type == BT_CLASS)
     {
       gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
-			      &tmp->n.sym->as);
+			      &tmp->n.sym->as, false);
       tmp->n.sym->attr.class_ok = 1;
     }
 
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index c58a67c..a419d6b 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1674,7 +1674,7 @@ typedef enum
   AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
   AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
   AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
-  AB_COARRAY_COMP
+  AB_COARRAY_COMP, AB_VTYPE, AB_VTAB
 }
 ab_attribute;
 
@@ -1720,6 +1720,8 @@ static const mstring attr_bits[] =
     minit ("IS_CLASS", AB_IS_CLASS),
     minit ("PROCEDURE", AB_PROCEDURE),
     minit ("PROC_POINTER", AB_PROC_POINTER),
+    minit ("VTYPE", AB_VTYPE),
+    minit ("VTAB", AB_VTAB),
     minit (NULL, -1)
 };
 
@@ -1880,6 +1882,10 @@ mio_symbol_attribute (symbol_attribute *attr)
 	MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
       if (attr->proc_pointer)
 	MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
+      if (attr->vtype)
+	MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
+      if (attr->vtab)
+	MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
 
       mio_rparen ();
 
@@ -2016,6 +2022,12 @@ mio_symbol_attribute (symbol_attribute *attr)
 	    case AB_PROC_POINTER:
 	      attr->proc_pointer = 1;
 	      break;
+	    case AB_VTYPE:
+	      attr->vtype = 1;
+	      break;
+	    case AB_VTAB:
+	      attr->vtab = 1;
+	      break;
 	    }
 	}
     }
@@ -4201,6 +4213,9 @@ check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
   if (st_sym == rsym)
     return false;
 
+  if (st_sym->attr.vtab || st_sym->attr.vtype)
+    return false;
+
   /* If the existing symbol is generic from a different module and
      the new symbol is generic there can be no ambiguity.  */
   if (st_sym->attr.generic
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index ef8931d..8ad52d2 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -2110,6 +2110,22 @@ endType:
 	  || c->attr.access == ACCESS_PRIVATE
 	  || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
 	sym->attr.private_comp = 1;
+
+     /* Fix up incomplete CLASS components.  */
+     if (c->ts.type == BT_CLASS)
+	{
+	  gfc_component *data;
+	  gfc_component *vptr;
+	  gfc_symbol *vtab;
+	  data = gfc_find_component (c->ts.u.derived, "$data", true, true);
+	  vptr = gfc_find_component (c->ts.u.derived, "$vptr", true, true);
+	  if (vptr->ts.u.derived == NULL)
+	    {
+	      vtab = gfc_find_derived_vtab (data->ts.u.derived, false);
+	      gcc_assert (vtab);
+	      vptr->ts.u.derived = vtab->ts.u.derived;
+	    }
+	}
     }
 
   if (!seen_component)
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 135eda4..93c5b48 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -898,7 +898,15 @@ resolve_structure_cons (gfc_expr *expr)
       if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
 	{
 	  t = FAILURE;
-	  if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
+	  if (strcmp (comp->name, "$extends") == 0)
+	    {
+	      /* Can afford to be brutal with the $extends initializer.
+		 The derived type can get lost because it is PRIVATE
+		 but it is not usage constrained by the standard.  */
+	      cons->expr->ts = comp->ts;
+	      t = SUCCESS;
+	    }
+	  else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
 	    gfc_error ("The element in the derived type constructor at %L, "
 		       "for pointer component '%s', is %s but should be %s",
 		       &cons->expr->where, comp->name,
@@ -1874,13 +1882,12 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
      
       /* Non-assumed length character functions.  */
       if (sym->attr.function && sym->ts.type == BT_CHARACTER
-	    && gsym->ns->proc_name->ts.u.cl != NULL
-	    && gsym->ns->proc_name->ts.u.cl->length != NULL)
+	  && gsym->ns->proc_name->ts.u.cl->length != NULL)
 	{
 	  gfc_charlen *cl = sym->ts.u.cl;
 
 	  if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
-                && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
+              && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
 	    {
               gfc_error ("Nonconstant character-length function '%s' at %L "
 			 "must have an explicit interface", sym->name,
@@ -5121,7 +5128,7 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
    the expression into a call of that binding.  */
 
 static gfc_try
-resolve_typebound_generic_call (gfc_expr* e)
+resolve_typebound_generic_call (gfc_expr* e, const char **name)
 {
   gfc_typebound_proc* genproc;
   const char* genname;
@@ -5177,6 +5184,10 @@ resolve_typebound_generic_call (gfc_expr* e)
 	  if (matches)
 	    {
 	      e->value.compcall.tbp = g->specific;
+	      /* Pass along the name for CLASS methods, where the vtab
+		 procedure pointer component has to be referenced.  */
+	      if (name)
+		*name = g->specific_st->name;
 	      goto success;
 	    }
 	}
@@ -5195,7 +5206,7 @@ success:
 /* Resolve a call to a type-bound subroutine.  */
 
 static gfc_try
-resolve_typebound_call (gfc_code* c)
+resolve_typebound_call (gfc_code* c, const char **name)
 {
   gfc_actual_arglist* newactual;
   gfc_symtree* target;
@@ -5211,7 +5222,12 @@ resolve_typebound_call (gfc_code* c)
   if (check_typebound_baseobject (c->expr1) == FAILURE)
     return FAILURE;
 
-  if (resolve_typebound_generic_call (c->expr1) == FAILURE)
+  /* Pass along the name for CLASS methods, where the vtab
+     procedure pointer component has to be referenced.  */
+  if (name)
+    *name = c->expr1->value.compcall.name;
+
+  if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
     return FAILURE;
 
   /* Transform into an ordinary EXEC_CALL for now.  */
@@ -5235,31 +5251,20 @@ resolve_typebound_call (gfc_code* c)
 }
 
 
-/* Resolve a component-call expression.  This originally was intended
-   only to see functions.  However, it is convenient to use it in 
-   resolving subroutine class methods, since we do not have to add a
-   gfc_code each time. */
+/* Resolve a component-call expression.  */
 static gfc_try
-resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
+resolve_compcall (gfc_expr* e, const char **name)
 {
   gfc_actual_arglist* newactual;
   gfc_symtree* target;
 
   /* Check that's really a FUNCTION.  */
-  if (fcn && !e->value.compcall.tbp->function)
+  if (!e->value.compcall.tbp->function)
     {
       gfc_error ("'%s' at %L should be a FUNCTION",
 		 e->value.compcall.name, &e->where);
       return FAILURE;
     }
-  else if (!fcn && !e->value.compcall.tbp->subroutine)
-    {
-      /* To resolve class member calls, we borrow this bit
-         of code to select the specific procedures.  */
-      gfc_error ("'%s' at %L should be a SUBROUTINE",
-		 e->value.compcall.name, &e->where);
-      return FAILURE;
-    }
 
   /* These must not be assign-calls!  */
   gcc_assert (!e->value.compcall.assign);
@@ -5267,7 +5272,12 @@ resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
   if (check_typebound_baseobject (e) == FAILURE)
     return FAILURE;
 
-  if (resolve_typebound_generic_call (e) == FAILURE)
+  /* Pass along the name for CLASS methods, where the vtab
+     procedure pointer component has to be referenced.  */
+  if (name)
+    *name = e->value.compcall.name;
+
+  if (resolve_typebound_generic_call (e, name) == FAILURE)
     return FAILURE;
   gcc_assert (!e->value.compcall.tbp->is_generic);
 
@@ -5284,169 +5294,15 @@ resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
   e->value.function.actual = newactual;
   e->value.function.name = NULL;
   e->value.function.esym = target->n.sym;
-  e->value.function.class_esym = NULL;
   e->value.function.isym = NULL;
   e->symtree = target;
   e->ts = target->n.sym->ts;
   e->expr_type = EXPR_FUNCTION;
 
-  /* Resolution is not necessary when constructing component calls
-     for class members, since this must only be done for the
-     declared type, which is done afterwards.  */
-  return !class_members ? gfc_resolve_expr (e) : SUCCESS;
-}
-
-
-/* Resolve a typebound call for the members in a class.  This group of
-   functions implements dynamic dispatch in the provisional version
-   of f03 OOP.  As soon as vtables are in place and contain pointers
-   to methods, this will no longer be necessary.  */
-static gfc_expr *list_e;
-static gfc_try check_class_members (gfc_symbol *);
-static gfc_try class_try;
-static bool fcn_flag;
-
-
-static void
-check_members (gfc_symbol *derived)
-{
-  if (derived->attr.flavor == FL_DERIVED)
-    (void) check_class_members (derived);
-}
-
-
-static gfc_try 
-check_class_members (gfc_symbol *derived)
-{
-  gfc_expr *e;
-  gfc_symtree *tbp;
-  gfc_class_esym_list *etmp;
-
-  e = gfc_copy_expr (list_e);
-
-  tbp = gfc_find_typebound_proc (derived, &class_try,
-				 e->value.compcall.name,
-				 false, &e->where);
-
-  if (tbp == NULL)
-    {
-      gfc_error ("no typebound available procedure named '%s' at %L",
-		 e->value.compcall.name, &e->where);
-      return FAILURE;
-    }
-
-  /* If we have to match a passed class member, force the actual
-      expression to have the correct type.  */
-  if (!tbp->n.tb->nopass)
-    {
-      if (e->value.compcall.base_object == NULL)
-	e->value.compcall.base_object = extract_compcall_passed_object (e);
-
-      if (e->value.compcall.base_object == NULL)
-	return FAILURE;
-
-      if (!derived->attr.abstract)
-	{
-	  e->value.compcall.base_object->ts.type = BT_DERIVED;
-	  e->value.compcall.base_object->ts.u.derived = derived;
-	}
-    }
-
-  e->value.compcall.tbp = tbp->n.tb;
-  e->value.compcall.name = tbp->name;
-
-  /* Let the original expresssion catch the assertion in
-     resolve_compcall, since this flag does not appear to be reset or
-     copied in some systems.  */
-  e->value.compcall.assign = 0;
-
-  /* Do the renaming, PASSing, generic => specific and other
-     good things for each class member.  */
-  class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS)
-				? class_try : FAILURE;
-
-  /* Now transfer the found symbol to the esym list.  */
-  if (class_try == SUCCESS)
-    {
-      etmp = list_e->value.function.class_esym;
-      list_e->value.function.class_esym
-		= gfc_get_class_esym_list();
-      list_e->value.function.class_esym->next = etmp;
-      list_e->value.function.class_esym->derived = derived;
-      list_e->value.function.class_esym->esym
-		= e->value.function.esym;
-    }
-
-  gfc_free_expr (e);
-  
-  /* Burrow down into grandchildren types.  */
-  if (derived->f2k_derived)
-    gfc_traverse_ns (derived->f2k_derived, check_members);
-
-  return SUCCESS;
-}
-
-
-/* Eliminate esym_lists where all the members point to the
-   typebound procedure of the declared type; ie. one where
-   type selection has no effect..  */
-static void
-resolve_class_esym (gfc_expr *e)
-{
-  gfc_class_esym_list *p, *q;
-  bool empty = true;
-
-  gcc_assert (e && e->expr_type == EXPR_FUNCTION);
-
-  p = e->value.function.class_esym;
-  if (p == NULL)
-    return;
-
-  for (; p; p = p->next)
-    empty = empty && (e->value.function.esym == p->esym);
-
-  if (empty)
-    {
-      p = e->value.function.class_esym;
-      for (; p; p = q)
-	{
-	  q = p->next;
-	  gfc_free (p);
-	}
-      e->value.function.class_esym = NULL;
-   }
-}
-
-
-/* Generate an expression for the hash value, given the reference to
-   the class of the final expression (class_ref), the base of the
-   full reference list (new_ref), the declared type and the class
-   object (st).  */
-static gfc_expr*
-hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st)
-{
-  gfc_expr *hash_value;
-
-  /* Build an expression for the correct hash_value; ie. that of the last
-     CLASS reference.  */
-  if (class_ref)
-    {
-      class_ref->next = NULL;
-    }
-  else
-    {
-      gfc_free_ref_list (new_ref);
-      new_ref = NULL;
-    }
-  hash_value = gfc_get_expr ();
-  hash_value->expr_type = EXPR_VARIABLE;
-  hash_value->symtree = st;
-  hash_value->symtree->n.sym->refs++;
-  hash_value->ref = new_ref;
-  gfc_add_component_ref (hash_value, "$vptr");
-  gfc_add_component_ref (hash_value, "$hash");
-
-  return hash_value;
+  /* Resolution is not necessary if this is a class subroutine; this
+     function only has to identify the specific proc. Resolution of
+     the call will be done next in resolve_typebound_call.  */
+  return gfc_resolve_expr (e);
 }
 
 
@@ -5483,146 +5339,151 @@ get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
 }
 
 
-/* Resolve the argument expressions so that any arguments expressions
-   that include class methods are resolved before the current call.
-   This is necessary because of the static variables used in CLASS
-   method resolution.  */
-static void
-resolve_arg_exprs (gfc_actual_arglist *arg)
-{ 
-  /* Resolve the actual arglist expressions.  */
-  for (; arg; arg = arg->next)
-    {
-      if (arg->expr)
-	gfc_resolve_expr (arg->expr);
-    }
-}
-
-
-/* Resolve a typebound function, or 'method'.  First separate all
-   the non-CLASS references by calling resolve_compcall directly.
-   Then treat the CLASS references by resolving for each of the class
-   members in turn.  */
+/* Resolve a typebound function, or 'method'. First separate all
+   the non-CLASS references by calling resolve_compcall directly.  */
 
 static gfc_try
 resolve_typebound_function (gfc_expr* e)
 {
-  gfc_symbol *derived, *declared;
+  gfc_symbol *declared;
+  gfc_component *c;
   gfc_ref *new_ref;
   gfc_ref *class_ref;
   gfc_symtree *st;
+  const char *name;
+  const char *genname;
+  gfc_typespec ts;
 
   st = e->symtree;
   if (st == NULL)
-    return resolve_compcall (e, true, false);
+    return resolve_compcall (e, NULL);
 
   /* Get the CLASS declared type.  */
   declared = get_declared_from_expr (&class_ref, &new_ref, e);
 
   /* Weed out cases of the ultimate component being a derived type.  */
   if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
-	|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
+	 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
     {
       gfc_free_ref_list (new_ref);
-      return resolve_compcall (e, true, false);
+      return resolve_compcall (e, NULL);
     }
 
-  /* Resolve the argument expressions,  */
-  resolve_arg_exprs (e->value.function.actual); 
+  c = gfc_find_component (declared, "$data", true, true);
+  declared = c->ts.u.derived;
 
-  /* Get the data component, which is of the declared type.  */
-  derived = declared->components->ts.u.derived;
+  /* Keep the generic name so that the vtab reference can be made.  */
+  genname = NULL; 
+  if (e->value.compcall.tbp->is_generic)
+    genname = e->value.compcall.name;
 
-  /* Resolve the function call for each member of the class.  */
-  class_try = SUCCESS;
-  fcn_flag = true;
-  list_e = gfc_copy_expr (e);
-
-  if (check_class_members (derived) == FAILURE)
-    return FAILURE;
+  /* Treat the call as if it is a typebound procedure, in order to roll
+     out the correct name for the specific function.  */
+  resolve_compcall (e, &name);
+  ts = e->ts;
 
-  class_try = (resolve_compcall (e, true, false) == SUCCESS)
-		 ? class_try : FAILURE;
+  /* Then convert the expression to a procedure pointer component call.  */
+  e->value.function.esym = NULL;
+  e->symtree = st;
 
-  /* Transfer the class list to the original expression.  Note that
-     the class_esym list is cleaned up in trans-expr.c, as the calls
-     are translated.  */
-  e->value.function.class_esym = list_e->value.function.class_esym;
-  list_e->value.function.class_esym = NULL;
-  gfc_free_expr (list_e);
-
-  resolve_class_esym (e);
+  if (class_ref)  
+    {
+      gfc_free_ref_list (class_ref->next);
+      e->ref = new_ref;
+    }
 
-  /* More than one typebound procedure so transmit an expression for
-     the hash_value as the selector.  */
-  if (e->value.function.class_esym != NULL)
-    e->value.function.class_esym->hash_value
-		= hash_value_expr (class_ref, new_ref, st);
+  /* '$vptr' points to the vtab, which contains the procedure pointers.  */
+  gfc_add_component_ref (e, "$vptr");
+  if (genname)
+    {
+      /* A generic procedure needs the subsidiary vtabs and vtypes for
+	 the specific procedures to have been build.  */
+      gfc_symbol *vtab;
+      vtab = gfc_find_derived_vtab (declared, true);
+      gcc_assert (vtab);
+      gfc_add_component_ref (e, genname);
+    }
+  gfc_add_component_ref (e, name);
 
-  return class_try;
+  /* Recover the typespec for the expression.  This is really only
+     necessary for generic procedures, where the additional call
+     to gfc_add_component_ref seems to throw the collection of the
+     correct typespec.  */
+  e->ts = ts;
+  return SUCCESS;
 }
 
-/* Resolve a typebound subroutine, or 'method'.  First separate all
-   the non-CLASS references by calling resolve_typebound_call directly.
-   Then treat the CLASS references by resolving for each of the class
-   members in turn.  */
+/* Resolve a typebound subroutine, or 'method'. First separate all
+   the non-CLASS references by calling resolve_typebound_call
+   directly.  */
 
 static gfc_try
 resolve_typebound_subroutine (gfc_code *code)
 {
-  gfc_symbol *derived, *declared;
+  gfc_symbol *declared;
+  gfc_component *c;
   gfc_ref *new_ref;
   gfc_ref *class_ref;
   gfc_symtree *st;
+  const char *genname;
+  const char *name;
+  gfc_typespec ts;
 
   st = code->expr1->symtree;
   if (st == NULL)
-    return resolve_typebound_call (code);
+    return resolve_typebound_call (code, NULL);
 
   /* Get the CLASS declared type.  */
   declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
 
   /* Weed out cases of the ultimate component being a derived type.  */
   if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
-	|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
+	 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
     {
       gfc_free_ref_list (new_ref);
-      return resolve_typebound_call (code);
+      return resolve_typebound_call (code, NULL);
     } 
 
-  /* Resolve the argument expressions,  */
-  resolve_arg_exprs (code->expr1->value.compcall.actual); 
-
-  /* Get the data component, which is of the declared type.  */
-  derived = declared->components->ts.u.derived;
+  c = gfc_find_component (declared, "$data", true, true);
+  declared = c->ts.u.derived;
 
-  class_try = SUCCESS;
-  fcn_flag = false;
-  list_e = gfc_copy_expr (code->expr1);
-
-  if (check_class_members (derived) == FAILURE)
-    return FAILURE;
+  /* Keep the generic name so that the vtab reference can be made.  */
+  genname = NULL; 
+  if (code->expr1->value.compcall.tbp->is_generic)
+    genname = code->expr1->value.compcall.name;
 
-  class_try = (resolve_typebound_call (code) == SUCCESS)
-		 ? class_try : FAILURE;
+  resolve_typebound_call (code, &name);
+  ts = code->expr1->ts;
 
-  /* Transfer the class list to the original expression.  Note that
-     the class_esym list is cleaned up in trans-expr.c, as the calls
-     are translated.  */
-  code->expr1->value.function.class_esym
-			= list_e->value.function.class_esym;
-  list_e->value.function.class_esym = NULL;
-  gfc_free_expr (list_e);
+  /* Then convert the expression to a procedure pointer component call.  */
+  code->expr1->value.function.esym = NULL;
+  code->expr1->symtree = st;
 
-  resolve_class_esym (code->expr1);
+  if (class_ref)  
+    {
+      gfc_free_ref_list (class_ref->next);
+      code->expr1->ref = new_ref;
+    }
 
-  /* More than one typebound procedure so transmit an expression for
-     the hash_value as the selector.  */
-  if (code->expr1->value.function.class_esym != NULL)
-    code->expr1->value.function.class_esym->hash_value
-		= hash_value_expr (class_ref, new_ref, st);
+  /* '$vptr' points to the vtab, which contains the procedure pointers.  */
+  gfc_add_component_ref (code->expr1, "$vptr");
+  if (genname)
+    {
+      /* A generic procedure needs the subsidiary vtabs and vtypes for
+	 the specific procedures to have been build.  */
+      gfc_symbol *vtab;
+      vtab = gfc_find_derived_vtab (declared, true);
+      gcc_assert (vtab);
+      gfc_add_component_ref (code->expr1, genname);
+    }
+  gfc_add_component_ref (code->expr1, name);
 
-  return class_try;
+  /* Recover the typespec for the expression.  This is really only
+     necessary for generic procedures, where the additional call
+     to gfc_add_component_ref seems to throw the collection of the
+     correct typespec.  */
+  code->expr1->ts = ts;
+  return SUCCESS;
 }
 
 
@@ -7372,7 +7233,7 @@ resolve_select_type (gfc_code *code)
 	  tail->next = NULL;
 	  default_case = tail;
 	}
-      
+
       /* More than one CLASS IS block?  */
       if (class_is->block)
 	{
@@ -7428,7 +7289,7 @@ resolve_select_type (gfc_code *code)
 	  new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
 	  new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
 	  gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
-	  vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
+	  vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived, true);
 	  st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
 	  new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
 	  new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
@@ -10743,7 +10604,7 @@ resolve_fl_derived (gfc_symbol *sym)
 
       if (c->attr.proc_pointer && c->ts.interface)
 	{
-	  if (c->ts.interface->attr.procedure)
+	  if (c->ts.interface->attr.procedure && !sym->attr.vtype)
 	    gfc_error ("Interface '%s', used by procedure pointer component "
 		       "'%s' at %L, is declared in a later PROCEDURE statement",
 		       c->ts.interface->name, c->name, &c->loc);
@@ -10807,7 +10668,7 @@ resolve_fl_derived (gfc_symbol *sym)
 		  c->ts.u.cl = cl;
 		}
 	    }
-	  else if (c->ts.interface->name[0] != '\0')
+	  else if (c->ts.interface->name[0] != '\0' && !sym->attr.vtype)
 	    {
 	      gfc_error ("Interface '%s' of procedure pointer component "
 			 "'%s' at %L must be explicit", c->ts.interface->name,
@@ -10823,7 +10684,8 @@ resolve_fl_derived (gfc_symbol *sym)
 	}
 
       /* Procedure pointer components: Check PASS arg.  */
-      if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0)
+      if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
+	  && !sym->attr.vtype)
 	{
 	  gfc_symbol* me_arg;
 
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 4356845..b19714c 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4708,7 +4708,7 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
 
 gfc_try
 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
-			gfc_array_spec **as)
+			gfc_array_spec **as, bool delayed_vtab)
 {
   char name[GFC_MAX_SYMBOL_LEN + 5];
   gfc_symbol *fclass;
@@ -4763,9 +4763,14 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
 	return FAILURE;
       c->ts.type = BT_DERIVED;
-      vtab = gfc_find_derived_vtab (ts->u.derived);
-      gcc_assert (vtab);
-      c->ts.u.derived = vtab->ts.u.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;
     }
 
@@ -4787,10 +4792,344 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 }
 
 
-/* Find the symbol for a derived type's vtab.  */
+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)
+gfc_find_derived_vtab (gfc_symbol *derived, bool resolved)
 {
   gfc_namespace *ns;
   gfc_symbol *vtab = NULL, *vtype = NULL;
@@ -4815,7 +5154,6 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	  vtab->attr.target = 1;
 	  vtab->attr.save = SAVE_EXPLICIT;
 	  vtab->attr.vtab = 1;
-	  vtab->attr.access = ACCESS_PRIVATE;
 	  vtab->refs++;
 	  gfc_set_sym_referenced (vtab);
 	  sprintf (name, "vtype$%s", derived->name);
@@ -4832,7 +5170,6 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		return NULL;
 	      vtype->refs++;
 	      gfc_set_sym_referenced (vtype);
-	      vtype->attr.access = ACCESS_PRIVATE;
 
 	      /* Add component '$hash'.  */
 	      if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
@@ -4864,13 +5201,13 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	      parent = gfc_get_derived_super_type (derived);
 	      if (parent)
 		{
-		  parent_vtab = gfc_find_derived_vtab (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);
+		  gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
+				     0, &c->initializer->symtree);
 		}
 	      else
 		{
@@ -4878,13 +5215,25 @@ gfc_find_derived_vtab (gfc_symbol *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->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;
 }
 
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 11a75b4..2ad4e73 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1070,6 +1070,15 @@ gfc_get_symbol_decl (gfc_symbol * sym)
   else
     byref = 0;
 
+  /* Make sure that the vtab for the declared type is completed.  */
+  if (sym->ts.type == BT_CLASS)
+    {
+      gfc_component *c = gfc_find_component (sym->ts.u.derived,
+					     "$data", true, true);
+      if (!c->ts.u.derived->backend_decl)
+	gfc_find_derived_vtab (c->ts.u.derived, true);
+    }
+
   if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
     {
       /* Return via extra parameter.  */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index dc138a3..dfd38cc 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1532,141 +1532,11 @@ get_proc_ptr_comp (gfc_expr *e)
 }
 
 
-/* Select a class typebound procedure at runtime.  */
-static void
-select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
-		   tree declared, gfc_expr *expr)
-{
-  tree end_label;
-  tree label;
-  tree tmp;
-  tree hash;
-  stmtblock_t body;
-  gfc_class_esym_list *next_elist, *tmp_elist;
-  gfc_se tmpse;
-
-  /* Convert the hash expression.  */
-  gfc_init_se (&tmpse, NULL);
-  gfc_conv_expr (&tmpse, elist->hash_value);
-  gfc_add_block_to_block (&se->pre, &tmpse.pre);
-  hash = gfc_evaluate_now (tmpse.expr, &se->pre);
-  gfc_add_block_to_block (&se->post, &tmpse.post);
-
-  /* Fix the function type to be that of the declared type method.  */
-  declared = gfc_create_var (TREE_TYPE (declared), "method");
-
-  end_label = gfc_build_label_decl (NULL_TREE);
-
-  gfc_init_block (&body);
-
-  /* Go through the list of extensions.  */
-  for (; elist; elist = next_elist)
-    {
-      /* This case has already been added.  */
-      if (elist->derived == NULL)
-	goto free_elist;
-
-      /* Skip abstract base types.  */
-      if (elist->derived->attr.abstract)
-       goto free_elist;
-
-      /* Run through the chain picking up all the cases that call the
-	 same procedure.  */
-      tmp_elist = elist;
-      for (; elist; elist = elist->next)
-	{
-	  tree cval;
-
-	  if (elist->esym != tmp_elist->esym)
-	    continue;
-
-	  cval = build_int_cst (TREE_TYPE (hash),
-				elist->derived->hash_value);
-	  /* Build a label for the hash value.  */
-	  label = gfc_build_label_decl (NULL_TREE);
-	  tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
-			     cval, NULL_TREE, label);
-	  gfc_add_expr_to_block (&body, tmp);
-
-	  /* Null the reference the derived type so that this case is
-	     not used again.  */
-	  elist->derived = NULL;
-	}
-
-      elist = tmp_elist;
-
-      /* Get a pointer to the procedure,  */
-      tmp = gfc_get_symbol_decl (elist->esym);
-      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
-	{
-	  gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
-	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
-	}
-
-      /* Assign the pointer to the appropriate procedure.  */
-      gfc_add_modify (&body, declared,
-		      fold_convert (TREE_TYPE (declared), tmp));
-
-      /* Break to the end of the construct.  */
-      tmp = build1_v (GOTO_EXPR, end_label);
-      gfc_add_expr_to_block (&body, tmp);
-
-      /* Free the elists as we go; freeing them in gfc_free_expr causes
-	 segfaults because it occurs too early and too often.  */
-    free_elist:
-      next_elist = elist->next;
-      if (elist->hash_value)
-	gfc_free_expr (elist->hash_value);
-      gfc_free (elist);
-      elist = NULL;
-    }
-
-  /* Default is an error.  */
-  label = gfc_build_label_decl (NULL_TREE);
-  tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
-		     NULL_TREE, NULL_TREE, label);
-  gfc_add_expr_to_block (&body, tmp);
-  tmp = gfc_trans_runtime_error (true, &expr->where,
-		"internal error: bad hash value in dynamic dispatch");
-  gfc_add_expr_to_block (&body, tmp);
-
-  /* Write the switch expression.  */
-  tmp = gfc_finish_block (&body);
-  tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE);
-  gfc_add_expr_to_block (&se->pre, tmp);
-
-  tmp = build1_v (LABEL_EXPR, end_label);
-  gfc_add_expr_to_block (&se->pre, tmp);
-
-  se->expr = declared;
-  return;
-}
-
-
 static void
 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
 {
   tree tmp;
 
-  if (expr && expr->symtree
-	&& expr->value.function.class_esym)
-    {
-      if (!sym->backend_decl)
-	sym->backend_decl = gfc_get_extern_function_decl (sym);
-
-      tmp = sym->backend_decl;
-
-      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
-	{
-	  gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
-	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
-	}
-
-      select_class_proc (se, expr->value.function.class_esym,
-			 tmp, expr);
-      return;
-    }
-
   if (gfc_is_proc_ptr_comp (expr, NULL))
     tmp = get_proc_ptr_comp (expr);
   else if (sym->attr.dummy)
@@ -2614,8 +2484,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 
   /* Remember the vtab corresponds to the derived type
     not to the class declared type.  */
-  vtab = gfc_find_derived_vtab (e->ts.u.derived);
+  vtab = gfc_find_derived_vtab (e->ts.u.derived, true);
   gcc_assert (vtab);
+  gfc_trans_assign_vtab_procs (&parmse->pre, e->ts.u.derived, vtab);
   tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
   gfc_add_modify (&parmse->pre, ctree,
 		  fold_convert (TREE_TYPE (ctree), tmp));
@@ -4463,7 +4334,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
       if (!c->expr || cm->attr.allocatable)
         continue;
 
-      if (cm->ts.type == BT_CLASS)
+      if (cm->ts.type == BT_CLASS && !cm->attr.proc_pointer)
 	{
 	  gfc_component *data;
 	  data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
@@ -4484,10 +4355,11 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
       else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
 	       && strcmp (cm->name, "$extends") == 0)
 	{
+	  tree vtab;
 	  gfc_symbol *vtabs;
 	  vtabs = cm->initializer->symtree->n.sym;
-	  val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
-	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+	  vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
+	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
 	}
       else
 	{
@@ -5579,6 +5451,103 @@ gfc_trans_assign (gfc_code * code)
 }
 
 
+/* Generate code to assign typebound procedures to a derived vtab.  */
+void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt,
+				  gfc_symbol *vtab)
+{
+  gfc_component *cmp;
+  tree vtb;
+  tree ctree;
+  tree proc;
+  tree cond = NULL_TREE;
+  stmtblock_t body;
+  bool seen_extends;
+
+  /* Point to the first procedure pointer.  */
+  cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true);
+
+  seen_extends = (cmp != NULL);
+
+  vtb = gfc_get_symbol_decl (vtab);
+
+  if (seen_extends)
+    {
+      cmp = cmp->next;
+      if (!cmp)
+	return;
+      ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+		           vtb, cmp->backend_decl, NULL_TREE);
+      cond = fold_build2 (EQ_EXPR, boolean_type_node, ctree,
+			   build_int_cst (TREE_TYPE (ctree), 0));
+    }
+  else
+    {
+      cmp = vtab->ts.u.derived->components; 
+    }
+
+  gfc_init_block (&body);
+  for (; cmp; cmp = cmp->next)
+    {
+      gfc_symbol *target = NULL;
+      
+      /* Generic procedure - build its vtab.  */
+      if (cmp->ts.type == BT_DERIVED && !cmp->tb)
+	{
+	  gfc_symbol *vt = cmp->ts.interface;
+
+	  if (vt == NULL)
+	    {
+	      /* Use association loses the interface.  Obtain the vtab
+		 by name instead.  */
+	      char name[2 * GFC_MAX_SYMBOL_LEN + 8];
+	      sprintf (name, "vtab$%s$%s", vtab->ts.u.derived->name,
+		       cmp->name);
+	      gfc_find_symbol (name, vtab->ns, 0, &vt);
+	      if (vt == NULL)
+		continue;
+	    }
+
+	  gfc_trans_assign_vtab_procs (&body, dt, vt);
+	  ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+			       vtb, cmp->backend_decl, NULL_TREE);
+	  proc = gfc_get_symbol_decl (vt);
+	  proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
+	  gfc_add_modify (&body, ctree, proc);
+	  continue;
+	}
+
+      /* This is required when typebound generic procedures are called
+	 with derived type targets.  The specific procedures do not get
+	 added to the vtype, which remains "empty".  */
+      if (cmp->tb && cmp->tb->u.specific && cmp->tb->u.specific->n.sym)
+	target = cmp->tb->u.specific->n.sym;
+      else
+	{
+	  gfc_symtree *st;
+	  st = gfc_find_typebound_proc (dt, NULL, cmp->name, false, NULL);
+	  if (st->n.tb && st->n.tb->u.specific)
+	    target = st->n.tb->u.specific->n.sym;
+	}
+
+      if (!target)
+	continue;
+
+      ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+			   vtb, cmp->backend_decl, NULL_TREE);
+      proc = gfc_get_symbol_decl (target);
+      proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
+      gfc_add_modify (&body, ctree, proc);
+    }
+
+  proc = gfc_finish_block (&body);
+
+  if (seen_extends)
+    proc = build3_v (COND_EXPR, cond, proc, build_empty_stmt (input_location));
+
+  gfc_add_expr_to_block (block, proc);
+}
+
+
 /* Translate an assignment to a CLASS object
    (pointer or ordinary assignment).  */
 
@@ -5620,9 +5589,9 @@ gfc_trans_class_assign (gfc_code *code)
 	{
 	  gfc_symbol *vtab;
 	  gfc_symtree *st;
-	  vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
+	  vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived, true);
 	  gcc_assert (vtab);
-
+	  gfc_trans_assign_vtab_procs (&block, code->expr2->ts.u.derived, vtab);
 	  rhs = gfc_get_expr ();
 	  rhs->expr_type = EXPR_VARIABLE;
 	  gfc_find_sym_tree (vtab->name, NULL, 1, &st);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index edffb9b..0a2ad53 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -4278,8 +4278,9 @@ gfc_trans_allocate (gfc_code * code)
 
 	      if (ts->type == BT_DERIVED)
 		{
-		  vtab = gfc_find_derived_vtab (ts->u.derived);
+		  vtab = gfc_find_derived_vtab (ts->u.derived, true);
 		  gcc_assert (vtab);
+		  gfc_trans_assign_vtab_procs (&block, ts->u.derived, vtab);
 		  gfc_init_se (&lse, NULL);
 		  lse.want_pointer = 1;
 		  gfc_conv_expr (&lse, lhs);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index b332c8e..8e2b688 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -492,6 +492,9 @@ tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool);
 /* Generate code for a pointer assignment.  */
 tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);
 
+/* Generate code to assign typebound procedures to a derived vtab.  */
+void gfc_trans_assign_vtab_procs (stmtblock_t*, gfc_symbol*, gfc_symbol*);
+
 /* Initialize function decls for library functions.  */
 void gfc_build_intrinsic_lib_fndecls (void);
 /* Create function decls for IO library functions.  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 07e7e50..7b9a134 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,41 @@
+2010-04-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42274
+	* gfortran.dg/class_16.f03: New test.
+
+2010-04-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42274
+	* gfortran.dg/class_15.f03: New.
+
+2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43326
+	* gfortran.dg/dynamic_dispatch_9.f03: New test.
+
+2010-04-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43492
+	* gfortran.dg/generic_22.f03 : New test.
+
+2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/42353
+	* gfortran.dg/class_14.f03: New test.
+
+2010-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/42680
+	* gfortran.dg/interface_32.f90: New test.
+
+2009-04-29  Paul Thomas  <pault@gcc.gnu.org>
+	    Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41829
+	* gfortran.dg/dynamic_dispatch_5.f03 : Change to "run".
+	* gfortran.dg/dynamic_dispatch_7.f03 : New test.
+	* gfortran.dg/dynamic_dispatch_8.f03 : New test.
+
 2010-04-28  Mike Stump  <mikestump@comcast.net>
 
 	* g++.dg/uninit-pred-1_b.C: Use dg-message instead of
diff --git a/gcc/testsuite/gfortran.dg/class_14.f03 b/gcc/testsuite/gfortran.dg/class_14.f03
new file mode 100644
index 0000000..9b06b01
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_14.f03
@@ -0,0 +1,54 @@
+! { dg-do "compile" }
+! Test the final fix for PR42353, in which a compilation error was
+! occurring because the derived type of the initializer of the vtab
+! component '$extends' was not the same as that of the component.
+!
+! Contributed by Harald Anlauf <anlauf@gmx.de>
+!
+module abstract_vector
+  implicit none
+
+  type, abstract :: vector_class
+  end type vector_class
+end module abstract_vector
+!-------------------------
+module concrete_vector
+  use abstract_vector
+  implicit none
+
+  type, extends(vector_class) :: trivial_vector_type
+  end type trivial_vector_type
+
+  private :: my_assign
+contains
+  subroutine my_assign (this,v)
+    class(trivial_vector_type), intent(inout) :: this
+    class(vector_class),        intent(in)    :: v
+  end subroutine my_assign
+end module concrete_vector
+!---------------------------
+module concrete_gradient
+  use abstract_vector
+  implicit none
+
+  type, abstract, extends(vector_class) :: gradient_class
+  end type gradient_class
+
+  type, extends(gradient_class) :: trivial_gradient_type
+  end type trivial_gradient_type
+
+  private :: my_assign
+contains
+  subroutine my_assign (this,v)
+    class(trivial_gradient_type), intent(inout) :: this
+    class(vector_class),          intent(in)    :: v
+  end subroutine my_assign
+end module concrete_gradient
+!----------------------------
+module concrete_inner_product
+  use concrete_vector
+  use concrete_gradient
+  implicit none
+end module concrete_inner_product
+! { dg-final { cleanup-modules "abstract_vector concrete_vector" } }
+! { dg-final { cleanup-modules "concrete_gradient concrete_inner_product" } }
diff --git a/gcc/testsuite/gfortran.dg/class_15.f03 b/gcc/testsuite/gfortran.dg/class_15.f03
new file mode 100644
index 0000000..fbeb2a7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_15.f03
@@ -0,0 +1,43 @@
+! { dg-do compile }
+!
+! PR 42274: [fortran-dev Regression] ICE: segmentation fault
+!
+! Original test case by Salvatore Filippone <sfilippone@uniroma2.it>
+! Modified by Janus Weil <janus@gcc.gnu.org>
+
+module mod_A
+  type :: t1
+  contains 
+    procedure,nopass :: fun
+  end type
+contains
+  logical function fun()
+  end function
+end module
+
+module mod_B
+  use mod_A
+  type, extends(t1) :: t2
+  contains
+    procedure :: sub1
+  end type
+contains 
+  subroutine sub1(a)
+    class(t2) :: a
+  end subroutine
+end module
+
+module mod_C
+contains 
+  subroutine sub2(b)
+    use mod_B
+    type(t2) :: b
+  end subroutine
+end module
+
+module mod_D
+  use mod_A
+  use mod_C
+end module
+
+! { dg-final { cleanup-modules "mod_A mod_B mod_C mod_D" } }
diff --git a/gcc/testsuite/gfortran.dg/class_16.f03 b/gcc/testsuite/gfortran.dg/class_16.f03
new file mode 100644
index 0000000..7d0d38f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_16.f03
@@ -0,0 +1,23 @@
+! { dg-do compile }
+!
+! PR 43896: [fortran-dev Regression] ICE in gfc_conv_variable, at fortran/trans-expr.c:551
+!
+! Contributed by Fran Martinez Fadrique <fmartinez@gmv.com>
+
+module m_rotation_matrix
+
+  type t_rotation_matrix
+    contains
+      procedure :: array => rotation_matrix_array
+  end type
+
+contains
+
+  function rotation_matrix_array( rot ) result(array)
+    class(t_rotation_matrix) :: rot
+    double precision, dimension(3,3)    :: array
+  end function
+
+end module
+
+! { dg-final { cleanup-modules "m_rotation_matrix" } }
diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03
index 8533508..036c200 100644
--- a/gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03
+++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03
@@ -1,4 +1,4 @@
-! { dg-do compile }
+! { dg-do run }
 ! Tests the fix for PR4164656 in which the call to a%a%scal failed to compile.
 !
 ! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
@@ -166,7 +166,8 @@ contains
     integer :: err_act
     character(len=20)  :: name='csnmi'
     logical, parameter :: debug=.false.
-    print *, "s_scals"
+!    print *, "s_scals"
+    info = 0
     call a%a%scal(d,info)
     return
   end subroutine s_scals
@@ -180,6 +181,7 @@ end module s_mat_mod
     b%a => c
     a => b
     call a%scal (1.0_spk_, info)
+    if (info .ne. 700) call abort
 end
 ! { dg-final { cleanup-modules "const_mod base_mat_mod s_base_mat_mod s_mat_mod" } }
 
diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03
index a84d9f9..3cd0510 100644
--- a/gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03
+++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03
@@ -7,8 +7,8 @@
 ! Contributed by Janus Weil <janus@gcc.gnu.org>
 !
 module m1
-  type  :: t1
-  contains 
+  type :: t1
+  contains
     procedure :: sizeof
   end type
 contains
@@ -17,11 +17,10 @@ contains
     sizeof = 1
   end function sizeof
 end module
-
-
+	
 module m2
   use m1
-  type, extends(t1) :: t2    
+  type, extends(t1) :: t2
   contains
     procedure :: sizeof => sizeof2
   end type
@@ -32,19 +31,18 @@ contains
   end function
 end module
 
-
 module m3
   use m2
   type :: t3
-    class(t1), pointer  :: a 
+  class(t1), pointer :: a
   contains
     procedure :: sizeof => sizeof3
   end type
-contains 
+contains
   integer function sizeof3(a)
     class(t3) :: a
     sizeof3 = a%a%sizeof()
-  end function 
+  end function
 end module
 
   use m1
@@ -57,8 +55,7 @@ end module
   if ((z%sizeof() .ne. 1) .or. (z%a%sizeof() .ne. 1)) call abort
   z%a => y
   if ((z%sizeof() .ne. 2) .or. (z%a%sizeof() .ne. 2)) call abort
-
 end
 
 ! { dg-final { cleanup-modules "m1 m2 m3" } }
-
+ 	
diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_8.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_8.f03
new file mode 100644
index 0000000..4f3d806
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_8.f03
@@ -0,0 +1,108 @@
+! { dg-do run }
+!
+! PR 41829: [OOP] Runtime error with dynamic dispatching.  Tests
+! dynamic dispatch in a case where the caller knows nothing about
+! the dynamic type at compile time.
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+!
+module foo_mod
+  type foo
+    integer :: i 
+  contains
+    procedure, pass(a) :: doit
+    procedure, pass(a) :: getit
+  end type foo
+
+  private doit,getit
+contains
+  subroutine  doit(a) 
+    class(foo) :: a
+    
+    a%i = 1
+!    write(*,*) 'FOO%DOIT base version'
+  end subroutine doit
+  function getit(a) result(res)
+    class(foo) :: a
+    integer :: res
+
+    res = a%i
+  end function getit
+
+end module foo_mod
+module foo2_mod
+  use foo_mod
+
+  type, extends(foo) :: foo2
+    integer :: j
+  contains
+    procedure, pass(a) :: doit  => doit2
+    procedure, pass(a) :: getit => getit2
+  end type foo2
+  
+  private doit2, getit2
+
+contains
+
+  subroutine  doit2(a) 
+    class(foo2) :: a
+    
+    a%i = 2
+    a%j = 3
+!    write(*,*) 'FOO2%DOIT derived version'
+  end subroutine doit2
+  function getit2(a) result(res)
+    class(foo2) :: a
+    integer :: res
+
+    res = a%j
+  end function getit2
+    
+end module foo2_mod
+
+module bar_mod 
+  use foo_mod
+  type bar 
+    class(foo), allocatable :: a
+  contains 
+    procedure, pass(a) :: doit
+    procedure, pass(a) :: getit
+  end type bar
+  private doit,getit
+  
+contains
+  subroutine doit(a)
+    class(bar) :: a
+    
+    call a%a%doit()
+  end subroutine doit
+  function getit(a) result(res)
+    class(bar) :: a
+    integer :: res
+
+    res = a%a%getit()
+  end function getit
+end module bar_mod
+
+
+program testd10
+  use foo_mod
+  use foo2_mod
+  use bar_mod
+  
+  type(bar) :: a
+
+  allocate(foo :: a%a)
+  call a%doit()
+!  write(*,*) 'Getit value : ', a%getit()
+  if (a%getit() .ne. 1) call abort
+  deallocate(a%a)
+  allocate(foo2 :: a%a)
+  call a%doit()
+!  write(*,*) 'Getit value : ', a%getit()
+  if (a%getit() .ne. 3) call abort
+
+end program testd10
+
+! { dg-final { cleanup-modules "foo_mod foo2_mod bar_mod" } }
+
diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_9.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_9.f03
new file mode 100644
index 0000000..bf6a3d5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_9.f03
@@ -0,0 +1,54 @@
+! { dg-do run }
+!
+! [OOP] Ensure that different specifc interfaces are
+! handled properly by dynamic dispatch.
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+!
+module m
+
+ type :: t
+ contains
+  procedure :: a
+  generic :: gen => a
+ end type
+
+ type,extends(t) :: t2
+ contains
+  procedure :: b
+  generic :: gen => b
+ end type
+
+contains
+
+  real function a(ct,x)
+    class(t) :: ct
+    real :: x
+    a=2*x
+  end function
+
+  integer function b(ct,x)
+    class(t2) :: ct
+    integer :: x
+    b=3*x
+  end function
+
+end
+
+
+ use m
+ class(t), allocatable :: o1
+ type (t) :: t1
+ class(t2), allocatable :: o2
+
+ allocate(o1)
+ allocate(o2)
+
+ if (t1%gen(2.0) .ne. o1%gen(2.0)) call abort
+ if (t1%gen(2.0) .ne. o2%gen(2.0)) call abort
+ if (o2%gen(3) .ne. 9) call abort
+
+end
+
+! { dg-final { cleanup-modules "m" } }
+
diff --git a/gcc/testsuite/gfortran.dg/generic_22.f03 b/gcc/testsuite/gfortran.dg/generic_22.f03
new file mode 100644
index 0000000..1da49de
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/generic_22.f03
@@ -0,0 +1,38 @@
+! { dg-do compile }
+! Test the fix for PR43492, in which the generic call caused and ICE.
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+!
+module base_mod
+  
+  type  :: base_mat
+    integer, private     :: m, n
+  contains 
+    procedure, pass(a) :: transp1 => base_transp1
+    generic, public    :: transp => transp1
+    procedure, pass(a) :: transc1 => base_transc1
+    generic, public    :: transc => transc1
+  end type base_mat
+
+contains
+
+  subroutine base_transp1(a)
+    implicit none 
+    
+    class(base_mat), intent(inout) :: a
+    integer :: itmp
+    itmp        = a%m
+    a%m         = a%n
+    a%n         = itmp
+  end subroutine base_transp1
+  subroutine base_transc1(a)
+    implicit none 
+    class(base_mat), intent(inout) :: a
+    
+    call a%transp() 
+!!$    call a%transp1() 
+  end subroutine base_transc1
+
+
+end module base_mod
+! { dg-final { cleanup-modules "m" } }
diff --git a/gcc/testsuite/gfortran.dg/interface_32.f90 b/gcc/testsuite/gfortran.dg/interface_32.f90
new file mode 100644
index 0000000..6cdb091
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_32.f90
@@ -0,0 +1,81 @@
+! { dg-do compile }
+module m1
+  implicit none
+
+  type, abstract :: vector_class
+  end type vector_class
+end module m1
+!---------------------------------------------------------------
+module m2
+  use m1
+  implicit none
+
+  type, abstract :: inner_product_class
+  contains
+    procedure(dot), deferred :: dot_v_v
+    procedure(dot), deferred :: dot_g_g
+    procedure(sub), deferred :: D_times_v
+    procedure(sub), deferred :: D_times_g
+  end type inner_product_class
+
+  abstract interface
+    function dot (this,a,b)
+      import :: inner_product_class
+      import :: vector_class
+      class(inner_product_class), intent(in) :: this
+      class(vector_class),        intent(in) :: a,b
+      real                                   :: dot
+    end function
+    subroutine sub (this,a)
+      import :: inner_product_class
+      import :: vector_class
+      class(inner_product_class), intent(in)    :: this
+      class(vector_class),        intent(inout) :: a
+    end subroutine
+  end interface
+end module m2
+!---------------------------------------------------------------
+module m3
+  use :: m1
+  use :: m2
+  implicit none
+  private
+  public :: gradient_class
+
+  type, abstract, extends(vector_class) :: gradient_class
+    class(inner_product_class), pointer :: my_inner_product => NULL()
+  contains
+    procedure, non_overridable  :: inquire_inner_product
+    procedure(op_g_v), deferred :: to_vector
+  end type gradient_class
+
+  abstract interface
+    subroutine op_g_v(this,v)
+      import vector_class
+      import gradient_class
+      class(gradient_class), intent(in)    :: this
+      class(vector_class),   intent(inout) :: v
+    end subroutine
+  end interface
+contains
+  function inquire_inner_product (this)
+    class(gradient_class)               :: this
+    class(inner_product_class), pointer :: inquire_inner_product
+
+    inquire_inner_product => this%my_inner_product
+  end function inquire_inner_product
+end module m3
+!---------------------------------------------------------------
+module m4
+  use m3
+  use m2
+  implicit none
+contains
+  subroutine cg (g_initial)
+    class(gradient_class),  intent(in)    :: g_initial
+
+    class(inner_product_class), pointer   :: ip_save
+    ip_save => g_initial%inquire_inner_product()
+  end subroutine cg
+end module m4
+! { dg-final { cleanup-modules "m1 m2 m3 m4" } }