2008-08-31 Daniel Kraft <d@domob.eu>

	* gfortran.h (enum gfc_statement): New entry `ST_GENERIC'.
	(struct gfc_tbp_generic): New type.
	(struct gfc_typebound_proc): Removed `target' and added union with
	`specific' and `generic' members; new members `overridden',
	`subroutine', `function' and `is_generic'.
	(struct gfc_expr): New members `derived' and `name' in compcall union
	member and changed type of `tbp' to gfc_typebound_proc.
	(gfc_compare_interfaces), (gfc_compare_actual_formal): Made public.
	* match.h (gfc_typebound_default_access): New global.
	(gfc_match_generic): New method.
	* decl.c (gfc_match_generic): New method.
	(match_binding_attributes): New argument `generic' and handle it.
	(match_procedure_in_type): Mark matched binding as non-generic.
	* interface.c (gfc_compare_interfaces): Made public.
	(gfc_compare_actual_formal): Ditto.
	(check_interface_1), (compare_parameter): Use new public names.
	(gfc_procedure_use), (gfc_search_interface): Ditto.
	* match.c (match_typebound_call): Set base-symbol referenced.
	* module.c (binding_generic): New global array.
	(current_f2k_derived): New global.
	(mio_typebound_proc): Handle IO of GENERIC bindings.
	(mio_f2k_derived): Record current f2k-namespace in current_f2k_derived.
	* parse.c (decode_statement): Handle GENERIC statement.
	(gfc_ascii_statement): Ditto.
	(typebound_default_access), (set_typebound_default_access): Removed.
	(gfc_typebound_default_access): New global.
	(parse_derived_contains): New default-access implementation and handle
	GENERIC statements encountered.
	* primary.c (gfc_match_varspec): Adapted to new gfc_typebound_proc
	structure and removed check for SUBROUTINE/FUNCTION from here.
	* resolve.c (extract_compcall_passed_object): New method.
	(update_compcall_arglist): Use it.
	(resolve_typebound_static): Adapted to new gfc_typebound_proc structure.
	(resolve_typebound_generic_call): New method.
	(resolve_typebound_call): Check target is a SUBROUTINE and handle calls
	to GENERIC bindings.
	(resolve_compcall): Ditto (check for target being FUNCTION).
	(check_typebound_override): Handle GENERIC bindings.
	(check_generic_tbp_ambiguity), (resolve_typebound_generic): New methods.
	(resolve_typebound_procedure): Handle GENERIC bindings and set new
	attributes subroutine, function and overridden in gfc_typebound_proc.
	(resolve_fl_derived): Ensure extended type is resolved before the
	extending one is.
	* st.c (gfc_free_statement): Fix bug with free'ing EXEC_COMPCALL's.
	* symbol.c (gfc_find_typebound_proc): Adapt for GENERIC changes.

2008-08-31  Daniel Kraft  <d@domob.eu>

	* gfortran.dg/typebound_generic_1.f03: New test.
	* gfortran.dg/typebound_generic_2.f03: New test.
	* gfortran.dg/typebound_generic_3.f03: New test.



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

16 files changed, 938 insertions, 141 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6a88c38e724..13ddef193dc 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,51 @@
+2008-08-31  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h (enum gfc_statement): New entry `ST_GENERIC'.
+	(struct gfc_tbp_generic): New type.
+	(struct gfc_typebound_proc): Removed `target' and added union with
+	`specific' and `generic' members; new members `overridden',
+	`subroutine', `function' and `is_generic'.
+	(struct gfc_expr): New members `derived' and `name' in compcall union
+	member and changed type of `tbp' to gfc_typebound_proc.
+	(gfc_compare_interfaces), (gfc_compare_actual_formal): Made public.
+	* match.h (gfc_typebound_default_access): New global.
+	(gfc_match_generic): New method.
+	* decl.c (gfc_match_generic): New method.
+	(match_binding_attributes): New argument `generic' and handle it.
+	(match_procedure_in_type): Mark matched binding as non-generic.
+	* interface.c (gfc_compare_interfaces): Made public.
+	(gfc_compare_actual_formal): Ditto.
+	(check_interface_1), (compare_parameter): Use new public names.
+	(gfc_procedure_use), (gfc_search_interface): Ditto.
+	* match.c (match_typebound_call): Set base-symbol referenced.
+	* module.c (binding_generic): New global array.
+	(current_f2k_derived): New global.
+	(mio_typebound_proc): Handle IO of GENERIC bindings.
+	(mio_f2k_derived): Record current f2k-namespace in current_f2k_derived.
+	* parse.c (decode_statement): Handle GENERIC statement.
+	(gfc_ascii_statement): Ditto.
+	(typebound_default_access), (set_typebound_default_access): Removed.
+	(gfc_typebound_default_access): New global.
+	(parse_derived_contains): New default-access implementation and handle
+	GENERIC statements encountered.
+	* primary.c (gfc_match_varspec): Adapted to new gfc_typebound_proc
+	structure and removed check for SUBROUTINE/FUNCTION from here.
+	* resolve.c (extract_compcall_passed_object): New method.
+	(update_compcall_arglist): Use it.
+	(resolve_typebound_static): Adapted to new gfc_typebound_proc structure.
+	(resolve_typebound_generic_call): New method.
+	(resolve_typebound_call): Check target is a SUBROUTINE and handle calls
+	to GENERIC bindings.
+	(resolve_compcall): Ditto (check for target being FUNCTION).
+	(check_typebound_override): Handle GENERIC bindings.
+	(check_generic_tbp_ambiguity), (resolve_typebound_generic): New methods.
+	(resolve_typebound_procedure): Handle GENERIC bindings and set new
+	attributes subroutine, function and overridden in gfc_typebound_proc.
+	(resolve_fl_derived): Ensure extended type is resolved before the
+	extending one is.
+	* st.c (gfc_free_statement): Fix bug with free'ing EXEC_COMPCALL's.
+	* symbol.c (gfc_find_typebound_proc): Adapt for GENERIC changes.
+
 2008-08-29  Jan Hubicka  <jh@suse.cz>
 	
 	* parse.c (parse_interface): Silence uninitialized var warning.
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 2b50ea33be8..b3ec1a66e22 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -6721,7 +6721,7 @@ cleanup:
 /* Match binding attributes.  */
 
 static match
-match_binding_attributes (gfc_typebound_proc* ba)
+match_binding_attributes (gfc_typebound_proc* ba, bool generic)
 {
   bool found_passing = false;
   match m;
@@ -6736,120 +6736,135 @@ match_binding_attributes (gfc_typebound_proc* ba)
 
   /* If we find a comma, we believe there are binding attributes.  */
   if (gfc_match_char (',') == MATCH_NO)
-    return MATCH_NO;
+    {
+      ba->access = gfc_typebound_default_access;
+      return MATCH_NO;
+    }
 
   do
     {
-      /* NOPASS flag.  */
-      m = gfc_match (" nopass");
+      /* Access specifier.  */
+
+      m = gfc_match (" public");
       if (m == MATCH_ERROR)
 	goto error;
       if (m == MATCH_YES)
 	{
-	  if (found_passing)
+	  if (ba->access != ACCESS_UNKNOWN)
 	    {
-	      gfc_error ("Binding attributes already specify passing, illegal"
-			 " NOPASS at %C");
+	      gfc_error ("Duplicate access-specifier at %C");
 	      goto error;
 	    }
 
-	  found_passing = true;
-	  ba->nopass = 1;
+	  ba->access = ACCESS_PUBLIC;
 	  continue;
 	}
 
-      /* NON_OVERRIDABLE flag.  */
-      m = gfc_match (" non_overridable");
+      m = gfc_match (" private");
       if (m == MATCH_ERROR)
 	goto error;
       if (m == MATCH_YES)
 	{
-	  if (ba->non_overridable)
+	  if (ba->access != ACCESS_UNKNOWN)
 	    {
-	      gfc_error ("Duplicate NON_OVERRIDABLE at %C");
+	      gfc_error ("Duplicate access-specifier at %C");
 	      goto error;
 	    }
 
-	  ba->non_overridable = 1;
+	  ba->access = ACCESS_PRIVATE;
 	  continue;
 	}
 
-      /* DEFERRED flag.  */
-      /* TODO: Handle really once implemented.  */
-      m = gfc_match (" deferred");
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_YES)
-	{
-	  gfc_error ("DEFERRED not yet implemented at %C");
-	  goto error;
-	}
-
-      /* PASS possibly including argument.  */
-      m = gfc_match (" pass");
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_YES)
+      /* If inside GENERIC, the following is not allowed.  */
+      if (!generic)
 	{
-	  char arg[GFC_MAX_SYMBOL_LEN + 1];
 
-	  if (found_passing)
+	  /* NOPASS flag.  */
+	  m = gfc_match (" nopass");
+	  if (m == MATCH_ERROR)
+	    goto error;
+	  if (m == MATCH_YES)
 	    {
-	      gfc_error ("Binding attributes already specify passing, illegal"
-			 " PASS at %C");
-	      goto error;
+	      if (found_passing)
+		{
+		  gfc_error ("Binding attributes already specify passing,"
+			     " illegal NOPASS at %C");
+		  goto error;
+		}
+
+	      found_passing = true;
+	      ba->nopass = 1;
+	      continue;
 	    }
 
-	  m = gfc_match (" ( %n )", arg);
+	  /* NON_OVERRIDABLE flag.  */
+	  m = gfc_match (" non_overridable");
 	  if (m == MATCH_ERROR)
 	    goto error;
 	  if (m == MATCH_YES)
-	    ba->pass_arg = xstrdup (arg);
-	  gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
-
-	  found_passing = true;
-	  ba->nopass = 0;
-	  continue;
-	}
+	    {
+	      if (ba->non_overridable)
+		{
+		  gfc_error ("Duplicate NON_OVERRIDABLE at %C");
+		  goto error;
+		}
 
-      /* Access specifier.  */
+	      ba->non_overridable = 1;
+	      continue;
+	    }
 
-      m = gfc_match (" public");
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_YES)
-	{
-	  if (ba->access != ACCESS_UNKNOWN)
+	  /* DEFERRED flag.  */
+	  /* TODO: Handle really once implemented.  */
+	  m = gfc_match (" deferred");
+	  if (m == MATCH_ERROR)
+	    goto error;
+	  if (m == MATCH_YES)
 	    {
-	      gfc_error ("Duplicate access-specifier at %C");
+	      gfc_error ("DEFERRED not yet implemented at %C");
 	      goto error;
 	    }
 
-	  ba->access = ACCESS_PUBLIC;
-	  continue;
-	}
-
-      m = gfc_match (" private");
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_YES)
-	{
-	  if (ba->access != ACCESS_UNKNOWN)
+	  /* PASS possibly including argument.  */
+	  m = gfc_match (" pass");
+	  if (m == MATCH_ERROR)
+	    goto error;
+	  if (m == MATCH_YES)
 	    {
-	      gfc_error ("Duplicate access-specifier at %C");
-	      goto error;
+	      char arg[GFC_MAX_SYMBOL_LEN + 1];
+
+	      if (found_passing)
+		{
+		  gfc_error ("Binding attributes already specify passing,"
+			     " illegal PASS at %C");
+		  goto error;
+		}
+
+	      m = gfc_match (" ( %n )", arg);
+	      if (m == MATCH_ERROR)
+		goto error;
+	      if (m == MATCH_YES)
+		ba->pass_arg = xstrdup (arg);
+	      gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
+
+	      found_passing = true;
+	      ba->nopass = 0;
+	      continue;
 	    }
 
-	  ba->access = ACCESS_PRIVATE;
-	  continue;
 	}
 
       /* Nothing matching found.  */
-      gfc_error ("Expected binding attribute at %C");
+      if (generic)
+	gfc_error ("Expected access-specifier at %C");
+      else
+	gfc_error ("Expected binding attribute at %C");
       goto error;
     }
   while (gfc_match_char (',') == MATCH_YES);
 
+  if (ba->access == ACCESS_UNKNOWN)
+    ba->access = gfc_typebound_default_access;
+
   return MATCH_YES;
 
 error:
@@ -6890,9 +6905,10 @@ match_procedure_in_type (void)
   /* Construct the data structure.  */
   tb = gfc_get_typebound_proc ();
   tb->where = gfc_current_locus;
+  tb->is_generic = 0;
 
   /* Match binding attributes.  */
-  m = match_binding_attributes (tb);
+  m = match_binding_attributes (tb, false);
   if (m == MATCH_ERROR)
     return m;
   seen_attrs = (m == MATCH_YES);
@@ -6962,9 +6978,10 @@ match_procedure_in_type (void)
   gcc_assert (ns);
 
   /* See if we already have a binding with this name in the symtree which would
-     be an error.  */
+     be an error.  If a GENERIC already targetted this binding, it may be
+     already there but then typebound is still NULL.  */
   stree = gfc_find_symtree (ns->sym_root, name);
-  if (stree)
+  if (stree && stree->typebound)
     {
       gfc_error ("There's already a procedure with binding name '%s' for the"
 		 " derived type '%s' at %C", name, block->name);
@@ -6974,14 +6991,146 @@ match_procedure_in_type (void)
   /* Insert it and set attributes.  */
   if (gfc_get_sym_tree (name, ns, &stree))
     return MATCH_ERROR;
-  if (gfc_get_sym_tree (target, gfc_current_ns, &tb->target))
+  if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific))
     return MATCH_ERROR;
+  gfc_set_sym_referenced (tb->u.specific->n.sym);
   stree->typebound = tb;
 
   return MATCH_YES;
 }
 
 
+/* Match a GENERIC procedure binding inside a derived type.  */
+
+match
+gfc_match_generic (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol* block;
+  gfc_typebound_proc tbattr; /* Used for match_binding_attributes.  */
+  gfc_typebound_proc* tb;
+  gfc_symtree* st;
+  gfc_namespace* ns;
+  match m;
+
+  /* Check current state.  */
+  if (gfc_current_state () == COMP_DERIVED)
+    {
+      gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
+      return MATCH_ERROR;
+    }
+  if (gfc_current_state () != COMP_DERIVED_CONTAINS)
+    return MATCH_NO;
+  block = gfc_state_stack->previous->sym;
+  ns = block->f2k_derived;
+  gcc_assert (block && ns);
+
+  /* See if we get an access-specifier.  */
+  m = match_binding_attributes (&tbattr, true);
+  if (m == MATCH_ERROR)
+    goto error;
+
+  /* Now the colons, those are required.  */
+  if (gfc_match (" ::") != MATCH_YES)
+    {
+      gfc_error ("Expected '::' at %C");
+      goto error;
+    }
+
+  /* The binding name and =>.  */
+  m = gfc_match (" %n =>", name);
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+  if (m == MATCH_NO)
+    {
+      gfc_error ("Expected generic name at %C");
+      goto error;
+    }
+
+  /* If there's already something with this name, check that it is another
+     GENERIC and then extend that rather than build a new node.  */
+  st = gfc_find_symtree (ns->sym_root, name);
+  if (st)
+    {
+      if (!st->typebound || !st->typebound->is_generic)
+	{
+	  gfc_error ("There's already a non-generic procedure with binding name"
+		     " '%s' for the derived type '%s' at %C",
+		     name, block->name);
+	  goto error;
+	}
+
+      tb = st->typebound;
+      if (tb->access != tbattr.access)
+	{
+	  gfc_error ("Binding at %C must have the same access as already"
+		     " defined binding '%s'", name);
+	  goto error;
+	}
+    }
+  else
+    {
+      if (gfc_get_sym_tree (name, ns, &st))
+	return MATCH_ERROR;
+
+      st->typebound = tb = gfc_get_typebound_proc ();
+      tb->where = gfc_current_locus;
+      tb->access = tbattr.access;
+      tb->is_generic = 1;
+      tb->u.generic = NULL;
+    }
+
+  /* Now, match all following names as specific targets.  */
+  do
+    {
+      gfc_symtree* target_st;
+      gfc_tbp_generic* target;
+
+      m = gfc_match_name (name);
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_NO)
+	{
+	  gfc_error ("Expected specific binding name at %C");
+	  goto error;
+	}
+
+      if (gfc_get_sym_tree (name, ns, &target_st))
+	goto error;
+
+      /* See if this is a duplicate specification.  */
+      for (target = tb->u.generic; target; target = target->next)
+	if (target_st == target->specific_st)
+	  {
+	    gfc_error ("'%s' already defined as specific binding for the"
+		       " generic '%s' at %C", name, st->n.sym->name);
+	    goto error;
+	  }
+
+      gfc_set_sym_referenced (target_st->n.sym);
+
+      target = gfc_get_tbp_generic ();
+      target->specific_st = target_st;
+      target->specific = NULL;
+      target->next = tb->u.generic;
+      tb->u.generic = target;
+    }
+  while (gfc_match (" ,") == MATCH_YES);
+
+  /* Here should be the end.  */
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      gfc_error ("Junk after GENERIC binding at %C");
+      goto error;
+    }
+
+  return MATCH_YES;
+
+error:
+  return MATCH_ERROR;
+}
+
+
 /* Match a FINAL declaration inside a derived type.  */
 
 match
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index d6443515567..9020029c848 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -229,7 +229,7 @@ typedef enum
   ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
   ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE,
   ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_OMP_TASK, ST_OMP_END_TASK,
-  ST_OMP_TASKWAIT, ST_PROCEDURE,
+  ST_OMP_TASKWAIT, ST_PROCEDURE, ST_GENERIC,
   ST_GET_FCN_CHARACTERISTICS, ST_NONE
 }
 gfc_statement;
@@ -992,15 +992,40 @@ typedef struct
 gfc_user_op;
 
 
+/* A list of specific bindings that are associated with a generic spec.  */
+typedef struct gfc_tbp_generic
+{
+  /* The parser sets specific_st, upon resolution we look for the corresponding
+     gfc_typebound_proc and set specific for further use.  */
+  struct gfc_symtree* specific_st;
+  struct gfc_typebound_proc* specific;
+
+  struct gfc_tbp_generic* next;
+}
+gfc_tbp_generic;
+
+#define gfc_get_tbp_generic() XCNEW (gfc_tbp_generic)
+
+
 /* Data needed for type-bound procedures.  */
-typedef struct
+typedef struct gfc_typebound_proc
 {
-  struct gfc_symtree* target;
-  locus where; /* Where the PROCEDURE definition was.  */
+  locus where; /* Where the PROCEDURE/GENERIC definition was.  */
+
+  union
+  {
+    struct gfc_symtree* specific;
+    gfc_tbp_generic* generic;
+  }
+  u;
 
   gfc_access access;
   char* pass_arg; /* Argument-name for PASS.  NULL if not specified.  */
 
+  /* The overridden type-bound proc (or GENERIC with this name in the
+     parent-type) or NULL if non.  */
+  struct gfc_typebound_proc* overridden;
+
   /* Once resolved, we use the position of pass_arg in the formal arglist of
      the binding-target procedure to identify it.  The first argument has
      number 1 here, the second 2, and so on.  */
@@ -1008,6 +1033,8 @@ typedef struct
 
   unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise).  */
   unsigned non_overridable:1;
+  unsigned is_generic:1;
+  unsigned function:1, subroutine:1;
 }
 gfc_typebound_proc;
 
@@ -1565,7 +1592,9 @@ typedef struct gfc_expr
     struct
     {
       gfc_actual_arglist* actual;
-      gfc_symtree* tbp;
+      gfc_typebound_proc* tbp;
+      gfc_symbol* derived;
+      const char* name;
     }
     compcall;
 
@@ -2472,6 +2501,7 @@ int gfc_is_compile_time_shape (gfc_array_spec *);
 void gfc_free_interface (gfc_interface *);
 int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
 int gfc_compare_types (gfc_typespec *, gfc_typespec *);
+int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int);
 void gfc_check_interfaces (gfc_namespace *);
 void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
 gfc_symbol *gfc_search_interface (gfc_interface *, int,
@@ -2483,6 +2513,8 @@ gfc_try gfc_add_interface (gfc_symbol *);
 gfc_interface *gfc_current_interface_head (void);
 void gfc_set_current_interface_head (gfc_interface *);
 gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*);
+int gfc_compare_actual_formal (gfc_actual_arglist**, gfc_formal_arglist*,
+      			       int, int, locus*);
 
 /* io.c */
 extern gfc_st_label format_asterisk;
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index b03be73accc..9df24ffd33e 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -479,7 +479,6 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
 }
 
 
-static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
 static int compare_intr_interfaces (gfc_symbol *, gfc_symbol *);
 
 /* Given two symbols that are formal arguments, compare their types
@@ -954,8 +953,8 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
    We return nonzero if there exists an actual argument list that
    would be ambiguous between the two interfaces, zero otherwise.  */
 
-static int
-compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
+int
+gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
 {
   gfc_formal_arglist *f1, *f2;
 
@@ -1173,7 +1172,7 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
 	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
 	  continue;
 
-	if (compare_interfaces (p->sym, q->sym, generic_flag))
+	if (gfc_compare_interfaces (p->sym, q->sym, generic_flag))
 	  {
 	    if (referenced)
 	      {
@@ -1460,7 +1459,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	 if (!compare_intr_interfaces (formal, actual->symtree->n.sym))
 	   goto proc_fail;
 	}
-      else if (!compare_interfaces (formal, actual->symtree->n.sym, 0))
+      else if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0))
 	goto proc_fail;
 
       return 1;
@@ -1819,9 +1818,9 @@ has_vector_subscript (gfc_expr *e)
    errors when things don't match instead of just returning the status
    code.  */
 
-static int
-compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
-		       int ranks_must_agree, int is_elemental, locus *where)
+int
+gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
+      			   int ranks_must_agree, int is_elemental, locus *where)
 {
   gfc_actual_arglist **new_arg, *a, *actual, temp;
   gfc_formal_arglist *f;
@@ -2449,8 +2448,8 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
       return;
     }
 
-  if (!compare_actual_formal (ap, sym->formal, 0,
-			      sym->attr.elemental, where))
+  if (!gfc_compare_actual_formal (ap, sym->formal, 0,
+		  		  sym->attr.elemental, where))
     return;
 
   check_intents (sym->formal, *ap);
@@ -2479,7 +2478,7 @@ gfc_search_interface (gfc_interface *intr, int sub_flag,
 
       r = !intr->sym->attr.elemental;
 
-      if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
+      if (gfc_compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
 	{
 	  check_intents (intr->sym->formal, *ap);
 	  if (gfc_option.warn_aliasing)
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 0da70689443..3b9d3d21d71 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2525,6 +2525,7 @@ match_typebound_call (gfc_symtree* varst)
   base->expr_type = EXPR_VARIABLE;
   base->symtree = varst;
   base->where = gfc_current_locus;
+  gfc_set_sym_referenced (varst->n.sym);
   
   m = gfc_match_varspec (base, 0, true);
   if (m == MATCH_NO)
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 02d088e12d2..ff9e8a8d174 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -36,6 +36,9 @@ extern gfc_st_label *gfc_statement_label;
 extern int gfc_matching_procptr_assignment;
 extern bool gfc_matching_prefix;
 
+/* Default access specifier while matching procedure bindings.  */
+extern gfc_access gfc_typebound_default_access;
+
 /****************** All gfc_match* routines *****************/
 
 /* match.c.  */
@@ -141,6 +144,7 @@ match gfc_match_end (gfc_statement *);
 match gfc_match_data_decl (void);
 match gfc_match_formal_arglist (gfc_symbol *, int, int);
 match gfc_match_procedure (void);
+match gfc_match_generic (void);
 match gfc_match_function_decl (void);
 match gfc_match_entry (void);
 match gfc_match_subroutine (void);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 0f504efeded..c92780386f1 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1698,6 +1698,12 @@ static const mstring binding_overriding[] =
     minit ("NON_OVERRIDABLE", 1),
     minit (NULL, -1)
 };
+static const mstring binding_generic[] =
+{
+    minit ("SPECIFIC", 0),
+    minit ("GENERIC", 1),
+    minit (NULL, -1)
+};
 
 
 /* Specialization of mio_name.  */
@@ -3189,6 +3195,8 @@ mio_namespace_ref (gfc_namespace **nsp)
 
 /* Save/restore the f2k_derived namespace of a derived-type symbol.  */
 
+static gfc_namespace* current_f2k_derived;
+
 static void
 mio_typebound_proc (gfc_typebound_proc** proc)
 {
@@ -3202,13 +3210,13 @@ mio_typebound_proc (gfc_typebound_proc** proc)
   gcc_assert (*proc);
 
   mio_lparen ();
-  mio_symtree_ref (&(*proc)->target);
 
   (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
 
   (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
   (*proc)->non_overridable = mio_name ((*proc)->non_overridable,
 				       binding_overriding);
+  (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
 
   if (iomode == IO_INPUT)
     (*proc)->pass_arg = NULL;
@@ -3217,6 +3225,38 @@ mio_typebound_proc (gfc_typebound_proc** proc)
   mio_integer (&flag);
   (*proc)->pass_arg_num = (unsigned) flag;
 
+  if ((*proc)->is_generic)
+    {
+      gfc_tbp_generic* g;
+
+      mio_lparen ();
+
+      if (iomode == IO_OUTPUT)
+	for (g = (*proc)->u.generic; g; g = g->next)
+	  mio_allocated_string (g->specific_st->name);
+      else
+	{
+	  (*proc)->u.generic = NULL;
+	  while (peek_atom () != ATOM_RPAREN)
+	    {
+	      g = gfc_get_tbp_generic ();
+	      g->specific = NULL;
+
+	      require_atom (ATOM_STRING);
+	      gfc_get_sym_tree (atom_string, current_f2k_derived,
+				&g->specific_st);
+	      gfc_free (atom_string);
+
+	      g->next = (*proc)->u.generic;
+	      (*proc)->u.generic = g;
+	    }
+	}
+
+      mio_rparen ();
+    }
+  else
+    mio_symtree_ref (&(*proc)->u.specific);
+
   mio_rparen ();
 }
 
@@ -3260,6 +3300,8 @@ mio_finalizer (gfc_finalizer **f)
 static void
 mio_f2k_derived (gfc_namespace *f2k)
 {
+  current_f2k_derived = f2k;
+
   /* Handle the list of finalizer procedures.  */
   mio_lparen ();
   if (iomode == IO_OUTPUT)
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 9ec376ad066..c5493dff705 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -372,6 +372,7 @@ decode_statement (void)
       break;
 
     case 'g':
+      match ("generic", gfc_match_generic, ST_GENERIC);
       match ("go to", gfc_match_goto, ST_GOTO);
       break;
 
@@ -1195,6 +1196,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_FUNCTION:
       p = "FUNCTION";
       break;
+    case ST_GENERIC:
+      p = "GENERIC";
+      break;
     case ST_GOTO:
       p = "GOTO";
       break;
@@ -1691,21 +1695,10 @@ unexpected_eof (void)
 }
 
 
-/* Set the default access attribute for a typebound procedure; this is used
-   as callback for gfc_traverse_symtree.  */
-
-static gfc_access typebound_default_access;
-
-static void
-set_typebound_default_access (gfc_symtree* stree)
-{
-  if (stree->typebound && stree->typebound->access == ACCESS_UNKNOWN)
-    stree->typebound->access = typebound_default_access;
-}
-
-
 /* Parse the CONTAINS section of a derived type definition.  */
 
+gfc_access gfc_typebound_default_access;
+
 static bool
 parse_derived_contains (void)
 {
@@ -1730,6 +1723,8 @@ parse_derived_contains (void)
   accept_statement (ST_CONTAINS);
   push_state (&s, COMP_DERIVED_CONTAINS, NULL);
 
+  gfc_typebound_default_access = ACCESS_PUBLIC;
+
   to_finish = false;
   while (!to_finish)
     {
@@ -1755,6 +1750,15 @@ parse_derived_contains (void)
 	  seen_comps = true;
 	  break;
 
+	case ST_GENERIC:
+	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003:  GENERIC binding"
+					     " at %C") == FAILURE)
+	    error_flag = true;
+
+	  accept_statement (ST_GENERIC);
+	  seen_comps = true;
+	  break;
+
 	case ST_FINAL:
 	  if (gfc_notify_std (GFC_STD_F2003,
 			      "Fortran 2003:  FINAL procedure declaration"
@@ -1801,6 +1805,7 @@ parse_derived_contains (void)
 	    }
 
 	  accept_statement (ST_PRIVATE);
+	  gfc_typebound_default_access = ACCESS_PRIVATE;
 	  seen_private = true;
 	  break;
 
@@ -1823,12 +1828,6 @@ parse_derived_contains (void)
   pop_state ();
   gcc_assert (gfc_current_state () == COMP_DERIVED);
 
-  /* Walk the parsed type-bound procedures and set ACCESS_UNKNOWN attributes
-     to PUBLIC or PRIVATE depending on seen_private.  */
-  typebound_default_access = (seen_private ? ACCESS_PRIVATE : ACCESS_PUBLIC);
-  gfc_traverse_symtree (gfc_current_block ()->f2k_derived->sym_root,
-			&set_typebound_default_access);
-
   return error_flag;
 }
 
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index c72f430c860..3a72dda8a99 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1709,7 +1709,6 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
   gfc_ref *substring, *tail;
   gfc_component *component;
   gfc_symbol *sym = primary->symtree->n.sym;
-  gfc_symtree *tbp;
   match m;
   bool unknown;
 
@@ -1754,6 +1753,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
   for (;;)
     {
       gfc_try t;
+      gfc_symtree *tbp;
 
       m = gfc_match_name (name);
       if (m == MATCH_NO)
@@ -1772,13 +1772,20 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
 	  gcc_assert (!tail || !tail->next);
 	  gcc_assert (primary->expr_type == EXPR_VARIABLE);
 
-	  tbp_sym = tbp->typebound->target->n.sym;
+	  if (tbp->typebound->is_generic)
+	    tbp_sym = NULL;
+	  else
+	    tbp_sym = tbp->typebound->u.specific->n.sym;
 
 	  primary->expr_type = EXPR_COMPCALL;
-	  primary->value.compcall.tbp = tbp;
-	  primary->ts = tbp_sym->ts;
-
-	  m = gfc_match_actual_arglist (tbp_sym->attr.subroutine,
+	  primary->value.compcall.tbp = tbp->typebound;
+	  primary->value.compcall.derived = sym;
+	  primary->value.compcall.name = tbp->name;
+	  gcc_assert (primary->symtree->n.sym->attr.referenced);
+	  if (tbp_sym)
+	    primary->ts = tbp_sym->ts;
+
+	  m = gfc_match_actual_arglist (tbp->typebound->subroutine,
 					&primary->value.compcall.actual);
 	  if (m == MATCH_ERROR)
 	    return MATCH_ERROR;
@@ -1793,16 +1800,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
 		}
 	    }
 
-	  if (sub_flag && !tbp_sym->attr.subroutine)
-	    {
-	      gfc_error ("'%s' at %C should be a SUBROUTINE", name);
-	      return MATCH_ERROR;
-	    }
-	  if (!sub_flag && !tbp_sym->attr.function)
-	    {
-	      gfc_error ("'%s' at %C should be a FUNCTION", name);
-	      return MATCH_ERROR;
-	    }
+	  gfc_set_sym_referenced (tbp->n.sym);
 
 	  break;
 	}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index c6f59ad6329..440461c82a8 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4306,16 +4306,14 @@ update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos)
 }
 
 
-/* Update the arglist of an EXPR_COMPCALL expression to include the
-   passed-object.  */
+/* Extract the passed-object from an EXPR_COMPCALL (a copy of it).  */
 
-static gfc_try
-update_compcall_arglist (gfc_expr* e)
+static gfc_expr*
+extract_compcall_passed_object (gfc_expr* e)
 {
   gfc_expr* po;
-  gfc_typebound_proc* tbp;
 
-  tbp = e->value.compcall.tbp->typebound;
+  gcc_assert (e->expr_type == EXPR_COMPCALL);
 
   po = gfc_get_expr ();
   po->expr_type = EXPR_VARIABLE;
@@ -4323,7 +4321,27 @@ update_compcall_arglist (gfc_expr* e)
   po->ref = gfc_copy_ref (e->ref);
 
   if (gfc_resolve_expr (po) == FAILURE)
+    return NULL;
+
+  return po;
+}
+
+
+/* Update the arglist of an EXPR_COMPCALL expression to include the
+   passed-object.  */
+
+static gfc_try
+update_compcall_arglist (gfc_expr* e)
+{
+  gfc_expr* po;
+  gfc_typebound_proc* tbp;
+
+  tbp = e->value.compcall.tbp;
+
+  po = extract_compcall_passed_object (e);
+  if (!po)
     return FAILURE;
+
   if (po->rank > 0)
     {
       gfc_error ("Passed-object at %L must be scalar", &e->where);
@@ -4353,13 +4371,14 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
 			  gfc_actual_arglist** actual)
 {
   gcc_assert (e->expr_type == EXPR_COMPCALL);
+  gcc_assert (!e->value.compcall.tbp->is_generic);
 
   /* Update the actual arglist for PASS.  */
   if (update_compcall_arglist (e) == FAILURE)
     return FAILURE;
 
   *actual = e->value.compcall.actual;
-  *target = e->value.compcall.tbp->typebound->target;
+  *target = e->value.compcall.tbp->u.specific;
 
   gfc_free_ref_list (e->ref);
   e->ref = NULL;
@@ -4369,6 +4388,74 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
 }
 
 
+/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
+   which of the specific bindings (if any) matches the arglist and transform
+   the expression into a call of that binding.  */
+
+static gfc_try
+resolve_typebound_generic_call (gfc_expr* e)
+{
+  gfc_typebound_proc* genproc;
+  const char* genname;
+
+  gcc_assert (e->expr_type == EXPR_COMPCALL);
+  genname = e->value.compcall.name;
+  genproc = e->value.compcall.tbp;
+
+  if (!genproc->is_generic)
+    return SUCCESS;
+
+  /* Try the bindings on this type and in the inheritance hierarchy.  */
+  for (; genproc; genproc = genproc->overridden)
+    {
+      gfc_tbp_generic* g;
+
+      gcc_assert (genproc->is_generic);
+      for (g = genproc->u.generic; g; g = g->next)
+	{
+	  gfc_symbol* target;
+	  gfc_actual_arglist* args;
+	  bool matches;
+
+	  gcc_assert (g->specific);
+	  target = g->specific->u.specific->n.sym;
+
+	  /* Get the right arglist by handling PASS/NOPASS.  */
+	  args = gfc_copy_actual_arglist (e->value.compcall.actual);
+	  if (!g->specific->nopass)
+	    {
+	      gfc_expr* po;
+	      po = extract_compcall_passed_object (e);
+	      if (!po)
+		return FAILURE;
+
+	      args = update_arglist_pass (args, po, g->specific->pass_arg_num);
+	    }
+
+	  /* Check if this arglist matches the formal.  */
+	  matches = gfc_compare_actual_formal (&args, target->formal, 1,
+					       target->attr.elemental, NULL);
+
+	  /* Clean up and break out of the loop if we've found it.  */
+	  gfc_free_actual_arglist (args);
+	  if (matches)
+	    {
+	      e->value.compcall.tbp = g->specific;
+	      goto success;
+	    }
+	}
+    }
+
+  /* Nothing matching found!  */
+  gfc_error ("Found no matching specific binding for the call to the GENERIC"
+	     " '%s' at %L", genname, &e->where);
+  return FAILURE;
+
+success:
+  return SUCCESS;
+}
+
+
 /* Resolve a call to a type-bound subroutine.  */
 
 static gfc_try
@@ -4377,6 +4464,17 @@ resolve_typebound_call (gfc_code* c)
   gfc_actual_arglist* newactual;
   gfc_symtree* target;
 
+  /* Check that's really a SUBROUTINE.  */
+  if (!c->expr->value.compcall.tbp->subroutine)
+    {
+      gfc_error ("'%s' at %L should be a SUBROUTINE",
+		 c->expr->value.compcall.name, &c->loc);
+      return FAILURE;
+    }
+
+  if (resolve_typebound_generic_call (c->expr) == FAILURE)
+    return FAILURE;
+
   /* Transform into an ordinary EXEC_CALL for now.  */
 
   if (resolve_typebound_static (c->expr, &target, &newactual) == FAILURE)
@@ -4402,13 +4500,27 @@ resolve_compcall (gfc_expr* e)
   gfc_actual_arglist* newactual;
   gfc_symtree* target;
 
-  /* For now, we simply transform it into a EXPR_FUNCTION call with the same
+  /* Check that's really a FUNCTION.  */
+  if (!e->value.compcall.tbp->function)
+    {
+      gfc_error ("'%s' at %L should be a FUNCTION",
+		 e->value.compcall.name, &e->where);
+      return FAILURE;
+    }
+
+  if (resolve_typebound_generic_call (e) == FAILURE)
+    return FAILURE;
+
+  /* For now, we simply transform it into an EXPR_FUNCTION call with the same
      arglist to the TBP's binding target.  */
 
   if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
     return FAILURE;
 
   e->value.function.actual = newactual;
+  e->value.function.name = e->value.compcall.name;
+  e->value.function.isym = NULL;
+  e->value.function.esym = NULL;
   e->symtree = target;
   e->expr_type = EXPR_FUNCTION;
 
@@ -7771,9 +7883,20 @@ check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
   gfc_formal_arglist* proc_formal;
   gfc_formal_arglist* old_formal;
 
+  /* This procedure should only be called for non-GENERIC proc.  */
+  gcc_assert (!proc->typebound->is_generic);
+
+  /* If the overwritten procedure is GENERIC, this is an error.  */
+  if (old->typebound->is_generic)
+    {
+      gfc_error ("Can't overwrite GENERIC '%s' at %L",
+		 old->name, &proc->typebound->where);
+      return FAILURE;
+    }
+
   where = proc->typebound->where;
-  proc_target = proc->typebound->target->n.sym;
-  old_target = old->typebound->target->n.sym;
+  proc_target = proc->typebound->u.specific->n.sym;
+  old_target = old->typebound->u.specific->n.sym;
 
   /* Check that overridden binding is not NON_OVERRIDABLE.  */
   if (old->typebound->non_overridable)
@@ -7933,6 +8056,161 @@ check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
 }
 
 
+/* Check if two GENERIC targets are ambiguous and emit an error is they are.  */
+
+static gfc_try
+check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
+			     const char* generic_name, locus where)
+{
+  gfc_symbol* sym1;
+  gfc_symbol* sym2;
+
+  gcc_assert (t1->specific && t2->specific);
+  gcc_assert (!t1->specific->is_generic);
+  gcc_assert (!t2->specific->is_generic);
+
+  sym1 = t1->specific->u.specific->n.sym;
+  sym2 = t2->specific->u.specific->n.sym;
+
+  /* Both must be SUBROUTINEs or both must be FUNCTIONs.  */
+  if (sym1->attr.subroutine != sym2->attr.subroutine
+      || sym1->attr.function != sym2->attr.function)
+    {
+      gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
+		 " GENERIC '%s' at %L",
+		 sym1->name, sym2->name, generic_name, &where);
+      return FAILURE;
+    }
+
+  /* Compare the interfaces.  */
+  if (gfc_compare_interfaces (sym1, sym2, 1))
+    {
+      gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
+		 sym1->name, sym2->name, generic_name, &where);
+      return FAILURE;
+    }
+
+  return SUCCESS;
+}
+
+
+/* Resolve a GENERIC procedure binding for a derived type.  */
+
+static gfc_try
+resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
+{
+  gfc_tbp_generic* target;
+  gfc_symtree* first_target;
+  gfc_symbol* super_type;
+  gfc_symtree* inherited;
+  locus where;
+
+  gcc_assert (st->typebound);
+  gcc_assert (st->typebound->is_generic);
+
+  where = st->typebound->where;
+  super_type = gfc_get_derived_super_type (derived);
+
+  /* Find the overridden binding if any.  */
+  st->typebound->overridden = NULL;
+  if (super_type)
+    {
+      gfc_symtree* overridden;
+      overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
+
+      if (overridden && overridden->typebound)
+	st->typebound->overridden = overridden->typebound;
+    }
+
+  /* Try to find the specific bindings for the symtrees in our target-list.  */
+  gcc_assert (st->typebound->u.generic);
+  for (target = st->typebound->u.generic; target; target = target->next)
+    if (!target->specific)
+      {
+	gfc_typebound_proc* overridden_tbp;
+	gfc_tbp_generic* g;
+	const char* target_name;
+
+	target_name = target->specific_st->name;
+
+	/* Defined for this type directly.  */
+	if (target->specific_st->typebound)
+	  {
+	    target->specific = target->specific_st->typebound;
+	    goto specific_found;
+	  }
+
+	/* Look for an inherited specific binding.  */
+	if (super_type)
+	  {
+	    inherited = gfc_find_typebound_proc (super_type, NULL,
+						 target_name, true);
+
+	    if (inherited)
+	      {
+		gcc_assert (inherited->typebound);
+		target->specific = inherited->typebound;
+		goto specific_found;
+	      }
+	  }
+
+	gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
+		   " at %L", target_name, st->name, &where);
+	return FAILURE;
+
+	/* Once we've found the specific binding, check it is not ambiguous with
+	   other specifics already found or inherited for the same GENERIC.  */
+specific_found:
+	gcc_assert (target->specific);
+
+	/* This must really be a specific binding!  */
+	if (target->specific->is_generic)
+	  {
+	    gfc_error ("GENERIC '%s' at %L must target a specific binding,"
+		       " '%s' is GENERIC, too", st->name, &where, target_name);
+	    return FAILURE;
+	  }
+
+	/* Check those already resolved on this type directly.  */
+	for (g = st->typebound->u.generic; g; g = g->next)
+	  if (g != target && g->specific
+	      && check_generic_tbp_ambiguity (target, g, st->name, where)
+		  == FAILURE)
+	    return FAILURE;
+
+	/* Check for ambiguity with inherited specific targets.  */
+	for (overridden_tbp = st->typebound->overridden; overridden_tbp;
+	     overridden_tbp = overridden_tbp->overridden)
+	  if (overridden_tbp->is_generic)
+	    {
+	      for (g = overridden_tbp->u.generic; g; g = g->next)
+		{
+		  gcc_assert (g->specific);
+		  if (check_generic_tbp_ambiguity (target, g,
+						   st->name, where) == FAILURE)
+		    return FAILURE;
+		}
+	    }
+      }
+
+  /* If we attempt to "overwrite" a specific binding, this is an error.  */
+  if (st->typebound->overridden && !st->typebound->overridden->is_generic)
+    {
+      gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
+		 " the same name", st->name, &where);
+      return FAILURE;
+    }
+
+  /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
+     all must have the same attributes here.  */
+  first_target = st->typebound->u.generic->specific->u.specific;
+  st->typebound->subroutine = first_target->n.sym->attr.subroutine;
+  st->typebound->function = first_target->n.sym->attr.function;
+
+  return SUCCESS;
+}
+
+
 /* Resolve the type-bound procedures for a derived type.  */
 
 static gfc_symbol* resolve_bindings_derived;
@@ -7951,9 +8229,19 @@ resolve_typebound_procedure (gfc_symtree* stree)
   if (!stree->typebound)
     return;
 
+  /* If this is a GENERIC binding, use that routine.  */
+  if (stree->typebound->is_generic)
+    {
+      if (resolve_typebound_generic (resolve_bindings_derived, stree)
+	    == FAILURE)
+	goto error;
+      return;
+    }
+
   /* Get the target-procedure to check it.  */
-  gcc_assert (stree->typebound->target);
-  proc = stree->typebound->target->n.sym;
+  gcc_assert (!stree->typebound->is_generic);
+  gcc_assert (stree->typebound->u.specific);
+  proc = stree->typebound->u.specific->n.sym;
   where = stree->typebound->where;
 
   /* Default access should already be resolved from the parser.  */
@@ -7970,14 +8258,17 @@ resolve_typebound_procedure (gfc_symtree* stree)
 		 " an explicit interface at %L", proc->name, &where);
       goto error;
     }
+  stree->typebound->subroutine = proc->attr.subroutine;
+  stree->typebound->function = proc->attr.function;
 
   /* Find the super-type of the current derived type.  We could do this once and
      store in a global if speed is needed, but as long as not I believe this is
      more readable and clearer.  */
   super_type = gfc_get_derived_super_type (resolve_bindings_derived);
 
-  /* If PASS, resolve and check arguments.  */
-  if (!stree->typebound->nopass)
+  /* If PASS, resolve and check arguments if not already resolved / loaded
+     from a .mod file.  */
+  if (!stree->typebound->nopass && stree->typebound->pass_arg_num == 0)
     {
       if (stree->typebound->pass_arg)
 	{
@@ -8039,12 +8330,16 @@ resolve_typebound_procedure (gfc_symtree* stree)
 
   /* If we are extending some type, check that we don't override a procedure
      flagged NON_OVERRIDABLE.  */
+  stree->typebound->overridden = NULL;
   if (super_type)
     {
       gfc_symtree* overridden;
       overridden = gfc_find_typebound_proc (super_type, NULL,
 					    stree->name, true);
 
+      if (overridden && overridden->typebound)
+	stree->typebound->overridden = overridden->typebound;
+
       if (overridden && check_typebound_override (stree, overridden) == FAILURE)
 	goto error;
     }
@@ -8121,6 +8416,10 @@ resolve_fl_derived (gfc_symbol *sym)
 
   super_type = gfc_get_derived_super_type (sym);
 
+  /* Ensure the extended type gets resolved before we do.  */
+  if (super_type && resolve_fl_derived (super_type) == FAILURE)
+    return FAILURE;
+
   for (c = sym->components; c != NULL; c = c->next)
     {
       /* If this type is an extension, see if this component has the same name
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index 81d861aee96..18f1b6d91c4 100644
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -109,7 +109,6 @@ gfc_free_statement (gfc_code *p)
       break;
 
     case EXEC_COMPCALL:
-      gfc_free_expr (p->expr);
     case EXEC_CALL:
     case EXEC_ASSIGN_CALL:
       gfc_free_actual_arglist (p->ext.actual);
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 41e8006809e..5b7db4c75ea 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4279,11 +4279,8 @@ gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
   /* 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)
+  if (res && res->typebound)
     {
-      if (!res->typebound)
-	return NULL;
-
       /* We found one.  */
       if (t)
 	*t = SUCCESS;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 405e0f37084..647714a88b3 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2008-08-31  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.dg/typebound_generic_1.f03: New test.
+	* gfortran.dg/typebound_generic_2.f03: New test.
+	* gfortran.dg/typebound_generic_3.f03: New test.
+
 2008-08-30  Andrew Pinski  <andrew_pinski@playstation.sony.com>
 
 	PR middle-end/36444
diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_1.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_1.f03
new file mode 100644
index 00000000000..08303557cf7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_generic_1.f03
@@ -0,0 +1,95 @@
+! { dg-do compile }
+
+! Type-bound procedures
+! Compiling and errors with GENERIC binding declarations.
+! Bindings with NOPASS.
+
+MODULE m
+  IMPLICIT NONE
+
+  TYPE somet
+  CONTAINS
+    PROCEDURE, NOPASS :: p1 => intf1
+    PROCEDURE, NOPASS :: p1a => intf1a
+    PROCEDURE, NOPASS :: p2 => intf2
+    PROCEDURE, NOPASS :: p3 => intf3
+    PROCEDURE, NOPASS :: subr
+
+    GENERIC :: gen1 => p1a ! { dg-error "are ambiguous" }
+
+    GENERIC, PUBLIC :: gen1 => p1, p2
+    GENERIC :: gen1 => p3 ! Implicitelly PUBLIC.
+    GENERIC, PRIVATE :: gen2 => p1
+
+    GENERIC :: gen2 => p2 ! { dg-error "same access" }
+    GENERIC :: gen1 => p1 ! { dg-error "already defined as specific binding" }
+    GENERIC, PASS :: gen3 => p1 ! { dg-error "Expected access-specifier" }
+    GENERIC :: p1 => p1 ! { dg-error "already a non-generic procedure" }
+    PROCEDURE, NOPASS :: gen1 => intf1 ! { dg-error "already a procedure" }
+    GENERIC :: gen3 => ! { dg-error "specific binding" }
+    GENERIC :: gen4 => p1 x ! { dg-error "Junk after" }
+    GENERIC :: gen4 => p_notthere ! { dg-error "Undefined specific binding" }
+    GENERIC :: gen5 => gen1 ! { dg-error "must target a specific binding" }
+
+    GENERIC :: gensubr => p2 ! { dg-error "mixed FUNCTION/SUBROUTINE" }
+    GENERIC :: gensubr => subr
+
+  END TYPE somet
+
+  TYPE supert
+  CONTAINS
+    PROCEDURE, NOPASS :: p1 => intf1
+    PROCEDURE, NOPASS :: p1a => intf1a
+    PROCEDURE, NOPASS :: p2 => intf2
+    PROCEDURE, NOPASS :: p3 => intf3
+    PROCEDURE, NOPASS :: sub1 => subr
+
+    GENERIC :: gen1 => p1, p2
+    GENERIC :: gen1 => p3
+    GENERIC :: gen2 => p1
+    GENERIC :: gensub => sub1
+  END TYPE supert
+
+  TYPE, EXTENDS(supert) :: t
+  CONTAINS
+    GENERIC :: gen2 => p1a ! { dg-error "are ambiguous" }
+    GENERIC :: gen2 => p3
+    GENERIC :: p1 => p2 ! { dg-error "can't overwrite specific" }
+    GENERIC :: gensub => p2 ! { dg-error "mixed FUNCTION/SUBROUTINE" }
+
+    PROCEDURE, NOPASS :: gen1 => intf1 ! { dg-error "Can't overwrite GENERIC" }
+  END TYPE t
+
+CONTAINS
+
+  INTEGER FUNCTION intf1 (a, b)
+    IMPLICIT NONE
+    INTEGER :: a, b
+    intf1 = 42
+  END FUNCTION intf1
+
+  INTEGER FUNCTION intf1a (a, b)
+    IMPLICIT NONE
+    INTEGER :: a, b
+    intf1a = 42
+  END FUNCTION intf1a
+
+  INTEGER FUNCTION intf2 (a, b)
+    IMPLICIT NONE
+    REAL :: a, b
+    intf2 = 42.0
+  END FUNCTION intf2
+
+  LOGICAL FUNCTION intf3 ()
+    IMPLICIT NONE
+    intf3 = .TRUE.
+  END FUNCTION intf3
+
+  SUBROUTINE subr (x)
+    IMPLICIT NONE
+    INTEGER :: x
+  END SUBROUTINE subr
+
+END MODULE m
+
+! { dg-final { cleanup-modules "m" } }
diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_2.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_2.f03
new file mode 100644
index 00000000000..c18b306b906
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_generic_2.f03
@@ -0,0 +1,64 @@
+! { dg-do compile }
+
+! Type-bound procedures
+! Check for errors with calls to GENERIC bindings and their module IO.
+! Calls with NOPASS.
+
+MODULE m
+  IMPLICIT NONE
+
+  TYPE supert
+  CONTAINS
+    PROCEDURE, NOPASS :: func_int
+    PROCEDURE, NOPASS :: sub_int
+    GENERIC :: func => func_int
+    GENERIC :: sub => sub_int
+  END TYPE supert
+
+  TYPE, EXTENDS(supert) :: t
+  CONTAINS
+    PROCEDURE, NOPASS :: func_real
+    GENERIC :: func => func_real
+  END TYPE t
+
+CONTAINS
+
+  INTEGER FUNCTION func_int (x)
+    IMPLICIT NONE
+    INTEGER :: x
+    func_int = x
+  END FUNCTION func_int
+
+  INTEGER FUNCTION func_real (x)
+    IMPLICIT NONE
+    REAL :: x
+    func_real = INT(x * 4.2)
+  END FUNCTION func_real
+
+  SUBROUTINE sub_int (x)
+    IMPLICIT NONE
+    INTEGER :: x
+  END SUBROUTINE sub_int
+
+END MODULE m
+
+PROGRAM main
+  USE m
+  IMPLICIT NONE
+
+  TYPE(t) :: myobj
+
+  ! These are ok.
+  CALL myobj%sub (1)
+  WRITE (*,*) myobj%func (1)
+  WRITE (*,*) myobj%func (2.5)
+
+  ! These are not.
+  CALL myobj%sub (2.5) ! { dg-error "no matching specific binding" }
+  WRITE (*,*) myobj%func ("hello") ! { dg-error "no matching specific binding" }
+  CALL myobj%func (2.5) ! { dg-error "SUBROUTINE" }
+  WRITE (*,*) myobj%sub (1) ! { dg-error "FUNCTION" }
+
+END PROGRAM main
+
+! { dg-final { cleanup-modules "m" } }
diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_3.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_3.f03
new file mode 100644
index 00000000000..fc565740976
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_generic_3.f03
@@ -0,0 +1,65 @@
+! { dg-do run }
+
+! FIXME: Remove -w once switched to polymorphic passed-object dummy arguments.
+! { dg-options "-w" }
+
+! Type-bound procedures
+! Check calls with GENERIC bindings.
+
+MODULE m
+  IMPLICIT NONE
+
+  TYPE t
+  CONTAINS
+    PROCEDURE, NOPASS :: plain_int
+    PROCEDURE, NOPASS :: plain_real
+    PROCEDURE, PASS(me) :: passed_intint
+    PROCEDURE, PASS(me) :: passed_realreal
+
+    GENERIC :: gensub => plain_int, plain_real, passed_intint, passed_realreal
+  END TYPE t
+
+CONTAINS
+
+  SUBROUTINE plain_int (x)
+    IMPLICIT NONE
+    INTEGER :: x
+    WRITE (*,*) "Plain Integer"
+  END SUBROUTINE plain_int
+
+  SUBROUTINE plain_real (x)
+    IMPLICIT NONE
+    REAL :: x
+    WRITE (*,*) "Plain Real"
+  END SUBROUTINE plain_real
+
+  SUBROUTINE passed_intint (me, x, y)
+    IMPLICIT NONE
+    TYPE(t) :: me
+    INTEGER :: x, y
+    WRITE (*,*) "Passed Integer"
+  END SUBROUTINE passed_intint
+
+  SUBROUTINE passed_realreal (x, me, y)
+    IMPLICIT NONE
+    REAL :: x, y
+    TYPE(t) :: me
+    WRITE (*,*) "Passed Real"
+  END SUBROUTINE passed_realreal
+
+END MODULE m
+
+PROGRAM main
+  USE m
+  IMPLICIT NONE
+
+  TYPE(t) :: myobj
+
+  CALL myobj%gensub (5)
+  CALL myobj%gensub (2.5)
+  CALL myobj%gensub (5, 5)
+  CALL myobj%gensub (2.5, 2.5)
+END PROGRAM main
+
+! { dg-output "Plain Integer(\n|\r\n|\r).*Plain Real(\n|\r\n|\r).*Passed Integer(\n|\r\n|\r).*Passed Real" }
+! { dg-final { cleanup-modules "m" } }