[gcc] GCC 4.5.0=>4.5.1

gcc/gcc/fortran/symbol.c

Index: gcc/gcc/fortran/symbol.c
diff --git a/gcc/gcc/fortran/symbol.c b/gcc/gcc/fortran/symbol.c
index 6a82d1055db30c59598bce934db164eb864ebeb8..98af7550f2241c362f3b7a50cef39a7f55981538 100644
--- a/gcc/gcc/fortran/symbol.c
+++ b/gcc/gcc/fortran/symbol.c
@@ -1,5 +1,6 @@
 /* Maintain binary trees of symbols.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+   2009, 2010
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -75,8 +76,7 @@ const mstring ifsrc_types[] =
 {
     minit ("UNKNOWN", IFSRC_UNKNOWN),
     minit ("DECL", IFSRC_DECL),
-    minit ("BODY", IFSRC_IFBODY),
-    minit ("USAGE", IFSRC_USAGE)
+    minit ("BODY", IFSRC_IFBODY)
 };
 
 const mstring save_status[] =
@@ -93,6 +93,7 @@ static int next_dummy_order = 1;
 
 
 gfc_namespace *gfc_current_ns;
+gfc_namespace *gfc_global_ns_list;
 
 gfc_gsymbol *gfc_gsym_root = NULL;
 
@@ -101,6 +102,18 @@ static gfc_symbol *changed_syms = NULL;
 gfc_dt_list *gfc_derived_types;
 
 
+/* List of tentative typebound-procedures.  */
+
+typedef struct tentative_tbp
+{
+  gfc_typebound_proc *proc;
+  struct tentative_tbp *next;
+}
+tentative_tbp;
+
+static tentative_tbp *tentative_tbp_list = NULL;
+
+
 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
 
 /* The following static variable indicates whether a particular element has
@@ -207,11 +220,11 @@ gfc_merge_new_implicit (gfc_typespec *ts)
 /* Given a symbol, return a pointer to the typespec for its default type.  */
 
 gfc_typespec *
-gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns)
+gfc_get_default_type (const char *name, gfc_namespace *ns)
 {
   char letter;
 
-  letter = sym->name[0];
+  letter = name[0];
 
   if (gfc_option.flag_allow_leading_underscore && letter == '_')
     gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
@@ -219,7 +232,7 @@ gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns)
 			"implicitly typed variables");
 
   if (letter < 'a' || letter > 'z')
-    gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'",sym->name);
+    gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
 
   if (ns == NULL)
     ns = gfc_current_ns;
@@ -240,7 +253,7 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
   if (sym->ts.type != BT_UNKNOWN)
     gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
 
-  ts = gfc_get_default_type (sym, ns);
+  ts = gfc_get_default_type (sym->name, ns);
 
   if (ts->type == BT_UNKNOWN)
     {
@@ -257,11 +270,8 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
   sym->ts = *ts;
   sym->attr.implicit_type = 1;
 
-  if (ts->cl)
-    {
-      sym->ts.cl = gfc_get_charlen ();
-      *sym->ts.cl = *ts->cl;
-    }
+  if (ts->type == BT_CHARACTER && ts->u.cl)
+    sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
 
   if (sym->attr.is_bind_c == 1)
     {
@@ -305,7 +315,7 @@ gfc_check_function_type (gfc_namespace *ns)
   if (!proc->attr.contained || proc->result->attr.implicit_type)
     return;
 
-  if (proc->result->ts.type == BT_UNKNOWN)
+  if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
     {
       if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
 		== SUCCESS)
@@ -319,7 +329,7 @@ gfc_check_function_type (gfc_namespace *ns)
 	      proc->attr.allocatable = proc->result->attr.allocatable;
 	    }
 	}
-      else
+      else if (!proc->result->attr.proc_pointer)
 	{
 	  gfc_error ("Function result '%s' at %L has no IMPLICIT type",
 		     proc->result->name, &proc->result->declared_at);
@@ -360,7 +370,8 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
     *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
     *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
     *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
-    *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
+    *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
+    *asynchronous = "ASYNCHRONOUS";
   static const char *threadprivate = "THREADPRIVATE";
 
   const char *a1, *a2;
@@ -452,10 +463,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (entry, intrinsic);
 
   if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
-    {
-      conf (external, subroutine);
-      conf (external, function);
-    }
+    conf (external, subroutine);
+
+  if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003,
+			    "Fortran 2003: Procedure pointer at %C") == FAILURE)
+    return FAILURE;
 
   conf (allocatable, pointer);
   conf_std (allocatable, dummy, GFC_STD_F2003);
@@ -549,6 +561,9 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (is_protected, external)
   conf (is_protected, in_common)
 
+  conf (asynchronous, intrinsic)
+  conf (asynchronous, external)
+
   conf (volatile_, intrinsic)
   conf (volatile_, external)
 
@@ -566,6 +581,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (procedure, target)
   conf (procedure, value)
   conf (procedure, volatile_)
+  conf (procedure, asynchronous)
   conf (procedure, entry)
 
   a1 = gfc_code2string (flavors, attr->flavor);
@@ -588,6 +604,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       conf2 (dimension);
       conf2 (dummy);
       conf2 (volatile_);
+      conf2 (asynchronous);
       conf2 (pointer);
       conf2 (is_protected);
       conf2 (target);
@@ -625,14 +642,16 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       break;
 
     case FL_PROCEDURE:
-      /* Conflicts with INTENT will be checked at resolution stage,
-	 see "resolve_fl_procedure".  */
+      /* Conflicts with INTENT, SAVE and RESULT will be checked
+	 at resolution stage, see "resolve_fl_procedure".  */
 
       if (attr->subroutine)
 	{
+	  a1 = subroutine;
 	  conf2 (target);
 	  conf2 (allocatable);
-	  conf2 (result);
+	  conf2 (volatile_);
+	  conf2 (asynchronous);
 	  conf2 (in_namelist);
 	  conf2 (dimension);
 	  conf2 (function);
@@ -699,6 +718,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       conf2 (in_common);
       conf2 (value);
       conf2 (volatile_);
+      conf2 (asynchronous);
       conf2 (threadprivate);
       conf2 (value);
       conf2 (is_bind_c);
@@ -797,19 +817,28 @@ duplicate_attr (const char *attr, locus *where)
 }
 
 
+gfc_try
+gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
+		       locus *where ATTRIBUTE_UNUSED)
+{
+  attr->ext_attr |= 1 << ext_attr;
+  return SUCCESS;
+}
+
+
 /* Called from decl.c (attr_decl1) to check attributes, when declared
    separately.  */
 
 gfc_try
 gfc_add_attribute (symbol_attribute *attr, locus *where)
 {
-
   if (check_used (attr, NULL, where))
     return FAILURE;
 
   return check_conflict (attr, NULL, where);
 }
 
+
 gfc_try
 gfc_add_allocatable (symbol_attribute *attr, locus *where)
 {
@@ -1027,7 +1056,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",
@@ -1082,6 +1111,25 @@ gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
 
 
 gfc_try
+gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
+{
+  /* No check_used needed as 11.2.1 of the F2003 standard allows
+     that the local identifier made accessible by a use statement can be
+     given a ASYNCHRONOUS attribute.  */
+
+  if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
+    if (gfc_notify_std (GFC_STD_LEGACY, 
+        		"Duplicate ASYNCHRONOUS attribute specified at %L",
+			where) == FAILURE)
+      return FAILURE;
+
+  attr->asynchronous = 1;
+  attr->asynchronous_ns = gfc_current_ns;
+  return check_conflict (attr, name, where);
+}
+
+
+gfc_try
 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
 {
 
@@ -1547,26 +1595,31 @@ gfc_try
 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
 {
   sym_flavor flavor;
+  bt type;
 
   if (where == NULL)
     where = &gfc_current_locus;
 
-  if (sym->ts.type != BT_UNKNOWN)
+  if (sym->result)
+    type = sym->result->ts.type;
+  else
+    type = sym->ts.type;
+
+  if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
+    type = sym->ns->proc_name->ts.type;
+
+  if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
     {
-      const char *msg = "Symbol '%s' at %L already has basic type of %s";
-      if (!(sym->ts.type == ts->type
-	    && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result))
-	  || gfc_notification_std (GFC_STD_GNU) == ERROR
-	  || pedantic)
-	{
-	  gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
-	  return FAILURE;
-	}
-      if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
-	      		  gfc_basic_typename (sym->ts.type)) == FAILURE)
-	return FAILURE;
-      if (gfc_option.warn_surprising)
-	gfc_warning (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
+      gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
+		 where, gfc_basic_typename (type));
+      return FAILURE;
+    }
+
+  if (sym->attr.procedure && sym->ts.interface)
+    {
+      gfc_error ("Procedure '%s' at %L may not have basic type of %s",
+		 sym->name, where, gfc_basic_typename (ts->type));
+      return FAILURE;
     }
 
   flavor = sym->attr.flavor;
@@ -1615,6 +1668,10 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
 {
   int is_proc_lang_bind_spec;
   
+  /* In line with the other attributes, we only add bits but do not remove
+     them; cf. also PR 41034.  */
+  dest->ext_attr |= src->ext_attr;
+
   if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
     goto fail;
 
@@ -1632,6 +1689,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
     goto fail;
   if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
     goto fail;
+  if (src->asynchronous && gfc_add_asynchronous (dest, NULL, where) == FAILURE)
+    goto fail;
   if (src->threadprivate
       && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
     goto fail;
@@ -1684,7 +1743,7 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
   if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
     goto fail;
   if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
-    goto fail;    
+    goto fail;
 
   is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
   if (src->is_bind_c
@@ -1744,10 +1803,10 @@ gfc_add_component (gfc_symbol *sym, const char *name,
     }
 
   if (sym->attr.extension
-	&& gfc_find_component (sym->components->ts.derived, name, true, true))
+	&& gfc_find_component (sym->components->ts.u.derived, name, true, true))
     {
       gfc_error ("Component '%s' at %C already in the parent type "
-		 "at %L", name, &sym->components->ts.derived->declared_at);
+		 "at %L", name, &sym->components->ts.u.derived->declared_at);
       return FAILURE;
     }
 
@@ -1761,6 +1820,7 @@ gfc_add_component (gfc_symbol *sym, const char *name,
 
   p->name = gfc_get_string (name);
   p->loc = gfc_current_locus;
+  p->ts.type = BT_UNKNOWN;
 
   *component = p;
   return SUCCESS;
@@ -1779,8 +1839,8 @@ switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
     return;
 
   sym = st->n.sym;
-  if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
-    sym->ts.derived = to;
+  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
+    sym->ts.u.derived = to;
 
   switch_types (st->left, from, to);
   switch_types (st->right, from, to);
@@ -1832,8 +1892,8 @@ gfc_use_derived (gfc_symbol *sym)
   for (i = 0; i < GFC_LETTERS; i++)
     {
       t = &sym->ns->default_type[i];
-      if (t->derived == sym)
-	t->derived = s;
+      if (t->u.derived == sym)
+	t->u.derived = s;
     }
 
   st = gfc_find_symtree (sym->ns->sym_root, sym->name);
@@ -1886,7 +1946,7 @@ gfc_find_component (gfc_symbol *sym, const char *name,
 	&& sym->attr.extension
 	&& sym->components->ts.type == BT_DERIVED)
     {
-      p = gfc_find_component (sym->components->ts.derived, name,
+      p = gfc_find_component (sym->components->ts.u.derived, name,
 			      noaccess, silent);
       /* Do not overwrite the error.  */
       if (p == NULL)
@@ -1899,23 +1959,17 @@ gfc_find_component (gfc_symbol *sym, const char *name,
 
   else if (sym->attr.use_assoc && !noaccess)
     {
-      if (p->attr.access == ACCESS_PRIVATE)
+      bool is_parent_comp = sym->attr.extension && (p == sym->components);
+      if (p->attr.access == ACCESS_PRIVATE ||
+	  (p->attr.access != ACCESS_PUBLIC
+	   && sym->component_access == ACCESS_PRIVATE
+	   && !is_parent_comp))
 	{
 	  if (!silent)
 	    gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
 		       name, sym->name);
 	  return NULL;
 	}
-	
-      /* If there were components given and all components are private, error
-	 out at this place.  */
-      if (p->attr.access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
-	{
-	  if (!silent)
-	    gfc_error ("All components of '%s' are PRIVATE in structure"
-		       " constructor at %C", sym->name);
-	  return NULL;
-	}
     }
 
   return p;
@@ -2002,9 +2056,16 @@ gfc_st_label *
 gfc_get_st_label (int labelno)
 {
   gfc_st_label *lp;
+  gfc_namespace *ns;
+
+  /* Find the namespace of the scoping unit:
+     If we're in a BLOCK construct, jump to the parent namespace.  */
+  ns = gfc_current_ns;
+  while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
+    ns = ns->parent;
 
   /* First see if the label is already in this namespace.  */
-  lp = gfc_current_ns->st_labels;
+  lp = ns->st_labels;
   while (lp)
     {
       if (lp->value == labelno)
@@ -2022,7 +2083,7 @@ gfc_get_st_label (int labelno)
   lp->defined = ST_LABEL_UNKNOWN;
   lp->referenced = ST_LABEL_UNKNOWN;
 
-  gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
+  gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
 
   return lp;
 }
@@ -2179,18 +2240,22 @@ gfc_get_namespace (gfc_namespace *parent, int parent_types)
 {
   gfc_namespace *ns;
   gfc_typespec *ts;
-  gfc_intrinsic_op in;
+  int in;
   int i;
 
   ns = XCNEW (gfc_namespace);
   ns->sym_root = NULL;
   ns->uop_root = NULL;
+  ns->tb_sym_root = NULL;
   ns->finalizers = NULL;
   ns->default_access = ACCESS_UNKNOWN;
   ns->parent = parent;
 
   for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
-    ns->operator_access[in] = ACCESS_UNKNOWN;
+    {
+      ns->operator_access[in] = ACCESS_UNKNOWN;
+      ns->tb_op[in] = NULL;
+    }
 
   /* Initialize default implicit types.  */
   for (i = 'a'; i <= 'z'; i++)
@@ -2252,7 +2317,6 @@ gfc_new_symtree (gfc_symtree **root, const char *name)
 
   st = XCNEW (gfc_symtree);
   st->name = gfc_get_string (name);
-  st->typebound = NULL;
 
   gfc_insert_bbt (root, st, compare_symtree);
   return st;
@@ -2430,6 +2494,19 @@ ambiguous_symbol (const char *name, gfc_symtree *st)
 }
 
 
+/* If we're in a SELECT TYPE block, check if the variable 'st' matches any
+   selector on the stack. If yes, replace it by the corresponding temporary.  */
+
+static void
+select_type_insert_tmp (gfc_symtree **st)
+{
+  gfc_select_type_stack *stack = select_type_stack;
+  for (; stack; stack = stack->prev)
+    if ((*st)->n.sym == stack->selector && stack->tmp)
+      *st = stack->tmp;
+}
+
+
 /* Search for a symtree starting in the current namespace, resorting to
    any parent namespaces if requested by a nonzero parent_flag.
    Returns nonzero if the name is ambiguous.  */
@@ -2448,6 +2525,8 @@ gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
       st = gfc_find_symtree (ns->sym_root, name);
       if (st != NULL)
 	{
+	  select_type_insert_tmp (&st);
+
 	  *result = st;
 	  /* Ambiguous generic interfaces are permitted, as long
 	     as the specific interfaces are different.  */
@@ -2521,7 +2600,8 @@ save_symbol_data (gfc_symbol *sym)
    So if the return value is nonzero, then an error was issued.  */
 
 int
-gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result)
+gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
+		  bool allow_subroutine)
 {
   gfc_symtree *st;
   gfc_symbol *p;
@@ -2562,11 +2642,10 @@ gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result)
 	}
 
       p = st->n.sym;
-
       if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
-	    && !(ns->proc_name
-		   && ns->proc_name->attr.if_source == IFSRC_IFBODY
-		   && (ns->has_import_set || p->attr.imported)))
+	  && !(allow_subroutine && p->attr.subroutine)
+	  && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
+	  && (ns->has_import_set || p->attr.imported)))
 	{
 	  /* Symbol is from another namespace.  */
 	  gfc_error ("Symbol '%s' at %C has already been host associated",
@@ -2591,7 +2670,7 @@ gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
   gfc_symtree *st;
   int i;
 
-  i = gfc_get_sym_tree (name, ns, &st);
+  i = gfc_get_sym_tree (name, ns, &st, false);
   if (i != 0)
     return i;
 
@@ -2613,6 +2692,7 @@ gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
   int i;
 
   i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
+
   if (st != NULL)
     {
       save_symbol_data (st->n.sym);
@@ -2633,7 +2713,7 @@ gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
 	}
     }
 
-  return gfc_get_sym_tree (name, gfc_current_ns, result);
+  return gfc_get_sym_tree (name, gfc_current_ns, result, false);
 }
 
 
@@ -2685,6 +2765,7 @@ void
 gfc_undo_symbols (void)
 {
   gfc_symbol *p, *q, *old;
+  tentative_tbp *tbp, *tbq;
 
   for (p = changed_syms; p; p = q)
     {
@@ -2783,6 +2864,14 @@ gfc_undo_symbols (void)
     }
 
   changed_syms = NULL;
+
+  for (tbp = tentative_tbp_list; tbp; tbp = tbq)
+    {
+      tbq = tbp->next;
+      /* Procedure is already marked `error' by default.  */
+      gfc_free (tbp);
+    }
+  tentative_tbp_list = NULL;
 }
 
 
@@ -2820,6 +2909,7 @@ void
 gfc_commit_symbols (void)
 {
   gfc_symbol *p, *q;
+  tentative_tbp *tbp, *tbq;
 
   for (p = changed_syms; p; p = q)
     {
@@ -2830,6 +2920,14 @@ gfc_commit_symbols (void)
       free_old_symbol (p);
     }
   changed_syms = NULL;
+
+  for (tbp = tentative_tbp_list; tbp; tbp = tbq)
+    {
+      tbq = tbp->next;
+      tbp->proc->error = 0;
+      gfc_free (tbp);
+    }
+  tentative_tbp_list = NULL;
 }
 
 
@@ -2861,6 +2959,24 @@ gfc_commit_symbol (gfc_symbol *sym)
 }
 
 
+/* Recursively free trees containing type-bound procedures.  */
+
+static void
+free_tb_tree (gfc_symtree *t)
+{
+  if (t == NULL)
+    return;
+
+  free_tb_tree (t->left);
+  free_tb_tree (t->right);
+
+  /* TODO: Free type-bound procedure structs themselves; probably needs some
+     sort of ref-counting mechanism.  */
+
+  gfc_free (t);
+}
+
+
 /* Recursive function that deletes an entire tree and all the common
    head structures it points to.  */
 
@@ -2883,7 +2999,6 @@ free_common_tree (gfc_symtree * common_tree)
 static void
 free_uop_tree (gfc_symtree *uop_tree)
 {
-
   if (uop_tree == NULL)
     return;
 
@@ -2891,7 +3006,6 @@ free_uop_tree (gfc_symtree *uop_tree)
   free_uop_tree (uop_tree->right);
 
   gfc_free_interface (uop_tree->n.uop->op);
-
   gfc_free (uop_tree->n.uop);
   gfc_free (uop_tree);
 }
@@ -2938,7 +3052,7 @@ free_sym_tree (gfc_symtree *sym_tree)
 
 /* Free the derived type list.  */
 
-static void
+void
 gfc_free_dt_list (void)
 {
   gfc_dt_list *dt, *n;
@@ -3008,6 +3122,33 @@ gfc_free_finalizer_list (gfc_finalizer* list)
 }
 
 
+/* Create a new gfc_charlen structure and add it to a namespace.
+   If 'old_cl' is given, the newly created charlen will be a copy of it.  */
+
+gfc_charlen*
+gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
+{
+  gfc_charlen *cl;
+  cl = gfc_get_charlen ();
+
+  /* Put into namespace.  */
+  cl->next = ns->cl_list;
+  ns->cl_list = cl;
+
+  /* Copy old_cl.  */
+  if (old_cl)
+    {
+      cl->length = gfc_copy_expr (old_cl->length);
+      cl->length_from_typespec = old_cl->length_from_typespec;
+      cl->backend_decl = old_cl->backend_decl;
+      cl->passed_length = old_cl->passed_length;
+      cl->resolved = old_cl->resolved;
+    }
+
+  return cl;
+}
+
+
 /* Free the charlen list from cl to end (end is not freed). 
    Free the whole list if end is NULL.  */
 
@@ -3034,7 +3175,7 @@ void
 gfc_free_namespace (gfc_namespace *ns)
 {
   gfc_namespace *p, *q;
-  gfc_intrinsic_op i;
+  int i;
 
   if (ns == NULL)
     return;
@@ -3049,6 +3190,8 @@ gfc_free_namespace (gfc_namespace *ns)
   free_sym_tree (ns->sym_root);
   free_uop_tree (ns->uop_root);
   free_common_tree (ns->common_root);
+  free_tb_tree (ns->tb_sym_root);
+  free_tb_tree (ns->tb_uop_root);
   gfc_free_finalizer_list (ns->finalizers);
   gfc_free_charlen (ns->cl_list, NULL);
   free_st_labels (ns->st_labels);
@@ -3180,8 +3323,8 @@ gfc_is_var_automatic (gfc_symbol *sym)
     return true;
   /* Check for non-constant length character variables.  */
   if (sym->ts.type == BT_CHARACTER
-      && sym->ts.cl
-      && !gfc_is_constant_expr (sym->ts.cl->length))
+      && sym->ts.u.cl
+      && !gfc_is_constant_expr (sym->ts.u.cl->length))
     return true;
   return false;
 }
@@ -3375,6 +3518,15 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym)
           retval = FAILURE;
         }
 
+      if (curr_comp->attr.proc_pointer != 0)
+	{
+	  gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
+		     " of the BIND(C) derived type '%s' at %L", curr_comp->name,
+		     &curr_comp->loc, derived_sym->name,
+		     &derived_sym->declared_at);
+          retval = FAILURE;
+        }
+
       /* The components cannot be allocatable.
          J3/04-007, Section 15.2.3, C1505.	*/
       if (curr_comp->attr.allocatable != 0)
@@ -3389,14 +3541,14 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym)
       
       /* BIND(C) derived types must have interoperable components.  */
       if (curr_comp->ts.type == BT_DERIVED
-	  && curr_comp->ts.derived->ts.is_iso_c != 1 
-          && curr_comp->ts.derived != derived_sym)
+	  && curr_comp->ts.u.derived->ts.is_iso_c != 1 
+          && curr_comp->ts.u.derived != derived_sym)
         {
           /* This should be allowed; the draft says a derived-type can not
              have type parameters if it is has the BIND attribute.  Type
              parameters seem to be for making parameterized derived types.
              There's no need to verify the type if it is c_ptr/c_funptr.  */
-          retval = verify_bind_c_derived_type (curr_comp->ts.derived);
+          retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
 	}
       else
 	{
@@ -3495,10 +3647,10 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
   /* The c_ptr and c_funptr derived types will provide the
      definition for c_null_ptr and c_null_funptr, respectively.  */
   if (ptr_id == ISOCBINDING_NULL_PTR)
-    tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
+    tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
   else
-    tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
-  if (tmp_sym->ts.derived == NULL)
+    tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+  if (tmp_sym->ts.u.derived == NULL)
     {
       /* This can occur if the user forgot to declare c_ptr or
          c_funptr and they're trying to use one of the procedures
@@ -3511,7 +3663,7 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
 				   ? "_gfortran_iso_c_binding_c_ptr"
 				   : "_gfortran_iso_c_binding_c_funptr"));
 
-      tmp_sym->ts.derived =
+      tmp_sym->ts.u.derived =
         get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
                               ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
     }
@@ -3532,11 +3684,11 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
   tmp_sym->value = gfc_get_expr ();
   tmp_sym->value->expr_type = EXPR_STRUCTURE;
   tmp_sym->value->ts.type = BT_DERIVED;
-  tmp_sym->value->ts.derived = tmp_sym->ts.derived;
-  /* Create a constructor with no expr, that way we can recognize if the user
-     tries to call the structure constructor for one of the iso_c_binding
-     derived types during resolution (resolve_structure_cons).  */
+  tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
   tmp_sym->value->value.constructor = gfc_get_constructor ();
+  tmp_sym->value->value.constructor->expr = gfc_get_expr ();
+  tmp_sym->value->value.constructor->expr->expr_type = EXPR_NULL;
+  tmp_sym->value->value.constructor->expr->ts.is_iso_c = 1;
   /* Must declare c_null_ptr and c_null_funptr as having the
      PARAMETER attribute so they can be used in init expressions.  */
   tmp_sym->attr.flavor = FL_PARAMETER;
@@ -3598,7 +3750,7 @@ gen_cptr_param (gfc_formal_arglist **head,
     c_ptr_in = "gfc_cptr__";
   else
     c_ptr_in = c_ptr_name;
-  gfc_get_sym_tree (c_ptr_in, ns, &param_symtree);
+  gfc_get_sym_tree (c_ptr_in, ns, &param_symtree, false);
   if (param_symtree != NULL)
     param_sym = param_symtree->n.sym;
   else
@@ -3636,7 +3788,7 @@ gen_cptr_param (gfc_formal_arglist **head,
       gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
     }
 
-  param_sym->ts.derived = c_ptr_sym;
+  param_sym->ts.u.derived = c_ptr_sym;
   param_sym->module = gfc_get_string (module_name);
 
   /* Make new formal arg.  */
@@ -3664,7 +3816,7 @@ gen_fptr_param (gfc_formal_arglist **head,
   if (f_ptr_name != NULL)
     f_ptr_out = f_ptr_name;
 
-  gfc_get_sym_tree (f_ptr_out, ns, &param_symtree);
+  gfc_get_sym_tree (f_ptr_out, ns, &param_symtree, false);
   if (param_symtree != NULL)
     param_sym = param_symtree->n.sym;
   else
@@ -3711,7 +3863,7 @@ gen_shape_param (gfc_formal_arglist **head,
   if (shape_param_name != NULL)
     shape_param = shape_param_name;
 
-  gfc_get_sym_tree (shape_param, ns, &param_symtree);
+  gfc_get_sym_tree (shape_param, ns, &param_symtree, false);
   if (param_symtree != NULL)
     param_sym = param_symtree->n.sym;
   else
@@ -3761,6 +3913,7 @@ gen_shape_param (gfc_formal_arglist **head,
   add_formal_arg (head, tail, formal_arg, param_sym);
 }
 
+
 /* Add a procedure interface to the given symbol (i.e., store a
    reference to the list of formal arguments).  */
 
@@ -3773,6 +3926,7 @@ add_proc_interface (gfc_symbol *sym, ifsrc source,
   sym->attr.if_source = source;
 }
 
+
 /* Copy the formal args from an existing symbol, src, into a new
    symbol, dest.  New formal args are created, and the description of
    each arg is set according to the existing ones.  This function is
@@ -3781,7 +3935,7 @@ add_proc_interface (gfc_symbol *sym, ifsrc source,
    args based on the args of a given named interface.  */
 
 void
-copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
+gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
 {
   gfc_formal_arglist *head = NULL;
   gfc_formal_arglist *tail = NULL;
@@ -3805,7 +3959,7 @@ copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
       formal_arg->sym->attr = curr_arg->sym->attr;
       formal_arg->sym->ts = curr_arg->sym->ts;
       formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
-      copy_formal_args (formal_arg->sym, curr_arg->sym);
+      gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
 
       /* If this isn't the first arg, set up the next ptr.  For the
         last arg built, the formal_arg->next will never get set to
@@ -3832,6 +3986,118 @@ copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
   gfc_current_ns = parent_ns;
 }
 
+
+void
+gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
+{
+  gfc_formal_arglist *head = NULL;
+  gfc_formal_arglist *tail = NULL;
+  gfc_formal_arglist *formal_arg = NULL;
+  gfc_intrinsic_arg *curr_arg = NULL;
+  gfc_formal_arglist *formal_prev = NULL;
+  /* Save current namespace so we can change it for formal args.  */
+  gfc_namespace *parent_ns = gfc_current_ns;
+
+  /* Create a new namespace, which will be the formal ns (namespace
+     of the formal args).  */
+  gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+  gfc_current_ns->proc_name = dest;
+
+  for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+    {
+      formal_arg = gfc_get_formal_arglist ();
+      gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
+
+      /* May need to copy more info for the symbol.  */
+      formal_arg->sym->ts = curr_arg->ts;
+      formal_arg->sym->attr.optional = curr_arg->optional;
+      formal_arg->sym->attr.intent = curr_arg->intent;
+      formal_arg->sym->attr.flavor = FL_VARIABLE;
+      formal_arg->sym->attr.dummy = 1;
+
+      if (formal_arg->sym->ts.type == BT_CHARACTER)
+	formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+
+      /* If this isn't the first arg, set up the next ptr.  For the
+        last arg built, the formal_arg->next will never get set to
+        anything other than NULL.  */
+      if (formal_prev != NULL)
+	formal_prev->next = formal_arg;
+      else
+	formal_arg->next = NULL;
+
+      formal_prev = formal_arg;
+
+      /* Add arg to list of formal args.  */
+      add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+    }
+
+  /* Add the interface to the symbol.  */
+  add_proc_interface (dest, IFSRC_DECL, head);
+
+  /* Store the formal namespace information.  */
+  if (dest->formal != NULL)
+    /* The current ns should be that for the dest proc.  */
+    dest->formal_ns = gfc_current_ns;
+  /* Restore the current namespace to what it was on entry.  */
+  gfc_current_ns = parent_ns;
+}
+
+
+void
+gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src)
+{
+  gfc_formal_arglist *head = NULL;
+  gfc_formal_arglist *tail = NULL;
+  gfc_formal_arglist *formal_arg = NULL;
+  gfc_formal_arglist *curr_arg = NULL;
+  gfc_formal_arglist *formal_prev = NULL;
+  /* Save current namespace so we can change it for formal args.  */
+  gfc_namespace *parent_ns = gfc_current_ns;
+
+  /* Create a new namespace, which will be the formal ns (namespace
+     of the formal args).  */
+  gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+  /* TODO: gfc_current_ns->proc_name = dest;*/
+
+  for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+    {
+      formal_arg = gfc_get_formal_arglist ();
+      gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
+
+      /* May need to copy more info for the symbol.  */
+      formal_arg->sym->attr = curr_arg->sym->attr;
+      formal_arg->sym->ts = curr_arg->sym->ts;
+      formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
+      gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
+
+      /* If this isn't the first arg, set up the next ptr.  For the
+        last arg built, the formal_arg->next will never get set to
+        anything other than NULL.  */
+      if (formal_prev != NULL)
+	formal_prev->next = formal_arg;
+      else
+	formal_arg->next = NULL;
+
+      formal_prev = formal_arg;
+
+      /* Add arg to list of formal args.  */
+      add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+    }
+
+  /* Add the interface to the symbol.  */
+  dest->formal = head;
+  dest->attr.if_source = IFSRC_DECL;
+
+  /* Store the formal namespace information.  */
+  if (dest->formal != NULL)
+    /* The current ns should be that for the dest proc.  */
+    dest->formal_ns = gfc_current_ns;
+  /* Restore the current namespace to what it was on entry.  */
+  gfc_current_ns = parent_ns;
+}
+
+
 /* Builds the parameter list for the iso_c_binding procedure
    c_f_pointer or c_f_procpointer.  The old_sym typically refers to a
    generic version of either the c_f_pointer or c_f_procpointer
@@ -3949,7 +4215,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
     return;
 
   /* Create the sym tree in the current ns.  */
-  gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
+  gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
   if (tmp_symtree)
     tmp_sym = tmp_symtree->n.sym;
   else
@@ -4013,8 +4279,8 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 	tmp_sym->value->value.character.string[0]
 	  = (gfc_char_t) c_interop_kinds_table[s].value;
 	tmp_sym->value->value.character.string[1] = '\0';
-	tmp_sym->ts.cl = gfc_get_charlen ();
-	tmp_sym->ts.cl->length = gfc_int_expr (1);
+	tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+	tmp_sym->ts.u.cl->length = gfc_int_expr (1);
 
 	/* May not need this in both attr and ts, but do need in
 	   attr for writing module file.  */
@@ -4058,7 +4324,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 
 	tmp_sym->attr.referenced = 1;
 
-	tmp_sym->ts.derived = tmp_sym;
+	tmp_sym->ts.u.derived = tmp_sym;
 
         /* Add the symbol created for the derived type to the current ns.  */
         dt_list_ptr = &(gfc_derived_types);
@@ -4143,13 +4409,13 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
                   C address of.  */
 		tmp_sym->ts.type = BT_DERIVED;
                 if (s == ISOCBINDING_LOC)
-                  tmp_sym->ts.derived =
+                  tmp_sym->ts.u.derived =
                     get_iso_c_binding_dt (ISOCBINDING_PTR);
                 else
-                  tmp_sym->ts.derived =
+                  tmp_sym->ts.u.derived =
                     get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
 
-                if (tmp_sym->ts.derived == NULL)
+                if (tmp_sym->ts.u.derived == NULL)
                   {
                     /* Create the necessary derived type so we can continue
                        processing the file.  */
@@ -4159,7 +4425,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 		       (const char *)(s == ISOCBINDING_FUNLOC
                                 ? "_gfortran_iso_c_binding_c_funptr"
 				: "_gfortran_iso_c_binding_c_ptr"));
-                    tmp_sym->ts.derived =
+                    tmp_sym->ts.u.derived =
                       get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
                                             ? ISOCBINDING_FUNPTR
                                             : ISOCBINDING_PTR);
@@ -4237,6 +4503,8 @@ get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
   new_symtree->n.sym->module = gfc_get_string (old_sym->module);
   new_symtree->n.sym->from_intmod = old_sym->from_intmod;
   new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
+  if (old_sym->attr.function)
+    new_symtree->n.sym->result = new_symtree->n.sym;
   /* Build the formal arg list.  */
   build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
 
@@ -4280,6 +4548,27 @@ gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
 }
 
 
+/* Construct a typebound-procedure structure.  Those are stored in a tentative
+   list and marked `error' until symbols are committed.  */
+
+gfc_typebound_proc*
+gfc_get_typebound_proc (void)
+{
+  gfc_typebound_proc *result;
+  tentative_tbp *list_node;
+
+  result = XCNEW (gfc_typebound_proc);
+  result->error = 1;
+
+  list_node = XCNEW (tentative_tbp);
+  list_node->next = tentative_tbp_list;
+  list_node->proc = result;
+  tentative_tbp_list = list_node;
+
+  return result;
+}
+
+
 /* Get the super-type of a given derived type.  */
 
 gfc_symbol*
@@ -4290,38 +4579,383 @@ gfc_get_derived_super_type (gfc_symbol* derived)
 
   gcc_assert (derived->components);
   gcc_assert (derived->components->ts.type == BT_DERIVED);
-  gcc_assert (derived->components->ts.derived);
+  gcc_assert (derived->components->ts.u.derived);
+
+  return derived->components->ts.u.derived;
+}
+
+
+/* Get the ultimate super-type of a given derived type.  */
+
+gfc_symbol*
+gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
+{
+  if (!derived->attr.extension)
+    return NULL;
+
+  derived = gfc_get_derived_super_type (derived);
+
+  if (derived->attr.extension)
+    return gfc_get_ultimate_derived_super_type (derived);
+  else
+    return derived;
+}
+
 
-  return derived->components->ts.derived;
+/* Check if a derived type t2 is an extension of (or equal to) a type t1.  */
+
+bool
+gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
+{
+  while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
+    t2 = gfc_get_derived_super_type (t2);
+  return gfc_compare_derived_types (t1, t2);
 }
 
 
-/* Find a type-bound procedure by name for a derived-type (looking recursively
-   through the super-types).  */
+/* Check if two typespecs are type compatible (F03:5.1.1.2):
+   If ts1 is nonpolymorphic, ts2 must be the same type.
+   If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1.  */
+
+bool
+gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
+{
+  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)
+    {
+      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 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.class_pointer = attr->pointer;
+      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->attr.access = ACCESS_PRIVATE;
+	  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);
+	      vtype->attr.access = ACCESS_PRIVATE;
+
+	      /* 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;
+}
+
+
+/* General worker function to find either a type-bound procedure or a
+   type-bound user operator.  */
+
+static gfc_symtree*
+find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
+			 const char* name, bool noaccess, bool uop,
+			 locus* where)
+{
+  gfc_symtree* res;
+  gfc_symtree* root;
+
+  /* Set correct symbol-root.  */
+  gcc_assert (derived->f2k_derived);
+  root = (uop ? derived->f2k_derived->tb_uop_root
+	      : derived->f2k_derived->tb_sym_root);
+
+  /* Set default to failure.  */
+  if (t)
+    *t = FAILURE;
+
+  /* Try to find it in the current type's namespace.  */
+  res = gfc_find_symtree (root, name);
+  if (res && res->n.tb && !res->n.tb->error)
+    {
+      /* We found one.  */
+      if (t)
+	*t = SUCCESS;
+
+      if (!noaccess && derived->attr.use_assoc
+	  && res->n.tb->access == ACCESS_PRIVATE)
+	{
+	  if (where)
+	    gfc_error ("'%s' of '%s' is PRIVATE at %L",
+		       name, derived->name, where);
+	  if (t)
+	    *t = FAILURE;
+	}
+
+      return res;
+    }
+
+  /* Otherwise, recurse on parent type if derived is an extension.  */
+  if (derived->attr.extension)
+    {
+      gfc_symbol* super_type;
+      super_type = gfc_get_derived_super_type (derived);
+      gcc_assert (super_type);
+
+      return find_typebound_proc_uop (super_type, t, name,
+				      noaccess, uop, where);
+    }
+
+  /* Nothing found.  */
+  return NULL;
+}
+
+
+/* Find a type-bound procedure or user operator by name for a derived-type
+   (looking recursively through the super-types).  */
 
 gfc_symtree*
 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
-			 const char* name, bool noaccess)
+			 const char* name, bool noaccess, locus* where)
 {
-  gfc_symtree* res;
+  return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
+}
+
+gfc_symtree*
+gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
+			    const char* name, bool noaccess, locus* where)
+{
+  return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
+}
+
+
+/* Find a type-bound intrinsic operator looking recursively through the
+   super-type hierarchy.  */
+
+gfc_typebound_proc*
+gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
+				 gfc_intrinsic_op op, bool noaccess,
+				 locus* where)
+{
+  gfc_typebound_proc* res;
 
   /* Set default to failure.  */
   if (t)
     *t = FAILURE;
 
   /* Try to find it in the current type's namespace.  */
-  gcc_assert (derived->f2k_derived);
-  res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
-  if (res && res->typebound)
+  if (derived->f2k_derived)
+    res = derived->f2k_derived->tb_op[op];
+  else  
+    res = NULL;
+
+  /* Check access.  */
+  if (res && !res->error)
     {
       /* We found one.  */
       if (t)
 	*t = SUCCESS;
 
       if (!noaccess && derived->attr.use_assoc
-	  && res->typebound->access == ACCESS_PRIVATE)
+	  && res->access == ACCESS_PRIVATE)
 	{
-	  gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
+	  if (where)
+	    gfc_error ("'%s' of '%s' is PRIVATE at %L",
+		       gfc_op2string (op), derived->name, where);
 	  if (t)
 	    *t = FAILURE;
 	}
@@ -4335,9 +4969,32 @@ gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
       gfc_symbol* super_type;
       super_type = gfc_get_derived_super_type (derived);
       gcc_assert (super_type);
-      return gfc_find_typebound_proc (super_type, t, name, noaccess);
+
+      return gfc_find_typebound_intrinsic_op (super_type, t, op,
+					      noaccess, where);
     }
 
   /* Nothing found.  */
   return NULL;
 }
+
+
+/* Get a typebound-procedure symtree or create and insert it if not yet
+   present.  This is like a very simplified version of gfc_get_sym_tree for
+   tbp-symtrees rather than regular ones.  */
+
+gfc_symtree*
+gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
+{
+  gfc_symtree *result;
+
+  result = gfc_find_symtree (*root, name);
+  if (!result)
+    {
+      result = gfc_new_symtree (root, name);
+      gcc_assert (result);
+      result->n.tb = NULL;
+    }
+
+  return result;
+}