From 7c1dab0d8b4eef485b57813e1bb68542980db377 Mon Sep 17 00:00:00 2001
From: Janus Weil <janus@gcc.gnu.org>
Date: Mon, 30 Nov 2009 21:43:06 +0100
Subject: backport: re PR fortran/42053 ([OOP] SELECT TYPE: reject duplicate
 CLASS IS blocks)

merge from fortran-dev branch:


gcc/fortran/

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42053
	* resolve.c (resolve_select_type): Check for duplicate CLASS IS blocks.

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41631
	* decl.c (gfc_match_derived_decl): Set extension level.
	* gfortran.h (symbol_attribute): Expand 'extension' bit field to 8 bit.
	* iresolve.c (gfc_resolve_extends_type_of): Return value of
	'is_extension_of' has kind=4.
	* match.c (select_type_set_tmp,gfc_match_class_is): Create temporary
	for CLASS IS blocks.
	* module.c (MOD_VERSION): Bump module version.
	(ab_attribute,attr_bits): Remove AB_EXTENSION.
	(mio_symbol_attribute): Handle expanded 'extension' field.
	* resolve.c (resolve_select_type): Implement CLASS IS blocks.
	(resolve_fl_variable_derived): Show correct type name.
	* symbol.c (gfc_build_class_symbol): Set extension level.

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	* intrinsic.h (gfc_resolve_extends_type_of): Add prototype.
	* intrinsic.c (add_functions): Use 'gfc_resolve_extends_type_of'.
	* iresolve.c (gfc_resolve_extends_type_of): New function, which
	replaces the call to EXTENDS_TYPE_OF by the library function
	'is_extension_of' and modifies the arguments.
	* trans-intrinsic.c (gfc_conv_extends_type_of): Removed.
	(gfc_conv_intrinsic_function): FOR EXTENDS_TYPE_OF, don't call
	gfc_conv_extends_type_of but gfc_conv_intrinsic_funcall.

2009-11-30  Paul Thomas  <pault@gcc.gnu.org>
	    Janus Weil  <janus@gcc.gnu.org>

	* decl.c (encapsulate_class_symbol): Replaced by
	'gfc_build_class_symbol'.
	(build_sym,build_struct): Call 'gfc_build_class_symbol'.
	(gfc_match_derived_decl): Replace vindex by hash_value.
	* dump-parse-tree.c (show_symbol): Replace vindex by hash_value.
	* gfortran.h (symbol_attribute): Add field 'vtab'.
	(gfc_symbol): Replace vindex by hash_value.
	(gfc_class_esym_list): Ditto.
	(gfc_get_derived_type,gfc_build_class_symbol,gfc_find_derived_vtab):
	New prototypes.
	* module.c (mio_symbol): Replace vindex by hash_value.
	* resolve.c (vindex_expr): Rename to 'hash_value_expr'.
	(resolve_class_compcall,resolve_class_typebound_call): Renamed
	'vindex_expr'.
	(resolve_select_type): Replace $vindex by $vptr->$hash.
	* symbol.c (gfc_add_save): Handle vtab symbols.
	(gfc_type_compatible): Rewrite.
	(gfc_build_class_symbol): New function which replaces
	'encapsulate_class_symbol'.
	(gfc_find_derived_vtab): New function to set up a vtab symbol for a
	derived type.
	* trans-decl.c (gfc_create_module_variable): Handle vtab symbols.
	* trans-expr.c (select_class_proc): Replace vindex by hash_value.
	(gfc_conv_derived_to_class): New function to construct a temporary
	CLASS variable from a derived type expression.
	(gfc_conv_procedure_call): Call 'gfc_conv_derived_to_class'.
	(gfc_conv_structure): Initialize the $extends and $size fields of
	vtab symbols.
	(gfc_trans_class_assign): Replace $vindex by $vptr. Remove the $size
	assignment.
	* trans-intrinsic.c (gfc_conv_same_type_as): Replace $vindex by
	$vptr->$hash, and replace vindex by hash_value.
	* trans-stmt.c (gfc_trans_allocate): Insert $vptr references, replace
	$vindex by $vptr. Remove the $size assignment.
	* trans-types.c (gfc_get_derived_type): Make it non-static.


gcc/testsuite/

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42053
	* gfortran.dg/select_type_9.f03: New.

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41631
	* gfortran.dg/extends_type_of_1.f03: Fix invalid test case.
	* gfortran.dg/module_md5_1.f90: Adjusted MD5 sum.
	* gfortran.dg/select_type_1.f03: Remove FIXMEs.
	* gfortran.dg/select_type_2.f03: Ditto.
	* gfortran.dg/select_type_8.f03: New test.

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.dg/extends_type_of_1.f03: New test.
	* gfortran.dg/same_type_as_1.f03: Extended.

2009-11-30  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/class_4c.f03: Add dg-additional-sources.
	* gfortran.dg/class_4d.f03: Rename module. Cleanup modules.


libgfortran/

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.map: Add _gfortran_is_extension_of.
	* Makefile.am: Add intrinsics/extends_type_of.c.
	* Makefile.in: Regenerated.
	* intrinsics/extends_type_of.c: New file.

From-SVN: r154840
---
 gcc/fortran/ChangeLog                           |  71 ++++++++
 gcc/fortran/decl.c                              | 104 ++---------
 gcc/fortran/dump-parse-tree.c                   |   4 +-
 gcc/fortran/gfortran.h                          |  13 +-
 gcc/fortran/intrinsic.c                         |   2 +-
 gcc/fortran/intrinsic.h                         |   1 +
 gcc/fortran/iresolve.c                          |  51 ++++++
 gcc/fortran/match.c                             |  19 +-
 gcc/fortran/module.c                            |  19 +-
 gcc/fortran/resolve.c                           | 226 +++++++++++++++++------
 gcc/fortran/symbol.c                            | 232 ++++++++++++++++++++++--
 gcc/fortran/trans-decl.c                        |   2 +-
 gcc/fortran/trans-expr.c                        | 192 +++++++++++---------
 gcc/fortran/trans-intrinsic.c                   |  34 ++--
 gcc/fortran/trans-stmt.c                        |  56 +++---
 gcc/fortran/trans-types.c                       |   4 +-
 gcc/testsuite/ChangeLog                         |  24 +++
 gcc/testsuite/gfortran.dg/class_4c.f03          |   1 +
 gcc/testsuite/gfortran.dg/class_4d.f03          |   6 +-
 gcc/testsuite/gfortran.dg/extends_type_of_1.f03 |  48 +++++
 gcc/testsuite/gfortran.dg/module_md5_1.f90      |   2 +-
 gcc/testsuite/gfortran.dg/same_type_as_1.f03    |   7 +-
 gcc/testsuite/gfortran.dg/select_type_1.f03     |  10 +-
 gcc/testsuite/gfortran.dg/select_type_2.f03     |  10 +-
 gcc/testsuite/gfortran.dg/select_type_8.f03     |  98 ++++++++++
 gcc/testsuite/gfortran.dg/select_type_9.f03     |  20 ++
 libgfortran/ChangeLog                           |   7 +
 libgfortran/Makefile.am                         |   1 +
 libgfortran/Makefile.in                         |  46 +++--
 libgfortran/gfortran.map                        |   1 +
 libgfortran/intrinsics/extends_type_of.c        |  61 +++++++
 31 files changed, 1017 insertions(+), 355 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/extends_type_of_1.f03
 create mode 100644 gcc/testsuite/gfortran.dg/select_type_8.f03
 create mode 100644 gcc/testsuite/gfortran.dg/select_type_9.f03
 create mode 100644 libgfortran/intrinsics/extends_type_of.c

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 03c1548..976061a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,74 @@
+2009-11-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42053
+	* resolve.c (resolve_select_type): Check for duplicate CLASS IS blocks.
+
+2009-11-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41631
+	* decl.c (gfc_match_derived_decl): Set extension level.
+	* gfortran.h (symbol_attribute): Expand 'extension' bit field to 8 bit.
+	* iresolve.c (gfc_resolve_extends_type_of): Return value of
+	'is_extension_of' has kind=4.
+	* match.c (select_type_set_tmp,gfc_match_class_is): Create temporary
+	for CLASS IS blocks.
+	* module.c (MOD_VERSION): Bump module version.
+	(ab_attribute,attr_bits): Remove AB_EXTENSION.
+	(mio_symbol_attribute): Handle expanded 'extension' field.
+	* resolve.c (resolve_select_type): Implement CLASS IS blocks.
+	(resolve_fl_variable_derived): Show correct type name.
+	* symbol.c (gfc_build_class_symbol): Set extension level.
+
+2009-11-30  Janus Weil  <janus@gcc.gnu.org>
+
+	* intrinsic.h (gfc_resolve_extends_type_of): Add prototype.
+	* intrinsic.c (add_functions): Use 'gfc_resolve_extends_type_of'.
+	* iresolve.c (gfc_resolve_extends_type_of): New function, which
+	replaces the call to EXTENDS_TYPE_OF by the library function
+	'is_extension_of' and modifies the arguments.
+	* trans-intrinsic.c (gfc_conv_extends_type_of): Removed.
+	(gfc_conv_intrinsic_function): FOR EXTENDS_TYPE_OF, don't call
+	gfc_conv_extends_type_of but gfc_conv_intrinsic_funcall.
+
+2009-11-30  Paul Thomas  <pault@gcc.gnu.org>
+	    Janus Weil  <janus@gcc.gnu.org>
+
+	* decl.c (encapsulate_class_symbol): Replaced by
+	'gfc_build_class_symbol'.
+	(build_sym,build_struct): Call 'gfc_build_class_symbol'.
+	(gfc_match_derived_decl): Replace vindex by hash_value.
+	* dump-parse-tree.c (show_symbol): Replace vindex by hash_value.
+	* gfortran.h (symbol_attribute): Add field 'vtab'.
+	(gfc_symbol): Replace vindex by hash_value.
+	(gfc_class_esym_list): Ditto.
+	(gfc_get_derived_type,gfc_build_class_symbol,gfc_find_derived_vtab):
+	New prototypes.
+	* module.c (mio_symbol): Replace vindex by hash_value.
+	* resolve.c (vindex_expr): Rename to 'hash_value_expr'.
+	(resolve_class_compcall,resolve_class_typebound_call): Renamed
+	'vindex_expr'.
+	(resolve_select_type): Replace $vindex by $vptr->$hash.
+	* symbol.c (gfc_add_save): Handle vtab symbols.
+	(gfc_type_compatible): Rewrite.
+	(gfc_build_class_symbol): New function which replaces
+	'encapsulate_class_symbol'.
+	(gfc_find_derived_vtab): New function to set up a vtab symbol for a
+	derived type.
+	* trans-decl.c (gfc_create_module_variable): Handle vtab symbols.
+	* trans-expr.c (select_class_proc): Replace vindex by hash_value.
+	(gfc_conv_derived_to_class): New function to construct a temporary
+	CLASS variable from a derived type expression.
+	(gfc_conv_procedure_call): Call 'gfc_conv_derived_to_class'.
+	(gfc_conv_structure): Initialize the $extends and $size fields of
+	vtab symbols.
+	(gfc_trans_class_assign): Replace $vindex by $vptr. Remove the $size
+	assignment.
+	* trans-intrinsic.c (gfc_conv_same_type_as): Replace $vindex by
+	$vptr->$hash, and replace vindex by hash_value.
+	* trans-stmt.c (gfc_trans_allocate): Insert $vptr references, replace
+	$vindex by $vptr. Remove the $size assignment.
+	* trans-types.c (gfc_get_derived_type): Make it non-static.
+
 2009-11-30  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/42131
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 23ac5c3..90f30b3 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1025,88 +1025,6 @@ verify_c_interop_param (gfc_symbol *sym)
 }
 
 
-/* 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 an integer component '$vindex'
-   which determines the dynamic type, and another integer '$size', which
-   contains the size of the dynamic type structure.  */
-
-static gfc_try
-encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
-			  gfc_array_spec **as)
-{
-  char name[GFC_MAX_SYMBOL_LEN + 5];
-  gfc_symbol *fclass;
-  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->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->vindex = ts->u.derived->vindex;
-      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.pointer = attr->pointer || attr->dummy;
-      c->attr.allocatable = attr->allocatable;
-      c->attr.dimension = attr->dimension;
-      c->attr.abstract = ts->u.derived->attr.abstract;
-      c->as = (*as);
-      c->initializer = gfc_get_expr ();
-      c->initializer->expr_type = EXPR_NULL;
-
-      /* Add component '$vindex'.  */
-      if (gfc_add_component (fclass, "$vindex", &c) == FAILURE)
-   	return FAILURE;
-      c->ts.type = BT_INTEGER;
-      c->ts.kind = 4;
-      c->attr.access = ACCESS_PRIVATE;
-      c->initializer = gfc_int_expr (0);
-
-      /* Add component '$size'.  */
-      if (gfc_add_component (fclass, "$size", &c) == FAILURE)
-   	return FAILURE;
-      c->ts.type = BT_INTEGER;
-      c->ts.kind = 4;
-      c->attr.access = ACCESS_PRIVATE;
-      c->initializer = gfc_int_expr (0);
-    }
-
-  fclass->attr.extension = 1;
-  fclass->attr.is_class = 1;
-  ts->u.derived = fclass;
-  attr->allocatable = attr->pointer = attr->dimension = 0;
-  (*as) = NULL;  /* XXX */
-  return SUCCESS;
-}
 
 /* Function called by variable_decl() that adds a name to the symbol table.  */
 
@@ -1185,7 +1103,7 @@ build_sym (const char *name, gfc_charlen *cl,
       sym->attr.class_ok = (sym->attr.dummy
 			      || sym->attr.pointer
 			      || sym->attr.allocatable) ? 1 : 0;
-      encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+      gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
     }
 
   return SUCCESS;
@@ -1594,7 +1512,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
 
 scalar:
   if (c->ts.type == BT_CLASS)
-    encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
+    gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
 
   return t;
 }
@@ -6926,13 +6844,23 @@ gfc_match_derived_decl (void)
 
       /* Add the extended derived type as the first component.  */
       gfc_add_component (sym, parent, &p);
-      sym->attr.extension = attr.extension;
       extended->refs++;
       gfc_set_sym_referenced (extended);
 
       p->ts.type = BT_DERIVED;
       p->ts.u.derived = extended;
       p->initializer = gfc_default_initializer (&p->ts);
+      
+      /* Set extension level.  */
+      if (extended->attr.extension == 255)
+	{
+	  /* Since the extension field is 8 bit wide, we can only have
+	     up to 255 extension levels.  */
+	  gfc_error ("Maximum extension level reached with type '%s' at %L",
+		     extended->name, &extended->declared_at);
+	  return MATCH_ERROR;
+	}
+      sym->attr.extension = extended->attr.extension + 1;
 
       /* Provide the links between the extended type and its extension.  */
       if (!extended->f2k_derived)
@@ -6941,9 +6869,9 @@ gfc_match_derived_decl (void)
       st->n.sym = sym;
     }
 
-  if (!sym->vindex)
-    /* Set the vindex for this type.  */
-    sym->vindex = hash_value (sym);
+  if (!sym->hash_value)
+    /* Set the hash for the compound name for this type.  */
+    sym->hash_value = hash_value (sym);
 
   /* Take over the ABSTRACT attribute.  */
   sym->attr.abstract = attr.abstract;
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 32ff298..97289c2 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -827,8 +827,8 @@ show_symbol (gfc_symbol *sym)
   if (sym->f2k_derived)
     {
       show_indent ();
-      if (sym->vindex)
-	fprintf (dumpfile, "vindex: %d", sym->vindex);
+      if (sym->hash_value)
+	fprintf (dumpfile, "hash: %d", sym->hash_value);
       show_f2k_derived (sym->f2k_derived);
     }
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index cc3ccf5..e552203 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -670,9 +670,10 @@ typedef struct
   unsigned untyped:1;		/* No implicit type could be found.  */
 
   unsigned is_bind_c:1;		/* say if is bound to C.  */
-  unsigned extension:1;		/* extends a derived type.  */
+  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.  */
 
   /* These flags are both in the typespec and attribute.  The attribute
      list is what gets read from/written to a module file.  The typespec
@@ -1137,8 +1138,8 @@ typedef struct gfc_symbol
 
   int entry_id;			/* Used in resolve.c for entries.  */
 
-  /* CLASS vindex for declared and dynamic types in the class.  */
-  int vindex;
+  /* CLASS hashed name for declared and dynamic types in the class.  */
+  int hash_value;
 
   struct gfc_symbol *common_next;	/* Links for COMMON syms */
 
@@ -1599,7 +1600,7 @@ typedef struct gfc_class_esym_list
 {
   gfc_symbol *derived;
   gfc_symbol *esym;
-  struct gfc_expr *vindex;
+  struct gfc_expr *hash_value;
   struct gfc_class_esym_list *next;
 }
 gfc_class_esym_list;
@@ -2380,6 +2381,7 @@ gfc_try gfc_check_any_c_kind (gfc_typespec *);
 int gfc_validate_kind (bt, int, bool);
 int gfc_get_int_kind_from_width_isofortranenv (int size);
 int gfc_get_real_kind_from_width_isofortranenv (int size);
+tree gfc_get_derived_type (gfc_symbol * derived);
 extern int gfc_index_integer_kind;
 extern int gfc_default_integer_kind;
 extern int gfc_max_integer_kind;
@@ -2517,6 +2519,9 @@ 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 **);
+gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
 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/intrinsic.c b/gcc/fortran/intrinsic.c
index a62dd92..859fd4b 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1601,7 +1601,7 @@ add_functions (void)
 
   add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY,
 	     ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
-	     gfc_check_same_type_as, NULL, NULL,
+	     gfc_check_same_type_as, NULL, gfc_resolve_extends_type_of,
 	     a, BT_UNKNOWN, 0, REQUIRED,
 	     mo, BT_UNKNOWN, 0, REQUIRED);
 
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index acd3f78..cf436db 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -390,6 +390,7 @@ void gfc_resolve_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
 void gfc_resolve_etime_sub (gfc_code *);
 void gfc_resolve_exp (gfc_expr *, gfc_expr *);
 void gfc_resolve_exponent (gfc_expr *, gfc_expr *);
+void gfc_resolve_extends_type_of (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_fdate (gfc_expr *);
 void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_fnum (gfc_expr *, gfc_expr *);
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 960be08..7e8bdfb 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -806,6 +806,57 @@ gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
 }
 
 
+/* Resolve the EXTENDS_TYPE_OF intrinsic function.  */
+
+void
+gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
+{
+  gfc_symbol *vtab;
+  gfc_symtree *st;
+
+  /* Prevent double resolution.  */
+  if (f->ts.type == BT_LOGICAL)
+    return;
+
+  /* Replace the first argument with the corresponding vtab.  */
+  if (a->ts.type == BT_CLASS)
+    gfc_add_component_ref (a, "$vptr");
+  else if (a->ts.type == BT_DERIVED)
+    {
+      vtab = gfc_find_derived_vtab (a->ts.u.derived);
+      /* Clear the old expr.  */
+      gfc_free_ref_list (a->ref);
+      memset (a, '\0', sizeof (gfc_expr));
+      /* Construct a new one.  */
+      a->expr_type = EXPR_VARIABLE;
+      st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+      a->symtree = st;
+      a->ts = vtab->ts;
+    }
+
+  /* Replace the second argument with the corresponding vtab.  */
+  if (mo->ts.type == BT_CLASS)
+    gfc_add_component_ref (mo, "$vptr");
+  else if (mo->ts.type == BT_DERIVED)
+    {
+      vtab = gfc_find_derived_vtab (mo->ts.u.derived);
+      /* Clear the old expr.  */
+      gfc_free_ref_list (mo->ref);
+      memset (mo, '\0', sizeof (gfc_expr));
+      /* Construct a new one.  */
+      mo->expr_type = EXPR_VARIABLE;
+      st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+      mo->symtree = st;
+      mo->ts = vtab->ts;
+    }
+
+  f->ts.type = BT_LOGICAL;
+  f->ts.kind = 4;
+  /* Call library function.  */
+  f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
+}
+
+
 void
 gfc_resolve_fdate (gfc_expr *f)
 {
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 153dfdb3..9e76818 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -3968,13 +3968,25 @@ select_type_set_tmp (gfc_typespec *ts)
 {
   char name[GFC_MAX_SYMBOL_LEN];
   gfc_symtree *tmp;
+  
+  if (!gfc_type_is_extensible (ts->u.derived))
+    return;
 
-  sprintf (name, "tmp$%s", ts->u.derived->name);
+  if (ts->type == BT_CLASS)
+    sprintf (name, "tmp$class$%s", ts->u.derived->name);
+  else
+    sprintf (name, "tmp$type$%s", ts->u.derived->name);
   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
   gfc_add_type (tmp->n.sym, ts, NULL);
   gfc_set_sym_referenced (tmp->n.sym);
   gfc_add_pointer (&tmp->n.sym->attr, NULL);
   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+  if (ts->type == BT_CLASS)
+    {
+      gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
+			      &tmp->n.sym->as);
+      tmp->n.sym->attr.class_ok = 1;
+    }
 
   select_type_stack->tmp = tmp;
 }
@@ -4228,8 +4240,9 @@ gfc_match_class_is (void)
 
   new_st.op = EXEC_SELECT_TYPE;
   new_st.ext.case_list = c;
-
-  gfc_error_now ("CLASS IS specification at %C is not yet supported");
+  
+  /* Create temporary variable.  */
+  select_type_set_tmp (&c->ts);
 
   return MATCH_YES;
 
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 36095a2..d732b66 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -77,7 +77,7 @@ along with GCC; see the file COPYING3.  If not see
 
 /* Don't put any single quote (') in MOD_VERSION, 
    if yout want it to be recognized.  */
-#define MOD_VERSION "3"
+#define MOD_VERSION "4"
 
 
 /* Structure that describes a position within a module file.  */
@@ -1671,7 +1671,7 @@ typedef enum
   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
   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_EXTENSION, AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER
+  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER
 }
 ab_attribute;
 
@@ -1711,7 +1711,6 @@ static const mstring attr_bits[] =
     minit ("ZERO_COMP", AB_ZERO_COMP),
     minit ("PROTECTED", AB_PROTECTED),
     minit ("ABSTRACT", AB_ABSTRACT),
-    minit ("EXTENSION", AB_EXTENSION),
     minit ("IS_CLASS", AB_IS_CLASS),
     minit ("PROCEDURE", AB_PROCEDURE),
     minit ("PROC_POINTER", AB_PROC_POINTER),
@@ -1771,7 +1770,7 @@ static void
 mio_symbol_attribute (symbol_attribute *attr)
 {
   atom_type t;
-  unsigned ext_attr;
+  unsigned ext_attr,extension_level;
 
   mio_lparen ();
 
@@ -1780,10 +1779,15 @@ mio_symbol_attribute (symbol_attribute *attr)
   attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
   attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
   attr->save = MIO_NAME (save_state) (attr->save, save_status);
+  
   ext_attr = attr->ext_attr;
   mio_integer ((int *) &ext_attr);
   attr->ext_attr = ext_attr;
 
+  extension_level = attr->extension;
+  mio_integer ((int *) &extension_level);
+  attr->extension = extension_level;
+
   if (iomode == IO_OUTPUT)
     {
       if (attr->allocatable)
@@ -1858,8 +1862,6 @@ mio_symbol_attribute (symbol_attribute *attr)
 	MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
       if (attr->zero_comp)
 	MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
-      if (attr->extension)
-	MIO_NAME (ab_attribute) (AB_EXTENSION, attr_bits);
       if (attr->is_class)
 	MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
       if (attr->procedure)
@@ -1984,9 +1986,6 @@ mio_symbol_attribute (symbol_attribute *attr)
 	    case AB_ZERO_COMP:
 	      attr->zero_comp = 1;
 	      break;
-	    case AB_EXTENSION:
-	      attr->extension = 1;
-	      break;
 	    case AB_IS_CLASS:
 	      attr->is_class = 1;
 	      break;
@@ -3574,7 +3573,7 @@ mio_symbol (gfc_symbol *sym)
   mio_integer (&(sym->intmod_sym_id));
 
   if (sym->attr.flavor == FL_DERIVED)
-    mio_integer (&(sym->vindex));
+    mio_integer (&(sym->hash_value));
 
   mio_rparen ();
 }
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index b685312..bf705c6 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5218,41 +5218,35 @@ resolve_class_esym (gfc_expr *e)
 }
 
 
-/* Generate an expression for the vindex, given the reference to
+/* 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*
-vindex_expr (gfc_ref *class_ref, gfc_ref *new_ref,
-	     gfc_symbol *declared, gfc_symtree *st)
+hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st)
 {
-  gfc_expr *vindex;
-  gfc_ref *ref;
+  gfc_expr *hash_value;
 
-  /* Build an expression for the correct vindex; ie. that of the last
+  /* Build an expression for the correct hash_value; ie. that of the last
      CLASS reference.  */
-  ref = gfc_get_ref();
-  ref->type = REF_COMPONENT;
-  ref->u.c.component = declared->components->next;
-  ref->u.c.sym = declared;
-  ref->next = NULL;
   if (class_ref)
     {
-      class_ref->next = ref;
+      class_ref->next = NULL;
     }
   else
     {
       gfc_free_ref_list (new_ref);
-      new_ref = ref;
+      new_ref = NULL;
     }
-  vindex = gfc_get_expr ();
-  vindex->expr_type = EXPR_VARIABLE;
-  vindex->symtree = st;
-  vindex->symtree->n.sym->refs++;
-  vindex->ts = ref->u.c.component->ts;
-  vindex->ref = new_ref;
+  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 vindex;
+  return hash_value;
 }
 
 
@@ -5352,10 +5346,10 @@ resolve_class_compcall (gfc_expr* e)
   resolve_class_esym (e);
 
   /* More than one typebound procedure so transmit an expression for
-     the vindex as the selector.  */
+     the hash_value as the selector.  */
   if (e->value.function.class_esym != NULL)
-    e->value.function.class_esym->vindex
-		= vindex_expr (class_ref, new_ref, declared, st);
+    e->value.function.class_esym->hash_value
+		= hash_value_expr (class_ref, new_ref, st);
 
   return class_try;
 }
@@ -5407,10 +5401,10 @@ resolve_class_typebound_call (gfc_code *code)
   resolve_class_esym (code->expr1);
 
   /* More than one typebound procedure so transmit an expression for
-     the vindex as the selector.  */
+     the hash_value as the selector.  */
   if (code->expr1->value.function.class_esym != NULL)
-    code->expr1->value.function.class_esym->vindex
-		= vindex_expr (class_ref, new_ref, declared, st);
+    code->expr1->value.function.class_esym->hash_value
+		= hash_value_expr (class_ref, new_ref, st);
 
   return class_try;
 }
@@ -6862,11 +6856,13 @@ static void
 resolve_select_type (gfc_code *code)
 {
   gfc_symbol *selector_type;
-  gfc_code *body, *new_st;
-  gfc_case *c, *default_case;
+  gfc_code *body, *new_st, *if_st, *tail;
+  gfc_code *class_is = NULL, *default_case = NULL;
+  gfc_case *c;
   gfc_symtree *st;
   char name[GFC_MAX_SYMBOL_LEN];
   gfc_namespace *ns;
+  int error = 0;
 
   ns = code->ext.ns;
   gfc_resolve (ns);
@@ -6876,9 +6872,6 @@ resolve_select_type (gfc_code *code)
   else
     selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
 
-  /* Assume there is no DEFAULT case.  */
-  default_case = NULL;
-
   /* Loop over TYPE IS / CLASS IS cases.  */
   for (body = code->block; body; body = body->block)
     {
@@ -6890,6 +6883,7 @@ resolve_select_type (gfc_code *code)
 	{
 	  gfc_error ("Derived type '%s' at %L must be extensible",
 		     c->ts.u.derived->name, &c->where);
+	  error++;
 	  continue;
 	}
 
@@ -6899,6 +6893,7 @@ resolve_select_type (gfc_code *code)
 	{
 	  gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
 		     c->ts.u.derived->name, &c->where, selector_type->name);
+	  error++;
 	  continue;
 	}
 
@@ -6906,15 +6901,21 @@ resolve_select_type (gfc_code *code)
       if (c->ts.type == BT_UNKNOWN)
 	{
 	  /* Check F03:C818.  */
-	  if (default_case != NULL)
-	    gfc_error ("The DEFAULT CASE at %L cannot be followed "
-		       "by a second DEFAULT CASE at %L",
-		       &default_case->where, &c->where);
+	  if (default_case)
+	    {
+	      gfc_error ("The DEFAULT CASE at %L cannot be followed "
+			 "by a second DEFAULT CASE at %L",
+			 &default_case->ext.case_list->where, &c->where);
+	      error++;
+	      continue;
+	    }
 	  else
-	    default_case = c;
-	  continue;
+	    default_case = body;
 	}
     }
+    
+  if (error>0)
+    return;
 
   if (code->expr2)
     {
@@ -6944,45 +6945,153 @@ resolve_select_type (gfc_code *code)
 
   /* Transform to EXEC_SELECT.  */
   code->op = EXEC_SELECT;
-  gfc_add_component_ref (code->expr1, "$vindex");
+  gfc_add_component_ref (code->expr1, "$vptr");
+  gfc_add_component_ref (code->expr1, "$hash");
 
   /* Loop over TYPE IS / CLASS IS cases.  */
   for (body = code->block; body; body = body->block)
     {
       c = body->ext.case_list;
+      
       if (c->ts.type == BT_DERIVED)
-	c->low = c->high = gfc_int_expr (c->ts.u.derived->vindex);
-      else if (c->ts.type == BT_CLASS)
-	/* Currently IS CLASS blocks are simply ignored.
-	   TODO: Implement IS CLASS.  */
-	c->unreachable = 1;
-
-      if (c->ts.type != BT_DERIVED)
+	c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value);
+      else if (c->ts.type == BT_UNKNOWN)
 	continue;
+      
       /* Assign temporary to selector.  */
-      sprintf (name, "tmp$%s", c->ts.u.derived->name);
+      if (c->ts.type == BT_CLASS)
+	sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
+      else
+	sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
       st = gfc_find_symtree (ns->sym_root, name);
       new_st = gfc_get_code ();
-      new_st->op = EXEC_POINTER_ASSIGN;
       new_st->expr1 = gfc_get_variable_expr (st);
       new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
-      gfc_add_component_ref (new_st->expr2, "$data");
+      if (c->ts.type == BT_DERIVED)
+	{
+	  new_st->op = EXEC_POINTER_ASSIGN;
+	  gfc_add_component_ref (new_st->expr2, "$data");
+	}
+      else
+	new_st->op = EXEC_POINTER_ASSIGN;
       new_st->next = body->next;
       body->next = new_st;
     }
+    
+  /* Take out CLASS IS cases for separate treatment.  */
+  body = code;
+  while (body && body->block)
+    {
+      if (body->block->ext.case_list->ts.type == BT_CLASS)
+	{
+	  /* Add to class_is list.  */
+	  if (class_is == NULL)
+	    { 
+	      class_is = body->block;
+	      tail = class_is;
+	    }
+	  else
+	    {
+	      for (tail = class_is; tail->block; tail = tail->block) ;
+	      tail->block = body->block;
+	      tail = tail->block;
+	    }
+	  /* Remove from EXEC_SELECT list.  */
+	  body->block = body->block->block;
+	  tail->block = NULL;
+	}
+      else
+	body = body->block;
+    }
 
-  /* Eliminate dead blocks.  */
-  for (body = code; body && body->block; body = body->block)
+  if (class_is)
     {
-      if (body->block->ext.case_list->unreachable)
+      gfc_symbol *vtab;
+      
+      if (!default_case)
+	{
+	  /* Add a default case to hold the CLASS IS cases.  */
+	  for (tail = code; tail->block; tail = tail->block) ;
+	  tail->block = gfc_get_code ();
+	  tail = tail->block;
+	  tail->op = EXEC_SELECT_TYPE;
+	  tail->ext.case_list = gfc_get_case ();
+	  tail->ext.case_list->ts.type = BT_UNKNOWN;
+	  tail->next = NULL;
+	  default_case = tail;
+	}
+      
+      /* More than one CLASS IS block?  */
+      if (class_is->block)
 	{
-	  /* Cut the unreachable block from the code chain.  */
-	  gfc_code *cd = body->block;
-	  body->block = cd->block;
-	  /* Kill the dead block, but not the blocks below it.  */
-	  cd->block = NULL;
-	  gfc_free_statements (cd);
+	  gfc_code **c1,*c2;
+	  bool swapped;
+	  /* Sort CLASS IS blocks by extension level.  */
+	  do
+	    {
+	      swapped = false;
+	      for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
+		{
+		  c2 = (*c1)->block;
+		  /* F03:C817 (check for doubles).  */
+		  if ((*c1)->ext.case_list->ts.u.derived->hash_value
+		      == c2->ext.case_list->ts.u.derived->hash_value)
+		    {
+		      gfc_error ("Double CLASS IS block in SELECT TYPE "
+				 "statement at %L", &c2->ext.case_list->where);
+		      return;
+		    }
+		  if ((*c1)->ext.case_list->ts.u.derived->attr.extension
+		      < c2->ext.case_list->ts.u.derived->attr.extension)
+		    {
+		      /* Swap.  */
+		      (*c1)->block = c2->block;
+		      c2->block = *c1;
+		      *c1 = c2;
+		      swapped = true;
+		    }
+		}
+	    }
+	  while (swapped);
 	}
+	
+      /* Generate IF chain.  */
+      if_st = gfc_get_code ();
+      if_st->op = EXEC_IF;
+      new_st = if_st;
+      for (body = class_is; body; body = body->block)
+	{
+	  new_st->block = gfc_get_code ();
+	  new_st = new_st->block;
+	  new_st->op = EXEC_IF;
+	  /* Set up IF condition: Call _gfortran_is_extension_of.  */
+	  new_st->expr1 = gfc_get_expr ();
+	  new_st->expr1->expr_type = EXPR_FUNCTION;
+	  new_st->expr1->ts.type = BT_LOGICAL;
+	  new_st->expr1->ts.kind = 4;
+	  new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
+	  new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
+	  new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
+	  /* Set up arguments.  */
+	  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);
+	  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);
+	  new_st->next = body->next;
+	}
+	if (default_case->next)
+	  {
+	    new_st->block = gfc_get_code ();
+	    new_st = new_st->block;
+	    new_st->op = EXEC_IF;
+	    new_st->next = default_case->next;
+	  }
+	  
+	/* Replace CLASS DEFAULT code by the IF chain.  */
+	default_case->next = if_st;
     }
 
   resolve_select (code);
@@ -8751,7 +8860,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
       if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
 	{
 	  gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
-		     sym->ts.u.derived->name, sym->name, &sym->declared_at);
+		     sym->ts.u.derived->components->ts.u.derived->name,
+		     sym->name, &sym->declared_at);
 	  return FAILURE;
 	}
 
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index c1b39b0..6dd0a8a 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -1045,7 +1045,7 @@ gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
       return FAILURE;
     }
 
-  if (attr->save == SAVE_EXPLICIT)
+  if (attr->save == SAVE_EXPLICIT && !attr->vtab)
     {
 	if (gfc_notify_std (GFC_STD_LEGACY, 
 			    "Duplicate SAVE attribute specified at %L",
@@ -4592,22 +4592,228 @@ gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
 bool
 gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
 {
-  if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS)
-      && (ts2->type == BT_DERIVED || ts2->type == BT_CLASS))
+  gfc_component *cmp1, *cmp2;
+
+  bool is_class1 = (ts1->type == BT_CLASS);
+  bool is_class2 = (ts2->type == BT_CLASS);
+  bool is_derived1 = (ts1->type == BT_DERIVED);
+  bool is_derived2 = (ts2->type == BT_DERIVED);
+
+  if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
+    return (ts1->type == ts2->type);
+
+  if (is_derived1 && is_derived2)
+    return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
+
+  cmp1 = cmp2 = NULL;
+
+  if (is_class1)
     {
-      if (ts1->type == BT_CLASS && ts2->type == BT_DERIVED)
-	return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
-					 ts2->u.derived);
-      else if (ts1->type == BT_CLASS && ts2->type == BT_CLASS)
-	return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
-					 ts2->u.derived->components->ts.u.derived);
-      else if (ts2->type != BT_CLASS)
-	return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
-      else
+      cmp1 = gfc_find_component (ts1->u.derived, "$data", true, false);
+      if (cmp1 == NULL)
 	return 0;
     }
+
+  if (is_class2)
+    {
+      cmp2 = gfc_find_component (ts2->u.derived, "$data", true, false);
+      if (cmp2 == NULL)
+	return 0;
+    }
+
+  if (is_class1 && is_derived2)
+    return gfc_type_is_extension_of (cmp1->ts.u.derived, ts2->u.derived);
+
+  else if (is_class1 && is_class2)
+    return gfc_type_is_extension_of (cmp1->ts.u.derived, cmp2->ts.u.derived);
+
   else
-    return (ts1->type == ts2->type);
+    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)
+{
+  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->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.pointer = attr->pointer || attr->dummy;
+      c->attr.allocatable = attr->allocatable;
+      c->attr.dimension = attr->dimension;
+      c->attr.abstract = ts->u.derived->attr.abstract;
+      c->as = (*as);
+      c->initializer = gfc_get_expr ();
+      c->initializer->expr_type = EXPR_NULL;
+
+      /* Add component '$vptr'.  */
+      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;
+      c->attr.pointer = 1;
+      c->initializer = gfc_get_expr ();
+      c->initializer->expr_type = EXPR_NULL;
+    }
+
+  /* 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;
+}
+
+
+/* Find the symbol for a derived type's vtab.  */
+
+gfc_symbol *
+gfc_find_derived_vtab (gfc_symbol *derived)
+{
+  gfc_namespace *ns;
+  gfc_symbol *vtab = NULL, *vtype = NULL;
+  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_int_expr (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_int_expr (0);
+
+	      /* Add component $extends.  */
+	      if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
+		return NULL;
+	      c->attr.pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      c->initializer = gfc_get_expr ();
+	      parent = gfc_get_derived_super_type (derived);
+	      if (parent)
+		{
+		  parent_vtab = gfc_find_derived_vtab (parent);
+		  c->ts.type = BT_DERIVED;
+		  c->ts.u.derived = parent_vtab->ts.u.derived;
+		  c->initializer->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->expr_type = EXPR_NULL;
+		}
+	    }
+	  vtab->ts.u.derived = vtype;
+
+	  vtab->value = gfc_default_initializer (&vtab->ts);
+	}
+    }
+
+  return vtab;
 }
 
 
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 200c3f5..2e3fedd 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -3405,7 +3405,7 @@ gfc_create_module_variable (gfc_symbol * sym)
       && (sym->equiv_built || sym->attr.in_equivalence))
     return;
 
-  if (sym->backend_decl)
+  if (sym->backend_decl && !sym->attr.vtab)
     internal_error ("backend decl for module variable %s already exists",
 		    sym->name);
 
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 77de6bd..acca306 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1530,16 +1530,16 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
   tree end_label;
   tree label;
   tree tmp;
-  tree vindex;
+  tree hash;
   stmtblock_t body;
   gfc_class_esym_list *next_elist, *tmp_elist;
   gfc_se tmpse;
 
-  /* Convert the vindex expression.  */
+  /* Convert the hash expression.  */
   gfc_init_se (&tmpse, NULL);
-  gfc_conv_expr (&tmpse, elist->vindex);
+  gfc_conv_expr (&tmpse, elist->hash_value);
   gfc_add_block_to_block (&se->pre, &tmpse.pre);
-  vindex = gfc_evaluate_now (tmpse.expr, &se->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.  */
@@ -1566,9 +1566,9 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
 	  if (elist->esym != tmp_elist->esym)
 	    continue;
 
-	  cval = build_int_cst (TREE_TYPE (vindex),
-				elist->derived->vindex);
-	  /* Build a label for the vindex value.  */
+	  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);
@@ -1601,8 +1601,8 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
 	 segfaults because it occurs too early and too often.  */
     free_elist:
       next_elist = elist->next;
-      if (elist->vindex)
-	gfc_free_expr (elist->vindex);
+      if (elist->hash_value)
+	gfc_free_expr (elist->hash_value);
       gfc_free (elist);
       elist = NULL;
     }
@@ -1613,12 +1613,12 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
 		     NULL_TREE, NULL_TREE, label);
   gfc_add_expr_to_block (&body, tmp);
   tmp = gfc_trans_runtime_error (true, &expr->where,
-		"internal error: bad vindex in dynamic dispatch");
+		"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, vindex, tmp, NULL_TREE);
+  tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE);
   gfc_add_expr_to_block (&se->pre, tmp);
 
   tmp = build1_v (LABEL_EXPR, end_label);
@@ -2531,6 +2531,60 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
 }
 
 
+/* Takes a derived type expression and returns the address of a temporary
+   class object of the 'declared' type.  */ 
+static void
+gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
+			   gfc_typespec class_ts)
+{
+  gfc_component *cmp;
+  gfc_symbol *vtab;
+  gfc_symbol *declared = class_ts.u.derived;
+  gfc_ss *ss;
+  tree ctree;
+  tree var;
+  tree tmp;
+
+  /* The derived type needs to be converted to a temporary
+     CLASS object.  */
+  tmp = gfc_typenode_for_spec (&class_ts);
+  var = gfc_create_var (tmp, "class");
+
+  /* Set the vptr.  */
+  cmp = gfc_find_component (declared, "$vptr", true, true);
+  ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+		       var, cmp->backend_decl, NULL_TREE);
+
+  /* Remember the vtab corresponds to the derived type
+    not to the class declared type.  */
+  vtab = gfc_find_derived_vtab (e->ts.u.derived);
+  gcc_assert (vtab);
+  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+  gfc_add_modify (&parmse->pre, ctree,
+		  fold_convert (TREE_TYPE (ctree), tmp));
+
+  /* Now set the data field.  */
+  cmp = gfc_find_component (declared, "$data", true, true);
+  ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+		       var, cmp->backend_decl, NULL_TREE);
+  ss = gfc_walk_expr (e);
+  if (ss == gfc_ss_terminator)
+    {
+      gfc_conv_expr_reference (parmse, e);
+      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+      gfc_add_modify (&parmse->pre, ctree, tmp);
+    }
+  else
+    {
+      gfc_conv_expr (parmse, e);
+      gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+    }
+
+  /* Pass the address of the class object.  */
+  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+}
+
+
 /* The following routine generates code for the intrinsic
    procedures from the ISO_C_BINDING module:
     * C_LOC           (function)
@@ -2800,53 +2854,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       else if (fsym && fsym->ts.type == BT_CLASS
 		 && e->ts.type == BT_DERIVED)
 	{
-	  tree data;
-	  tree vindex;
-	  tree size;
-
 	  /* The derived type needs to be converted to a temporary
 	     CLASS object.  */
 	  gfc_init_se (&parmse, se);
-	  type = gfc_typenode_for_spec (&fsym->ts);
-	  var = gfc_create_var (type, "class");
-
-	  /* Get the components.  */
-	  tmp = fsym->ts.u.derived->components->backend_decl;
-	  data = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
-			      var, tmp, NULL_TREE);
-	  tmp = fsym->ts.u.derived->components->next->backend_decl;
-	  vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
-				var, tmp, NULL_TREE);
-	  tmp = fsym->ts.u.derived->components->next->next->backend_decl;
-	  size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
-			      var, tmp, NULL_TREE);
-
-	  /* Set the vindex.  */
-	  tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex);
-	  gfc_add_modify (&parmse.pre, vindex, tmp);
-
-	  /* Set the size.  */
-	  tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts));
-	  gfc_add_modify (&parmse.pre, size,
-			  fold_convert (TREE_TYPE (size), tmp));
-
-	  /* Now set the data field.  */
-	  argss = gfc_walk_expr (e);
-	  if (argss == gfc_ss_terminator)
-            {
-	      gfc_conv_expr_reference (&parmse, e);
-	      tmp = fold_convert (TREE_TYPE (data),
-				  parmse.expr);
-	      gfc_add_modify (&parmse.pre, data, tmp);
-	    }
-	  else
-	    {
-	      gfc_conv_expr (&parmse, e);
-	      gfc_add_modify (&parmse.pre, data, parmse.expr);
-	    }
-
-	  /* Pass the address of the class object.  */
-	  parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
+	  gfc_conv_derived_to_class (&parmse, e, fsym->ts);
 	}
       else if (se->ss && se->ss->useflags)
 	{
@@ -4240,14 +4251,27 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 
       if (cm->ts.type == BT_CLASS)
 	{
+	  gfc_component *data;
+	  data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
 	  val = gfc_conv_initializer (c->expr, &cm->ts,
-	      TREE_TYPE (cm->ts.u.derived->components->backend_decl),
-	      cm->ts.u.derived->components->attr.dimension,
-	      cm->ts.u.derived->components->attr.pointer);
+				      TREE_TYPE (data->backend_decl),
+				      data->attr.dimension,
+				      data->attr.pointer);
 
-	  /* Append it to the constructor list.  */
-	  CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl,
-				  val);
+	  CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val);
+	}
+      else if (strcmp (cm->name, "$size") == 0)
+	{
+	  val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
+	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+	}
+      else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
+	       && strcmp (cm->name, "$extends") == 0)
+	{
+	  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);
 	}
       else
 	{
@@ -5366,47 +5390,37 @@ gfc_trans_class_assign (gfc_code *code)
 {
   stmtblock_t block;
   tree tmp;
+  gfc_expr *lhs;
+  gfc_expr *rhs;
 
   gfc_start_block (&block);
 
   if (code->expr2->ts.type != BT_CLASS)
     {
-      /* Insert an additional assignment which sets the '$vindex' field.  */
-      gfc_expr *lhs,*rhs;
+      /* Insert an additional assignment which sets the '$vptr' field.  */
       lhs = gfc_copy_expr (code->expr1);
-      gfc_add_component_ref (lhs, "$vindex");
-      if (code->expr2->ts.type == BT_DERIVED)
-	/* vindex is constant, determined at compile time.  */
-	rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex);
-      else if (code->expr2->expr_type == EXPR_NULL)
-	rhs = gfc_int_expr (0);
-      else
-	gcc_unreachable ();
-      tmp = gfc_trans_assignment (lhs, rhs, false);
-      gfc_add_expr_to_block (&block, tmp);
-
-      /* Insert another assignment which sets the '$size' field.  */
-      lhs = gfc_copy_expr (code->expr1);
-      gfc_add_component_ref (lhs, "$size");
+      gfc_add_component_ref (lhs, "$vptr");
       if (code->expr2->ts.type == BT_DERIVED)
 	{
-	  /* Size is fixed at compile time.  */
-	  gfc_se lse;
-	  gfc_init_se (&lse, NULL);
-	  gfc_conv_expr (&lse, lhs);
-	  tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
-	  gfc_add_modify (&block, lse.expr,
-			  fold_convert (TREE_TYPE (lse.expr), tmp));
+	  gfc_symbol *vtab;
+	  gfc_symtree *st;
+	  vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
+	  gcc_assert (vtab);
+
+	  rhs = gfc_get_expr ();
+	  rhs->expr_type = EXPR_VARIABLE;
+	  gfc_find_sym_tree (vtab->name, NULL, 1, &st);
+	  rhs->symtree = st;
+	  rhs->ts = vtab->ts;
 	}
       else if (code->expr2->expr_type == EXPR_NULL)
-	{
-	  rhs = gfc_int_expr (0);
-	  tmp = gfc_trans_assignment (lhs, rhs, false);
-	  gfc_add_expr_to_block (&block, tmp);
-	}
+	rhs = gfc_int_expr (0);
       else
 	gcc_unreachable ();
 
+      tmp = gfc_trans_pointer_assignment (lhs, rhs);
+      gfc_add_expr_to_block (&block, tmp);
+
       gfc_free_expr (lhs);
       gfc_free_expr (rhs);
     }
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 4273b82..208a3b5 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -4715,14 +4715,20 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
   b = expr->value.function.actual->next->expr;
 
   if (a->ts.type == BT_CLASS)
-    gfc_add_component_ref (a, "$vindex");
+    {
+      gfc_add_component_ref (a, "$vptr");
+      gfc_add_component_ref (a, "$hash");
+    }
   else if (a->ts.type == BT_DERIVED)
-    a = gfc_int_expr (a->ts.u.derived->vindex);
+    a = gfc_int_expr (a->ts.u.derived->hash_value);
 
   if (b->ts.type == BT_CLASS)
-    gfc_add_component_ref (b, "$vindex");
+    {
+      gfc_add_component_ref (b, "$vptr");
+      gfc_add_component_ref (b, "$hash");
+    }
   else if (b->ts.type == BT_DERIVED)
-    b = gfc_int_expr (b->ts.u.derived->vindex);
+    b = gfc_int_expr (b->ts.u.derived->hash_value);
 
   gfc_conv_expr (&se1, a);
   gfc_conv_expr (&se2, b);
@@ -4733,21 +4739,6 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
 }
 
 
-/* Generate code for the EXTENDS_TYPE_OF intrinsic.  */
-
-static void
-gfc_conv_extends_type_of (gfc_se *se, gfc_expr *expr)
-{
-  gfc_expr *e;
-  /* TODO: Implement EXTENDS_TYPE_OF.  */
-  gfc_error ("Intrinsic EXTENDS_TYPE_OF at %L not yet implemented",
-	     &expr->where);
-  /* Just return 'false' for now.  */
-  e = gfc_logical_expr (false, &expr->where);
-  gfc_conv_expr (se, e);
-}
-
-
 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function.  */
 
 static void
@@ -5157,10 +5148,6 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_same_type_as (se, expr);
       break;
 
-    case GFC_ISYM_EXTENDS_TYPE_OF:
-      gfc_conv_extends_type_of (se, expr);
-      break;
-
     case GFC_ISYM_ABS:
       gfc_conv_intrinsic_abs (se, expr);
       break;
@@ -5538,6 +5525,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
     case GFC_ISYM_CHMOD:
     case GFC_ISYM_DTIME:
     case GFC_ISYM_ETIME:
+    case GFC_ISYM_EXTENDS_TYPE_OF:
     case GFC_ISYM_FGET:
     case GFC_ISYM_FGETC:
     case GFC_ISYM_FNUM:
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 0411588..e9f76a0 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -4046,6 +4046,7 @@ gfc_trans_allocate (gfc_code * code)
 	      gfc_expr *sz;
 	      gfc_se se_sz;
 	      sz = gfc_copy_expr (code->expr3);
+	      gfc_add_component_ref (sz, "$vptr");
 	      gfc_add_component_ref (sz, "$size");
 	      gfc_init_se (&se_sz, NULL);
 	      gfc_conv_expr (&se_sz, sz);
@@ -4141,42 +4142,49 @@ gfc_trans_allocate (gfc_code * code)
 	{
 	  gfc_expr *lhs,*rhs;
 	  gfc_se lse;
-	  /* Initialize VINDEX for CLASS objects.  */
+
+	  /* Initialize VPTR for CLASS objects.  */
 	  lhs = gfc_expr_to_initialize (expr);
-	  gfc_add_component_ref (lhs, "$vindex");
+	  gfc_add_component_ref (lhs, "$vptr");
+	  rhs = NULL;
 	  if (code->expr3 && code->expr3->ts.type == BT_CLASS)
 	    {
-	      /* vindex must be determined at run time.  */
+	      /* VPTR must be determined at run time.  */
 	      rhs = gfc_copy_expr (code->expr3);
-	      gfc_add_component_ref (rhs, "$vindex");
+	      gfc_add_component_ref (rhs, "$vptr");
+	      tmp = gfc_trans_pointer_assignment (lhs, rhs);
+	      gfc_add_expr_to_block (&block, tmp);
+	      gfc_free_expr (rhs);
 	    }
 	  else
 	    {
-	      /* vindex is fixed at compile time.  */
-	      int vindex;
+	      /* VPTR is fixed at compile time.  */
+	      gfc_symbol *vtab;
+	      gfc_typespec *ts;
 	      if (code->expr3)
-		vindex = code->expr3->ts.u.derived->vindex;
+		ts = &code->expr3->ts;
+	      else if (expr->ts.type == BT_DERIVED)
+		ts = &expr->ts;
 	      else if (code->ext.alloc.ts.type == BT_DERIVED)
-		vindex = code->ext.alloc.ts.u.derived->vindex;
+		ts = &code->ext.alloc.ts;
 	      else if (expr->ts.type == BT_CLASS)
-		vindex = expr->ts.u.derived->components->ts.u.derived->vindex;
+		ts = &expr->ts.u.derived->components->ts;
 	      else
-		vindex = expr->ts.u.derived->vindex;
-	      rhs = gfc_int_expr (vindex);
-	    }
-	  tmp = gfc_trans_assignment (lhs, rhs, false);
-	  gfc_free_expr (lhs);
-	  gfc_free_expr (rhs);
-	  gfc_add_expr_to_block (&block, tmp);
+		ts = &expr->ts;
 
-	  /* Initialize SIZE for CLASS objects.  */
-	  lhs = gfc_expr_to_initialize (expr);
-	  gfc_add_component_ref (lhs, "$size");
-	  gfc_init_se (&lse, NULL);
-	  gfc_conv_expr (&lse, lhs);
-	  gfc_add_modify (&block, lse.expr,
-			  fold_convert (TREE_TYPE (lse.expr), memsz));
-	  gfc_free_expr (lhs);
+	      if (ts->type == BT_DERIVED)
+		{
+		  vtab = gfc_find_derived_vtab (ts->u.derived);
+		  gcc_assert (vtab);
+		  gfc_init_se (&lse, NULL);
+		  lse.want_pointer = 1;
+		  gfc_conv_expr (&lse, lhs);
+		  tmp = gfc_build_addr_expr (NULL_TREE,
+					     gfc_get_symbol_decl (vtab));
+		  gfc_add_modify (&block, lse.expr,
+			fold_convert (TREE_TYPE (lse.expr), tmp));
+		}
+	    }
 	}
 
     }
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 1864477..278ae27 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -53,8 +53,6 @@ along with GCC; see the file COPYING3.  If not see
 /* array of structs so we don't have to worry about xmalloc or free */
 CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
 
-static tree gfc_get_derived_type (gfc_symbol * derived);
-
 tree gfc_array_index_type;
 tree gfc_array_range_type;
 tree gfc_character1_type_node;
@@ -1941,7 +1939,7 @@ gfc_get_ppc_type (gfc_component* c)
    at the same time.  If an equal derived type has been built
    in a parent namespace, this is used.  */
 
-static tree
+tree
 gfc_get_derived_type (gfc_symbol * derived)
 {
   tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e4cf40f..d9221faf 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,27 @@
+2009-11-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42053
+	* gfortran.dg/select_type_9.f03: New.
+
+2009-11-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41631
+	* gfortran.dg/extends_type_of_1.f03: Fix invalid test case.
+	* gfortran.dg/module_md5_1.f90: Adjusted MD5 sum.
+	* gfortran.dg/select_type_1.f03: Remove FIXMEs.
+	* gfortran.dg/select_type_2.f03: Ditto.
+	* gfortran.dg/select_type_8.f03: New test.
+
+2009-11-30  Janus Weil  <janus@gcc.gnu.org>
+
+	* gfortran.dg/extends_type_of_1.f03: New test.
+	* gfortran.dg/same_type_as_1.f03: Extended.
+
+2009-11-30  Paul Thomas  <pault@gcc.gnu.org>
+
+	* gfortran.dg/class_4c.f03: Add dg-additional-sources.
+	* gfortran.dg/class_4d.f03: Rename module. Cleanup modules.
+
 2009-11-30  Janis Johnson  <janis187@us.ibm.com>
 
 	PR testsuite/42212
diff --git a/gcc/testsuite/gfortran.dg/class_4c.f03 b/gcc/testsuite/gfortran.dg/class_4c.f03
index 7909c0e..c76b3ab 100644
--- a/gcc/testsuite/gfortran.dg/class_4c.f03
+++ b/gcc/testsuite/gfortran.dg/class_4c.f03
@@ -1,4 +1,5 @@
 ! { dg-do run }
+! { dg-additional-sources class_4a.f03 class_4b.f03 }
 !
 ! Test the fix for PR41583, in which the different source files
 ! would generate the same 'vindex' for different class declared
diff --git a/gcc/testsuite/gfortran.dg/class_4d.f03 b/gcc/testsuite/gfortran.dg/class_4d.f03
index 7a962aa..80934b6 100644
--- a/gcc/testsuite/gfortran.dg/class_4d.f03
+++ b/gcc/testsuite/gfortran.dg/class_4d.f03
@@ -8,8 +8,8 @@
 !
 ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
 !
-module m
+module m3
   type t
   end type t
-end module m
-! { dg-final { cleanup-modules "m m2" } }
+end module m3
+! { dg-final { cleanup-modules "m m2 m3" } }
diff --git a/gcc/testsuite/gfortran.dg/extends_type_of_1.f03 b/gcc/testsuite/gfortran.dg/extends_type_of_1.f03
new file mode 100644
index 0000000..9e98384
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/extends_type_of_1.f03
@@ -0,0 +1,48 @@
+! { dg-do run }
+!
+! Verifying the runtime behavior of the intrinsic function EXTENDS_TYPE_OF.
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+ implicit none
+
+ intrinsic :: extends_type_of
+
+ type :: t1
+   integer :: i = 42
+ end type
+
+ type, extends(t1) :: t2
+   integer :: j = 43
+ end type
+
+ type, extends(t2) :: t3
+   class(t1),pointer :: cc
+ end type
+
+ class(t1), pointer :: c1,c2
+ type(t1), target :: x
+ type(t2), target :: y
+ type(t3), target :: z
+ 
+ c1 => x
+ c2 => y
+ z%cc => y
+
+ if (.not. extends_type_of (c1, c1)) call abort()
+ if (      extends_type_of (c1, c2)) call abort()
+ if (.not. extends_type_of (c2, c1)) call abort()
+
+ if (.not. extends_type_of (x, x)) call abort()
+ if (      extends_type_of (x, y)) call abort()
+ if (.not. extends_type_of (y, x)) call abort()
+
+ if (.not. extends_type_of (c1, x)) call abort()
+ if (      extends_type_of (c1, y)) call abort()
+ if (.not. extends_type_of (x, c1)) call abort()
+ if (.not. extends_type_of (y, c1)) call abort()
+
+ if (.not. extends_type_of (z,   c1)) call abort()
+ if (      extends_type_of (z%cc, z)) call abort()
+
+end
diff --git a/gcc/testsuite/gfortran.dg/module_md5_1.f90 b/gcc/testsuite/gfortran.dg/module_md5_1.f90
index 88002c2..e725b4b 100644
--- a/gcc/testsuite/gfortran.dg/module_md5_1.f90
+++ b/gcc/testsuite/gfortran.dg/module_md5_1.f90
@@ -10,5 +10,5 @@ program test
   use foo
   print *, pi
 end program test
-! { dg-final { scan-module "foo" "MD5:9c43cf4d713824ec6894b83250720e68" } }
+! { dg-final { scan-module "foo" "MD5:5632bcd379cf023bf7e663e91d52fa12" } }
 ! { dg-final { cleanup-modules "foo" } }
diff --git a/gcc/testsuite/gfortran.dg/same_type_as_1.f03 b/gcc/testsuite/gfortran.dg/same_type_as_1.f03
index ba13a0b..45b5d26 100644
--- a/gcc/testsuite/gfortran.dg/same_type_as_1.f03
+++ b/gcc/testsuite/gfortran.dg/same_type_as_1.f03
@@ -1,6 +1,6 @@
 ! { dg-do compile }
 !
-! Error checking for the intrinsic function SAME_TYPE_AS.
+! Error checking for the intrinsic functions SAME_TYPE_AS and EXTENDS_TYPE_OF.
 !
 ! Contributed by Janus Weil <janus@gcc.gnu.org>
 
@@ -18,7 +18,10 @@
 
  integer :: i
 
- print *, SAME_TYPE_AS (l,x1)   ! { dg-error "must be of a derived type" }
+ print *, SAME_TYPE_AS (i,x1)   ! { dg-error "must be of a derived type" }
  print *, SAME_TYPE_AS (x1,x2)  ! { dg-error "must be of an extensible type" }
 
+ print *, EXTENDS_TYPE_OF (i,x1)   ! { dg-error "must be of a derived type" }
+ print *, EXTENDS_TYPE_OF (x1,x2)  ! { dg-error "must be of an extensible type" }
+
 end
diff --git a/gcc/testsuite/gfortran.dg/select_type_1.f03 b/gcc/testsuite/gfortran.dg/select_type_1.f03
index 6a7db2e..0214c51 100644
--- a/gcc/testsuite/gfortran.dg/select_type_1.f03
+++ b/gcc/testsuite/gfortran.dg/select_type_1.f03
@@ -40,16 +40,14 @@
     print *,"a is TYPE(t1)"
   type is (t2)
     print *,"a is TYPE(t2)"
-! FIXME: CLASS IS specification is not yet supported
-!  class is (ts)  ! { FIXME: error "must be extensible" }
-!    print *,"a is TYPE(ts)"
+  class is (ts)  ! { dg-error "must be extensible" }
+    print *,"a is TYPE(ts)"
   type is (t3)   ! { dg-error "must be an extension of" }
     print *,"a is TYPE(t3)"
   type is (t4)   ! { dg-error "is not an accessible derived type" }
     print *,"a is TYPE(t3)"
-! FIXME: CLASS IS specification is not yet supported
-!  class is (t1)
-!    print *,"a is CLASS(t1)"
+  class is (t1)
+    print *,"a is CLASS(t1)"
   class is (t2) label  ! { dg-error "Syntax error" }
     print *,"a is CLASS(t2)"
   class default  ! { dg-error "cannot be followed by a second DEFAULT CASE" }
diff --git a/gcc/testsuite/gfortran.dg/select_type_2.f03 b/gcc/testsuite/gfortran.dg/select_type_2.f03
index 08ac9fe..d4a5343 100644
--- a/gcc/testsuite/gfortran.dg/select_type_2.f03
+++ b/gcc/testsuite/gfortran.dg/select_type_2.f03
@@ -30,9 +30,8 @@
     i = 1
   type is (t2)
     i = 2
-! FIXME: CLASS IS is not yet supported
-!  class is (t1)
-!    i = 3
+  class is (t1)
+    i = 3
   end select
 
   if (i /= 1) call abort()
@@ -45,9 +44,8 @@
     i = 1
   type is (t2)
     i = 2
-! FIXME: CLASS IS is not yet supported
-!  class is (t2)
-!    i = 3
+  class is (t2)
+    i = 3
   end select
 
   if (i /= 2) call abort()
diff --git a/gcc/testsuite/gfortran.dg/select_type_8.f03 b/gcc/testsuite/gfortran.dg/select_type_8.f03
new file mode 100644
index 0000000..306f2d1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_8.f03
@@ -0,0 +1,98 @@
+! { dg-do run }
+!
+! executing SELECT TYPE statements with CLASS IS blocks
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+  implicit none
+
+  type :: t1
+    integer :: i
+  end type t1
+
+  type, extends(t1) :: t2
+    integer :: j
+  end type t2
+
+  type, extends(t2) :: t3
+    real :: r
+  end type
+
+  class(t1), pointer :: cp
+  type(t1), target :: a
+  type(t2), target :: b
+  type(t3), target :: c
+  integer :: i
+
+  cp => c
+  i = 0
+  select type (cp)
+  type is (t1)
+    i = 1
+  type is (t2)
+    i = 2
+  class is (t1)
+    i = 3
+  class default
+    i = 4
+  end select
+  print *,i
+  if (i /= 3) call abort()
+
+  cp => a
+  select type (cp)
+  type is (t1)
+    i = 1
+  type is (t2)
+    i = 2
+  class is (t1)
+    i = 3
+  end select
+  print *,i
+  if (i /= 1) call abort()
+
+  cp => b
+  select type (cp)
+  type is (t1)
+    i = 1
+  class is (t3)
+    i = 3
+  class is (t2)
+    i = 4
+  class is (t1)
+    i = 5
+  end select
+  print *,i
+  if (i /= 4) call abort()
+
+  cp => b
+  select type (cp)
+  type is (t1)
+    i = 1
+  class is (t1)
+    i = 5
+  class is (t2)
+    i = 4
+  class is (t3)
+    i = 3
+  end select
+  print *,i
+  if (i /= 4) call abort()
+
+  cp => a
+  select type (cp)
+  type is (t2)
+    i = 1
+  class is (t2)
+    i = 2
+  class default
+    i = 3
+  class is (t3)
+    i = 4
+  type is (t3)
+    i = 5
+  end select
+  print *,i
+  if (i /= 3) call abort()
+
+end
diff --git a/gcc/testsuite/gfortran.dg/select_type_9.f03 b/gcc/testsuite/gfortran.dg/select_type_9.f03
new file mode 100644
index 0000000..62df670
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_9.f03
@@ -0,0 +1,20 @@
+! { dg-do compile }
+!
+! PR 42053: [OOP] SELECT TYPE: reject duplicate CLASS IS blocks
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+ type :: t
+  integer :: i
+ end type
+
+ CLASS(t),pointer :: x
+
+ select type (x)
+ class is (t)
+  print *,"a"
+ class is (t)  ! { dg-error "Double CLASS IS block" }
+  print *,"b"
+ end select
+
+end
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index e84d844..68bf897 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,10 @@
+2009-11-30  Janus Weil  <janus@gcc.gnu.org>
+
+	* gfortran.map: Add _gfortran_is_extension_of.
+	* Makefile.am: Add intrinsics/extends_type_of.c.
+	* Makefile.in: Regenerated.
+	* intrinsics/extends_type_of.c: New file. 
+
 2009-11-30  Kai Tietz  <Kai.Tietz@onevision.com>
 
 	* io/unix.c (find_file): Add variable id conditionally for
diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am
index db086bb..bd767a2 100644
--- a/libgfortran/Makefile.am
+++ b/libgfortran/Makefile.am
@@ -85,6 +85,7 @@ intrinsics/eoshift2.c \
 intrinsics/erfc_scaled.c \
 intrinsics/etime.c \
 intrinsics/exit.c \
+intrinsics/extends_type_of.c \
 intrinsics/fnum.c \
 intrinsics/gerror.c \
 intrinsics/getcwd.c \
diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in
index 8fca11e..9bc8f11 100644
--- a/libgfortran/Makefile.in
+++ b/libgfortran/Makefile.in
@@ -433,15 +433,15 @@ am__libgfortran_la_SOURCES_DIST = runtime/backtrace.c runtime/bounds.c \
 	intrinsics/date_and_time.c intrinsics/dtime.c intrinsics/env.c \
 	intrinsics/eoshift0.c intrinsics/eoshift2.c \
 	intrinsics/erfc_scaled.c intrinsics/etime.c intrinsics/exit.c \
-	intrinsics/fnum.c intrinsics/gerror.c intrinsics/getcwd.c \
-	intrinsics/getlog.c intrinsics/getXid.c intrinsics/hostnm.c \
-	intrinsics/ierrno.c intrinsics/ishftc.c \
-	intrinsics/iso_c_generated_procs.c intrinsics/iso_c_binding.c \
-	intrinsics/kill.c intrinsics/link.c intrinsics/malloc.c \
-	intrinsics/mvbits.c intrinsics/move_alloc.c \
-	intrinsics/pack_generic.c intrinsics/perror.c \
-	intrinsics/selected_char_kind.c intrinsics/signal.c \
-	intrinsics/size.c intrinsics/sleep.c \
+	intrinsics/extends_type_of.c intrinsics/fnum.c \
+	intrinsics/gerror.c intrinsics/getcwd.c intrinsics/getlog.c \
+	intrinsics/getXid.c intrinsics/hostnm.c intrinsics/ierrno.c \
+	intrinsics/ishftc.c intrinsics/iso_c_generated_procs.c \
+	intrinsics/iso_c_binding.c intrinsics/kill.c intrinsics/link.c \
+	intrinsics/malloc.c intrinsics/mvbits.c \
+	intrinsics/move_alloc.c intrinsics/pack_generic.c \
+	intrinsics/perror.c intrinsics/selected_char_kind.c \
+	intrinsics/signal.c intrinsics/size.c intrinsics/sleep.c \
 	intrinsics/spread_generic.c intrinsics/string_intrinsics.c \
 	intrinsics/system.c intrinsics/rand.c intrinsics/random.c \
 	intrinsics/rename.c intrinsics/reshape_generic.c \
@@ -725,15 +725,16 @@ am__objects_36 = associated.lo abort.lo access.lo args.lo \
 	bit_intrinsics.lo c99_functions.lo chdir.lo chmod.lo clock.lo \
 	cpu_time.lo cshift0.lo ctime.lo date_and_time.lo dtime.lo \
 	env.lo eoshift0.lo eoshift2.lo erfc_scaled.lo etime.lo exit.lo \
-	fnum.lo gerror.lo getcwd.lo getlog.lo getXid.lo hostnm.lo \
-	ierrno.lo ishftc.lo iso_c_generated_procs.lo iso_c_binding.lo \
-	kill.lo link.lo malloc.lo mvbits.lo move_alloc.lo \
-	pack_generic.lo perror.lo selected_char_kind.lo signal.lo \
-	size.lo sleep.lo spread_generic.lo string_intrinsics.lo \
-	system.lo rand.lo random.lo rename.lo reshape_generic.lo \
-	reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
-	stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \
-	umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \
+	extends_type_of.lo fnum.lo gerror.lo getcwd.lo getlog.lo \
+	getXid.lo hostnm.lo ierrno.lo ishftc.lo \
+	iso_c_generated_procs.lo iso_c_binding.lo kill.lo link.lo \
+	malloc.lo mvbits.lo move_alloc.lo pack_generic.lo perror.lo \
+	selected_char_kind.lo signal.lo size.lo sleep.lo \
+	spread_generic.lo string_intrinsics.lo system.lo rand.lo \
+	random.lo rename.lo reshape_generic.lo reshape_packed.lo \
+	selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \
+	system_clock.lo time.lo transpose_generic.lo umask.lo \
+	unlink.lo unpack_generic.lo in_pack_generic.lo \
 	in_unpack_generic.lo
 am__objects_37 =
 am__objects_38 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
@@ -1030,6 +1031,7 @@ intrinsics/eoshift2.c \
 intrinsics/erfc_scaled.c \
 intrinsics/etime.c \
 intrinsics/exit.c \
+intrinsics/extends_type_of.c \
 intrinsics/fnum.c \
 intrinsics/gerror.c \
 intrinsics/getcwd.c \
@@ -1892,6 +1894,7 @@ distclean-compile:
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exponent_r16.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exponent_r4.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exponent_r8.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/extends_type_of.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fbuf.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/file_pos.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fmain.Plo@am__quote@
@@ -5478,6 +5481,13 @@ exit.lo: intrinsics/exit.c
 @AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 @am__fastdepCC_FALSE@	$(LIBTOOL)  --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o exit.lo `test -f 'intrinsics/exit.c' || echo '$(srcdir)/'`intrinsics/exit.c
 
+extends_type_of.lo: intrinsics/extends_type_of.c
+@am__fastdepCC_TRUE@	$(LIBTOOL)  --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT extends_type_of.lo -MD -MP -MF $(DEPDIR)/extends_type_of.Tpo -c -o extends_type_of.lo `test -f 'intrinsics/extends_type_of.c' || echo '$(srcdir)/'`intrinsics/extends_type_of.c
+@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/extends_type_of.Tpo $(DEPDIR)/extends_type_of.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='intrinsics/extends_type_of.c' object='extends_type_of.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@	$(LIBTOOL)  --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o extends_type_of.lo `test -f 'intrinsics/extends_type_of.c' || echo '$(srcdir)/'`intrinsics/extends_type_of.c
+
 fnum.lo: intrinsics/fnum.c
 @am__fastdepCC_TRUE@	$(LIBTOOL)  --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT fnum.lo -MD -MP -MF $(DEPDIR)/fnum.Tpo -c -o fnum.lo `test -f 'intrinsics/fnum.c' || echo '$(srcdir)/'`intrinsics/fnum.c
 @am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/fnum.Tpo $(DEPDIR)/fnum.Plo
diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map
index a149332..3541d14 100644
--- a/libgfortran/gfortran.map
+++ b/libgfortran/gfortran.map
@@ -1095,6 +1095,7 @@ GFORTRAN_1.2 {
   global:
     _gfortran_clz128;
     _gfortran_ctz128;
+    _gfortran_is_extension_of;
 } GFORTRAN_1.1; 
 
 F2C_1.0 {
diff --git a/libgfortran/intrinsics/extends_type_of.c b/libgfortran/intrinsics/extends_type_of.c
new file mode 100644
index 0000000..2fd149c
--- /dev/null
+++ b/libgfortran/intrinsics/extends_type_of.c
@@ -0,0 +1,61 @@
+/* Implementation of the EXTENDS_TYPE_OF intrinsic.
+   Copyright (C) 2004, 2007, 2009 Free Software Foundation, Inc.
+   Contributed by Janus Weil <janus@gcc.gnu.org>.
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran 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 of the License, or (at your option) any later version.
+
+Libgfortran 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */ 
+
+
+#include "libgfortran.h"
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+
+typedef struct vtype
+{
+  GFC_INTEGER_4 hash;
+  GFC_INTEGER_4 size;
+  struct vtype *extends;
+}
+vtype;
+
+
+extern GFC_LOGICAL_4 is_extension_of (struct vtype *, struct vtype *);
+export_proto(is_extension_of);
+
+
+/* This is a helper function for the F2003 intrinsic EXTENDS_TYPE_OF.
+   While EXTENDS_TYPE_OF accepts CLASS or TYPE arguments, this one here gets
+   passed the corresponding vtabs. Each call to EXTENDS_TYPE_OF is translated
+   to a call to is_extension_of.  */
+
+GFC_LOGICAL_4
+is_extension_of (struct vtype *v1, struct vtype *v2)
+{
+  while (v1)
+    {
+      if (v1->hash == v2->hash) return 1;
+      v1 = v1->extends;
+    }
+  return 0;
+}
-- 
cgit v1.1