gfortran.h (gfc_typebound_proc): New struct.

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

	* gfortran.h (gfc_typebound_proc):  New struct.
	(gfc_symtree):  New member typebound.
	(gfc_find_typebound_proc):  Prototype for new method.
	(gfc_get_derived_super_type):  Prototype for new method.
	* parse.h (gfc_compile_state):  New state COMP_DERIVED_CONTAINS.
	* decl.c (gfc_match_procedure):  Handle PROCEDURE inside derived-type
	CONTAINS section.
	(gfc_match_end):  Handle new context COMP_DERIVED_CONTAINS.
	(gfc_match_private):  Ditto.
	(match_binding_attributes), (match_procedure_in_type):  New methods.
	(gfc_match_final_decl):  Rewrote to make use of new
	COMP_DERIVED_CONTAINS parser state.
	* parse.c (typebound_default_access):  New global helper variable.
	(set_typebound_default_access):  New callback method.
	(parse_derived_contains):  New method.
	(parse_derived):  Extracted handling of CONTAINS to new parser state
	and parse_derived_contains.
	* resolve.c (resolve_bindings_derived), (resolve_bindings_result):  New.
	(check_typebound_override), (resolve_typebound_procedure):  New methods.
	(resolve_typebound_procedures):  New method.
	(resolve_fl_derived):  Call new resolving method for typebound procs.
	* symbol.c (gfc_new_symtree):  Initialize new member typebound to NULL.
	(gfc_find_typebound_proc):  New method.
	(gfc_get_derived_super_type):  New method.

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

	* gfortran.dg/finalize_5.f03:  Adapted expected error message to changes
	to handling of CONTAINS in derived-type declarations.
	* gfortran.dg/typebound_proc_1.f08:  New test.
	* gfortran.dg/typebound_proc_2.f90:  New test.
	* gfortran.dg/typebound_proc_3.f03:  New test.
	* gfortran.dg/typebound_proc_4.f03:  New test.
	* gfortran.dg/typebound_proc_5.f03:  New test.
	* gfortran.dg/typebound_proc_6.f03:  New test.

From-SVN: r139534

7 files changed, 852 insertions, 66 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e939f96..0916029 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,30 @@
+2008-08-24  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h (gfc_typebound_proc):  New struct.
+	(gfc_symtree):  New member typebound.
+	(gfc_find_typebound_proc):  Prototype for new method.
+	(gfc_get_derived_super_type):  Prototype for new method.
+	* parse.h (gfc_compile_state):  New state COMP_DERIVED_CONTAINS.
+	* decl.c (gfc_match_procedure):  Handle PROCEDURE inside derived-type
+	CONTAINS section.
+	(gfc_match_end):  Handle new context COMP_DERIVED_CONTAINS.
+	(gfc_match_private):  Ditto.
+	(match_binding_attributes), (match_procedure_in_type):  New methods.
+	(gfc_match_final_decl):  Rewrote to make use of new
+	COMP_DERIVED_CONTAINS parser state.
+	* parse.c (typebound_default_access):  New global helper variable.
+	(set_typebound_default_access):  New callback method.
+	(parse_derived_contains):  New method.
+	(parse_derived):  Extracted handling of CONTAINS to new parser state
+	and parse_derived_contains.
+	* resolve.c (resolve_bindings_derived), (resolve_bindings_result):  New.
+	(check_typebound_override), (resolve_typebound_procedure):  New methods.
+	(resolve_typebound_procedures):  New method.
+	(resolve_fl_derived):  Call new resolving method for typebound procs.
+	* symbol.c (gfc_new_symtree):  Initialize new member typebound to NULL.
+	(gfc_find_typebound_proc):  New method.
+	(gfc_get_derived_super_type):  New method.
+
 2008-08-23  Janus Weil  <janus@gcc.gnu.org>
 
 	* gfortran.h (gfc_component): Add field "symbol_attribute attr", remove
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index ab4a64f..7ccee8b 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4320,6 +4320,8 @@ syntax:
 
 /* General matcher for PROCEDURE declarations.  */
 
+static match match_procedure_in_type (void);
+
 match
 gfc_match_procedure (void)
 {
@@ -4338,9 +4340,12 @@ gfc_match_procedure (void)
       m = match_procedure_in_interface ();
       break;
     case COMP_DERIVED:
-      gfc_error ("Fortran 2003: Procedure components at %C are "
-		"not yet implemented in gfortran");
+      gfc_error ("Fortran 2003: Procedure components at %C are not yet"
+		 " implemented in gfortran");
       return MATCH_ERROR;
+    case COMP_DERIVED_CONTAINS:
+      m = match_procedure_in_type ();
+      break;
     default:
       return MATCH_NO;
     }
@@ -5099,7 +5104,7 @@ gfc_match_end (gfc_statement *st)
   block_name = gfc_current_block () == NULL
 	     ? NULL : gfc_current_block ()->name;
 
-  if (state == COMP_CONTAINS)
+  if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS)
     {
       state = gfc_state_stack->previous->state;
       block_name = gfc_state_stack->previous->sym == NULL
@@ -5146,6 +5151,7 @@ gfc_match_end (gfc_statement *st)
       break;
 
     case COMP_DERIVED:
+    case COMP_DERIVED_CONTAINS:
       *st = ST_END_TYPE;
       target = " type";
       eos_ok = 0;
@@ -5823,9 +5829,12 @@ gfc_match_private (gfc_statement *st)
     return MATCH_NO;
 
   if (gfc_current_state () != COMP_MODULE
-      && (gfc_current_state () != COMP_DERIVED
-          || !gfc_state_stack->previous
-          || gfc_state_stack->previous->state != COMP_MODULE))
+      && !(gfc_current_state () == COMP_DERIVED
+	   && gfc_state_stack->previous
+	   && gfc_state_stack->previous->state == COMP_MODULE)
+      && !(gfc_current_state () == COMP_DERIVED_CONTAINS
+	   && gfc_state_stack->previous && gfc_state_stack->previous->previous
+	   && gfc_state_stack->previous->previous->state == COMP_MODULE))
     {
       gfc_error ("PRIVATE statement at %C is only allowed in the "
 		 "specification part of a module");
@@ -6704,6 +6713,270 @@ cleanup:
 }
 
 
+/* Match binding attributes.  */
+
+static match
+match_binding_attributes (gfc_typebound_proc* ba)
+{
+  bool found_passing = false;
+  match m;
+
+  /* Intialize to defaults.  Do so even before the MATCH_NO check so that in
+     this case the defaults are in there.  */
+  ba->access = ACCESS_UNKNOWN;
+  ba->pass_arg = NULL;
+  ba->pass_arg_num = 0;
+  ba->nopass = 0;
+  ba->non_overridable = 0;
+
+  /* If we find a comma, we believe there are binding attributes.  */
+  if (gfc_match_char (',') == MATCH_NO)
+    return MATCH_NO;
+
+  do
+    {
+      /* NOPASS flag.  */
+      m = gfc_match (" nopass");
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_YES)
+	{
+	  if (found_passing)
+	    {
+	      gfc_error ("Binding attributes already specify passing, illegal"
+			 " NOPASS at %C");
+	      goto error;
+	    }
+
+	  found_passing = true;
+	  ba->nopass = 1;
+	  continue;
+	}
+
+      /* NON_OVERRIDABLE flag.  */
+      m = gfc_match (" non_overridable");
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_YES)
+	{
+	  if (ba->non_overridable)
+	    {
+	      gfc_error ("Duplicate NON_OVERRIDABLE at %C");
+	      goto error;
+	    }
+
+	  ba->non_overridable = 1;
+	  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)
+	{
+	  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;
+	}
+
+      /* Access specifier.  */
+
+      m = gfc_match (" public");
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_YES)
+	{
+	  if (ba->access != ACCESS_UNKNOWN)
+	    {
+	      gfc_error ("Duplicate access-specifier 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)
+	    {
+	      gfc_error ("Duplicate access-specifier at %C");
+	      goto error;
+	    }
+
+	  ba->access = ACCESS_PRIVATE;
+	  continue;
+	}
+
+      /* Nothing matching found.  */
+      gfc_error ("Expected binding attribute at %C");
+      goto error;
+    }
+  while (gfc_match_char (',') == MATCH_YES);
+
+  return MATCH_YES;
+
+error:
+  gfc_free (ba->pass_arg);
+  return MATCH_ERROR;
+}
+
+
+/* Match a PROCEDURE specific binding inside a derived type.  */
+
+static match
+match_procedure_in_type (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  char target_buf[GFC_MAX_SYMBOL_LEN + 1];
+  char* target;
+  gfc_typebound_proc* tb;
+  bool seen_colons;
+  bool seen_attrs;
+  match m;
+  gfc_symtree* stree;
+  gfc_namespace* ns;
+  gfc_symbol* block;
+
+  /* Check current state.  */
+  gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
+  block = gfc_state_stack->previous->sym;
+  gcc_assert (block);
+
+  /* TODO: Really implement PROCEDURE(interface).  */
+  if (gfc_match (" (") == MATCH_YES)
+    {
+      gfc_error ("Procedure with interface only allowed in abstract types at"
+		 " %C");
+      return MATCH_ERROR;
+    }
+
+  /* Construct the data structure.  */
+  tb = XCNEW (gfc_typebound_proc);
+  tb->where = gfc_current_locus;
+
+  /* Match binding attributes.  */
+  m = match_binding_attributes (tb);
+  if (m == MATCH_ERROR)
+    return m;
+  seen_attrs = (m == MATCH_YES);
+
+  /* Match the colons.  */
+  m = gfc_match (" ::");
+  if (m == MATCH_ERROR)
+    return m;
+  seen_colons = (m == MATCH_YES);
+  if (seen_attrs && !seen_colons)
+    {
+      gfc_error ("Expected '::' after binding-attributes at %C");
+      return MATCH_ERROR;
+    }
+
+  /* Match the binding name.  */ 
+  m = gfc_match_name (name);
+  if (m == MATCH_ERROR)
+    return m;
+  if (m == MATCH_NO)
+    {
+      gfc_error ("Expected binding name at %C");
+      return MATCH_ERROR;
+    }
+
+  /* Try to match the '=> target', if it's there.  */
+  target = NULL;
+  m = gfc_match (" =>");
+  if (m == MATCH_ERROR)
+    return m;
+  if (m == MATCH_YES)
+    {
+      if (!seen_colons)
+	{
+	  gfc_error ("'::' needed in PROCEDURE binding with explicit target"
+		     " at %C");
+	  return MATCH_ERROR;
+	}
+
+      m = gfc_match_name (target_buf);
+      if (m == MATCH_ERROR)
+	return m;
+      if (m == MATCH_NO)
+	{
+	  gfc_error ("Expected binding target after '=>' at %C");
+	  return MATCH_ERROR;
+	}
+      target = target_buf;
+    }
+
+  /* Now we should have the end.  */
+  m = gfc_match_eos ();
+  if (m == MATCH_ERROR)
+    return m;
+  if (m == MATCH_NO)
+    {
+      gfc_error ("Junk after PROCEDURE declaration at %C");
+      return MATCH_ERROR;
+    }
+
+  /* If no target was found, it has the same name as the binding.  */
+  if (!target)
+    target = name;
+
+  /* Get the namespace to insert the symbols into.  */
+  ns = block->f2k_derived;
+  gcc_assert (ns);
+
+  /* See if we already have a binding with this name in the symtree which would
+     be an error.  */
+  stree = gfc_find_symtree (ns->sym_root, name);
+  if (stree)
+    {
+      gfc_error ("There's already a procedure with binding name '%s' for the"
+		 " derived type '%s' at %C", name, block->name);
+      return MATCH_ERROR;
+    }
+
+  /* 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))
+    return MATCH_ERROR;
+  stree->typebound = tb;
+
+  return MATCH_YES;
+}
+
+
 /* Match a FINAL declaration inside a derived type.  */
 
 match
@@ -6714,18 +6987,20 @@ gfc_match_final_decl (void)
   match m;
   gfc_namespace* module_ns;
   bool first, last;
+  gfc_symbol* block;
 
-  if (gfc_state_stack->state != COMP_DERIVED)
+  if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
     {
       gfc_error ("FINAL declaration at %C must be inside a derived type "
-		 "definition!");
+		 "CONTAINS section");
       return MATCH_ERROR;
     }
 
-  gcc_assert (gfc_current_block ());
+  block = gfc_state_stack->previous->sym;
+  gcc_assert (block);
 
-  if (!gfc_state_stack->previous
-      || gfc_state_stack->previous->state != COMP_MODULE)
+  if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous
+      || gfc_state_stack->previous->previous->state != COMP_MODULE)
     {
       gfc_error ("Derived type declaration with FINAL at %C must be in the"
 		 " specification part of a MODULE");
@@ -6783,7 +7058,7 @@ gfc_match_final_decl (void)
 	return MATCH_ERROR;
 
       /* Check if we already have this symbol in the list, this is an error.  */
-      for (f = gfc_current_block ()->f2k_derived->finalizers; f; f = f->next)
+      for (f = block->f2k_derived->finalizers; f; f = f->next)
 	if (f->proc_sym == sym)
 	  {
 	    gfc_error ("'%s' at %C is already defined as FINAL procedure!",
@@ -6792,14 +7067,14 @@ gfc_match_final_decl (void)
 	  }
 
       /* Add this symbol to the list of finalizers.  */
-      gcc_assert (gfc_current_block ()->f2k_derived);
+      gcc_assert (block->f2k_derived);
       ++sym->refs;
       f = XCNEW (gfc_finalizer);
       f->proc_sym = sym;
       f->proc_tree = NULL;
       f->where = gfc_current_locus;
-      f->next = gfc_current_block ()->f2k_derived->finalizers;
-      gfc_current_block ()->f2k_derived->finalizers = f;
+      f->next = block->f2k_derived->finalizers;
+      block->f2k_derived->finalizers = f;
 
       first = false;
     }
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 7ab1b49..322b4a5 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -991,6 +991,27 @@ typedef struct
 }
 gfc_user_op;
 
+
+/* Data needed for type-bound procedures.  */
+typedef struct
+{
+  struct gfc_symtree* target;
+  locus where; /* Where the PROCEDURE definition was.  */
+
+  gfc_access access;
+  char* pass_arg; /* Argument-name for PASS.  NULL if not specified.  */
+
+  /* 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 0 here, the second 1, and so on.  */
+  unsigned pass_arg_num;
+
+  unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise).  */
+  unsigned non_overridable:1;
+}
+gfc_typebound_proc;
+
+
 /* Symbol nodes.  These are important things.  They are what the
    standard refers to as "entities".  The possibly multiple names that
    refer to the same entity are accomplished by a binary tree of
@@ -1127,6 +1148,8 @@ typedef struct gfc_symtree
   }
   n;
 
+  /* Data for type-bound procedures; NULL if no type-bound procedure.  */
+  gfc_typebound_proc* typebound;
 }
 gfc_symtree;
 
@@ -2237,6 +2260,9 @@ void gfc_symbol_state (void);
 gfc_gsymbol *gfc_get_gsymbol (const char *);
 gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
 
+gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
+gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, const char*);
+
 void copy_formal_args (gfc_symbol *dest, gfc_symbol *src);
 
 void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too  */
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index f9c3705..4bf1b81 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -1691,13 +1691,143 @@ 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.  */
+
+static bool
+parse_derived_contains (void)
+{
+  gfc_state_data s;
+  bool seen_private = false;
+  bool seen_comps = false;
+  bool error_flag = false;
+  bool to_finish;
+
+  accept_statement (ST_CONTAINS);
+  gcc_assert (gfc_current_state () == COMP_DERIVED);
+  push_state (&s, COMP_DERIVED_CONTAINS, NULL);
+
+  to_finish = false;
+  while (!to_finish)
+    {
+      gfc_statement st;
+      st = next_statement ();
+      switch (st)
+	{
+	case ST_NONE:
+	  unexpected_eof ();
+	  break;
+
+	case ST_DATA_DECL:
+	  gfc_error ("Components in TYPE at %C must precede CONTAINS");
+	  error_flag = true;
+	  break;
+
+	case ST_PROCEDURE:
+	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003:  Type-bound"
+					     " procedure at %C") == FAILURE)
+	    error_flag = true;
+
+	  accept_statement (ST_PROCEDURE);
+	  seen_comps = true;
+	  break;
+
+	case ST_FINAL:
+	  if (gfc_notify_std (GFC_STD_F2003,
+			      "Fortran 2003:  FINAL procedure declaration"
+			      " at %C") == FAILURE)
+	    error_flag = true;
+
+	  accept_statement (ST_FINAL);
+	  seen_comps = true;
+	  break;
+
+	case ST_END_TYPE:
+	  to_finish = true;
+
+	  if (!seen_comps
+	      && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
+				  "definition at %C with empty CONTAINS "
+				  "section") == FAILURE))
+	    error_flag = true;
+
+	  /* ST_END_TYPE is accepted by parse_derived after return.  */
+	  break;
+
+	case ST_PRIVATE:
+	  if (gfc_find_state (COMP_MODULE) == FAILURE)
+	    {
+	      gfc_error ("PRIVATE statement in TYPE at %C must be inside "
+			 "a MODULE");
+	      error_flag = true;
+	      break;
+	    }
+
+	  if (seen_comps)
+	    {
+	      gfc_error ("PRIVATE statement at %C must precede procedure"
+			 " bindings");
+	      error_flag = true;
+	      break;
+	    }
+
+	  if (seen_private)
+	    {
+	      gfc_error ("Duplicate PRIVATE statement at %C");
+	      error_flag = true;
+	    }
+
+	  accept_statement (ST_PRIVATE);
+	  seen_private = true;
+	  break;
+
+	case ST_SEQUENCE:
+	  gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
+	  error_flag = true;
+	  break;
+
+	case ST_CONTAINS:
+	  gfc_error ("Already inside a CONTAINS block at %C");
+	  error_flag = true;
+	  break;
+
+	default:
+	  unexpected_statement (st);
+	  break;
+	}
+    }
+
+  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;
+}
+
+
 /* Parse a derived type.  */
 
 static void
 parse_derived (void)
 {
   int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
-  int seen_contains, seen_contains_comp;
   gfc_statement st;
   gfc_state_data s;
   gfc_symbol *derived_sym = NULL;
@@ -1713,8 +1843,6 @@ parse_derived (void)
   seen_private = 0;
   seen_sequence = 0;
   seen_component = 0;
-  seen_contains = 0;
-  seen_contains_comp = 0;
 
   compiling_type = 1;
 
@@ -1727,34 +1855,22 @@ parse_derived (void)
 	  unexpected_eof ();
 
 	case ST_DATA_DECL:
-	case ST_PROCEDURE:
-	  if (seen_contains)
-	    {
-	      gfc_error ("Components in TYPE at %C must precede CONTAINS");
-	      error_flag = 1;
-	    }
-
 	  accept_statement (st);
 	  seen_component = 1;
 	  break;
 
-	case ST_FINAL:
-	  if (!seen_contains)
-	    {
-	      gfc_error ("FINAL declaration at %C must be inside CONTAINS");
-	      error_flag = 1;
-	    }
-
-	  if (gfc_notify_std (GFC_STD_F2003,
-			      "Fortran 2003:  FINAL procedure declaration"
-			      " at %C") == FAILURE)
-	    error_flag = 1;
+	case ST_PROCEDURE:
+	  gfc_error ("PROCEDURE binding at %C must be inside CONTAINS");
+	  error_flag = 1;
+	  break;
 
-	  accept_statement (ST_FINAL);
-	  seen_contains_comp = 1;
+	case ST_FINAL:
+	  gfc_error ("FINAL declaration at %C must be inside CONTAINS");
+	  error_flag = 1;
 	  break;
 
 	case ST_END_TYPE:
+endType:
 	  compiling_type = 0;
 
 	  if (!seen_component
@@ -1763,22 +1879,10 @@ parse_derived (void)
 		  == FAILURE))
 	    error_flag = 1;
 
-	  if (seen_contains && !seen_contains_comp
-	      && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
-				 "definition at %C with empty CONTAINS "
-				 "section") == FAILURE))
-	    error_flag = 1;
-
 	  accept_statement (ST_END_TYPE);
 	  break;
 
 	case ST_PRIVATE:
-	  if (seen_contains)
-	    {
-	      gfc_error ("PRIVATE statement at %C must precede CONTAINS");
-	      error_flag = 1;
-	    }
-
 	  if (gfc_find_state (COMP_MODULE) == FAILURE)
 	    {
 	      gfc_error ("PRIVATE statement in TYPE at %C must be inside "
@@ -1802,17 +1906,12 @@ parse_derived (void)
 	    }
 
 	  s.sym->component_access = ACCESS_PRIVATE;
+
 	  accept_statement (ST_PRIVATE);
 	  seen_private = 1;
 	  break;
 
 	case ST_SEQUENCE:
-	  if (seen_contains)
-	    {
-	      gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
-	      error_flag = 1;
-	    }
-
 	  if (seen_component)
 	    {
 	      gfc_error ("SEQUENCE statement at %C must precede "
@@ -1842,15 +1941,10 @@ parse_derived (void)
 			      " definition at %C") == FAILURE)
 	    error_flag = 1;
 
-	  if (seen_contains)
-	    {
-	      gfc_error ("Already inside a CONTAINS block at %C");
-	      error_flag = 1;
-	    }
-
-	  seen_contains = 1;
 	  accept_statement (ST_CONTAINS);
-	  break;
+	  if (parse_derived_contains ())
+	    error_flag = 1;
+	  goto endType;
 
 	default:
 	  unexpected_statement (st);
diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h
index 1ac3e94..7fe2330 100644
--- a/gcc/fortran/parse.h
+++ b/gcc/fortran/parse.h
@@ -29,8 +29,8 @@ along with GCC; see the file COPYING3.  If not see
 typedef enum
 {
   COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBROUTINE, COMP_FUNCTION,
-  COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_IF, COMP_DO,
-  COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
+  COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS, COMP_IF,
+  COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
   COMP_OMP_STRUCTURED_BLOCK
 }
 gfc_compile_state;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 51d0654..9cde435 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7613,6 +7613,321 @@ error:
 }
 
 
+/* Check that it is ok for the typebound procedure proc to override the
+   procedure old.  */
+
+static gfc_try
+check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
+{
+  locus where;
+  const gfc_symbol* proc_target;
+  const gfc_symbol* old_target;
+  unsigned proc_pass_arg, old_pass_arg, argpos;
+  gfc_formal_arglist* proc_formal;
+  gfc_formal_arglist* old_formal;
+
+  where = proc->typebound->where;
+  proc_target = proc->typebound->target->n.sym;
+  old_target = old->typebound->target->n.sym;
+
+  /* Check that overridden binding is not NON_OVERRIDABLE.  */
+  if (old->typebound->non_overridable)
+    {
+      gfc_error ("'%s' at %L overrides a procedure binding declared"
+		 " NON_OVERRIDABLE", proc->name, &where);
+      return FAILURE;
+    }
+
+  /* If the overridden binding is PURE, the overriding must be, too.  */
+  if (old_target->attr.pure && !proc_target->attr.pure)
+    {
+      gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
+		 proc->name, &where);
+      return FAILURE;
+    }
+
+  /* If the overridden binding is ELEMENTAL, the overriding must be, too.  If it
+     is not, the overriding must not be either.  */
+  if (old_target->attr.elemental && !proc_target->attr.elemental)
+    {
+      gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
+		 " ELEMENTAL", proc->name, &where);
+      return FAILURE;
+    }
+  if (!old_target->attr.elemental && proc_target->attr.elemental)
+    {
+      gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
+		 " be ELEMENTAL, either", proc->name, &where);
+      return FAILURE;
+    }
+
+  /* If the overridden binding is a SUBROUTINE, the overriding must also be a
+     SUBROUTINE.  */
+  if (old_target->attr.subroutine && !proc_target->attr.subroutine)
+    {
+      gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
+		 " SUBROUTINE", proc->name, &where);
+      return FAILURE;
+    }
+
+  /* If the overridden binding is a FUNCTION, the overriding must also be a
+     FUNCTION and have the same characteristics.  */
+  if (old_target->attr.function)
+    {
+      if (!proc_target->attr.function)
+	{
+	  gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
+		     " FUNCTION", proc->name, &where);
+	  return FAILURE;
+	}
+
+      /* FIXME:  Do more comprehensive checking (including, for instance, the
+	 rank and array-shape).  */
+      gcc_assert (proc_target->result && old_target->result);
+      if (!gfc_compare_types (&proc_target->result->ts,
+			      &old_target->result->ts))
+	{
+	  gfc_error ("'%s' at %L and the overridden FUNCTION should have"
+		     " matching result types", proc->name, &where);
+	  return FAILURE;
+	}
+    }
+
+  /* If the overridden binding is PUBLIC, the overriding one must not be
+     PRIVATE.  */
+  if (old->typebound->access == ACCESS_PUBLIC
+      && proc->typebound->access == ACCESS_PRIVATE)
+    {
+      gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
+		 " PRIVATE", proc->name, &where);
+      return FAILURE;
+    }
+
+  /* Compare the formal argument lists of both procedures.  This is also abused
+     to find the position of the passed-object dummy arguments of both
+     bindings as at least the overridden one might not yet be resolved and we
+     need those positions in the check below.  */
+  proc_pass_arg = old_pass_arg = 0;
+  if (!proc->typebound->nopass && !proc->typebound->pass_arg)
+    proc_pass_arg = 1;
+  if (!old->typebound->nopass && !old->typebound->pass_arg)
+    old_pass_arg = 1;
+  argpos = 1;
+  for (proc_formal = proc_target->formal, old_formal = old_target->formal;
+       proc_formal && old_formal;
+       proc_formal = proc_formal->next, old_formal = old_formal->next)
+    {
+      if (proc->typebound->pass_arg
+	  && !strcmp (proc->typebound->pass_arg, proc_formal->sym->name))
+	proc_pass_arg = argpos;
+      if (old->typebound->pass_arg
+	  && !strcmp (old->typebound->pass_arg, old_formal->sym->name))
+	old_pass_arg = argpos;
+
+      /* Check that the names correspond.  */
+      if (strcmp (proc_formal->sym->name, old_formal->sym->name))
+	{
+	  gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
+		     " to match the corresponding argument of the overridden"
+		     " procedure", proc_formal->sym->name, proc->name, &where,
+		     old_formal->sym->name);
+	  return FAILURE;
+	}
+
+      /* Check that the types correspond if neither is the passed-object
+	 argument.  */
+      /* FIXME:  Do more comprehensive testing here.  */
+      if (proc_pass_arg != argpos && old_pass_arg != argpos
+	  && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
+	{
+	  gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in"
+		     " in respect to the overridden procedure",
+		     proc_formal->sym->name, proc->name, &where);
+	  return FAILURE;
+	}
+
+      ++argpos;
+    }
+  if (proc_formal || old_formal)
+    {
+      gfc_error ("'%s' at %L must have the same number of formal arguments as"
+		 " the overridden procedure", proc->name, &where);
+      return FAILURE;
+    }
+
+  /* If the overridden binding is NOPASS, the overriding one must also be
+     NOPASS.  */
+  if (old->typebound->nopass && !proc->typebound->nopass)
+    {
+      gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
+		 " NOPASS", proc->name, &where);
+      return FAILURE;
+    }
+
+  /* If the overridden binding is PASS(x), the overriding one must also be
+     PASS and the passed-object dummy arguments must correspond.  */
+  if (!old->typebound->nopass)
+    {
+      if (proc->typebound->nopass)
+	{
+	  gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
+		     " PASS", proc->name, &where);
+	  return FAILURE;
+	}
+
+      if (proc_pass_arg != old_pass_arg)
+	{
+	  gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
+		     " the same position as the passed-object dummy argument of"
+		     " the overridden procedure", proc->name, &where);
+	  return FAILURE;
+	}
+    }
+
+  return SUCCESS;
+}
+
+
+/* Resolve the type-bound procedures for a derived type.  */
+
+static gfc_symbol* resolve_bindings_derived;
+static gfc_try resolve_bindings_result;
+
+static void
+resolve_typebound_procedure (gfc_symtree* stree)
+{
+  gfc_symbol* proc;
+  locus where;
+  gfc_symbol* me_arg;
+  gfc_symbol* super_type;
+
+  /* If this is no type-bound procedure, just return.  */
+  if (!stree->typebound)
+    return;
+
+  /* Get the target-procedure to check it.  */
+  gcc_assert (stree->typebound->target);
+  proc = stree->typebound->target->n.sym;
+  where = stree->typebound->where;
+
+  /* Default access should already be resolved from the parser.  */
+  gcc_assert (stree->typebound->access != ACCESS_UNKNOWN);
+
+  /* It should be a module procedure or an external procedure with explicit
+     interface.  */
+  if ((!proc->attr.subroutine && !proc->attr.function)
+      || (proc->attr.proc != PROC_MODULE
+	  && proc->attr.if_source != IFSRC_IFBODY)
+      || proc->attr.abstract)
+    {
+      gfc_error ("'%s' must be a module procedure or an external procedure with"
+		 " an explicit interface at %L", proc->name, &where);
+      goto error;
+    }
+
+  /* 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 (stree->typebound->pass_arg)
+	{
+	  gfc_formal_arglist* i;
+
+	  /* If an explicit passing argument name is given, walk the arg-list
+	     and look for it.  */
+
+	  me_arg = NULL;
+	  stree->typebound->pass_arg_num = 0;
+	  for (i = proc->formal; i; i = i->next)
+	    {
+	      if (!strcmp (i->sym->name, stree->typebound->pass_arg))
+		{
+		  me_arg = i->sym;
+		  break;
+		}
+	      ++stree->typebound->pass_arg_num;
+	    }
+
+	  if (!me_arg)
+	    {
+	      gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
+			 " argument '%s'",
+			 proc->name, stree->typebound->pass_arg, &where,
+			 stree->typebound->pass_arg);
+	      goto error;
+	    }
+	}
+      else
+	{
+	  /* Otherwise, take the first one; there should in fact be at least
+	     one.  */
+	  stree->typebound->pass_arg_num = 0;
+	  if (!proc->formal)
+	    {
+	      gfc_error ("Procedure '%s' with PASS at %L must have at"
+			 " least one argument", proc->name, &where);
+	      goto error;
+	    }
+	  me_arg = proc->formal->sym;
+	}
+
+      /* Now check that the argument-type matches.  */
+      gcc_assert (me_arg);
+      if (me_arg->ts.type != BT_DERIVED
+	  || me_arg->ts.derived != resolve_bindings_derived)
+	{
+	  gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
+		     " the derived-type '%s'", me_arg->name, proc->name,
+		     me_arg->name, &where, resolve_bindings_derived->name);
+	  goto error;
+	}
+    }
+
+  /* If we are extending some type, check that we don't override a procedure
+     flagged NON_OVERRIDABLE.  */
+  if (super_type)
+    {
+      gfc_symtree* overridden;
+      overridden = gfc_find_typebound_proc (super_type, stree->name);
+
+      if (overridden && check_typebound_override (stree, overridden) == FAILURE)
+	goto error;
+    }
+
+  /* FIXME: Remove once typebound-procedures are fully implemented.  */
+  {
+    /* Output the error only once so we can do reasonable testing.  */
+    static bool tbp_error = false;
+    if (!tbp_error)
+      gfc_error ("Type-bound procedures are not yet implemented at %L", &where);
+    tbp_error = true;
+  }
+
+  return;
+
+error:
+  resolve_bindings_result = FAILURE;
+}
+
+static gfc_try
+resolve_typebound_procedures (gfc_symbol* derived)
+{
+  if (!derived->f2k_derived || !derived->f2k_derived->sym_root)
+    return SUCCESS;
+
+  resolve_bindings_derived = derived;
+  resolve_bindings_result = SUCCESS;
+  gfc_traverse_symtree (derived->f2k_derived->sym_root,
+			&resolve_typebound_procedure);
+
+  return resolve_bindings_result;
+}
+
+
 /* Add a derived type to the dt_list.  The dt_list is used in trans-types.c
    to give all identical derived types the same backend_decl.  */
 static void
@@ -7722,6 +8037,10 @@ resolve_fl_derived (gfc_symbol *sym)
 	}
     }
 
+  /* Resolve the type-bound procedures.  */
+  if (resolve_typebound_procedures (sym) == FAILURE)
+    return FAILURE;
+
   /* Resolve the finalizer procedures.  */
   if (gfc_resolve_finalizers (sym) == FAILURE)
     return FAILURE;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 6244eed..005086d 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2225,6 +2225,7 @@ 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;
@@ -4238,3 +4239,47 @@ gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
   /* Everything is ok.  */
   return SUCCESS;
 }
+
+
+/* Get the super-type of a given derived type.  */
+
+gfc_symbol*
+gfc_get_derived_super_type (gfc_symbol* derived)
+{
+  if (!derived->attr.extension)
+    return NULL;
+
+  gcc_assert (derived->components);
+  gcc_assert (derived->components->ts.type == BT_DERIVED);
+  gcc_assert (derived->components->ts.derived);
+
+  return derived->components->ts.derived;
+}
+
+
+/* Find a type-bound procedure by name for a derived-type (looking recursively
+   through the super-types).  */
+
+gfc_symtree*
+gfc_find_typebound_proc (gfc_symbol* derived, const char* name)
+{
+  gfc_symtree* res;
+
+  /* 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)
+    return res->typebound ? res : NULL;
+
+  /* Otherwise, recurse on parent type if derived is an extension.  */
+  if (derived->attr.extension)
+    {
+      gfc_symbol* super_type;
+      super_type = gfc_get_derived_super_type (derived);
+      gcc_assert (super_type);
+      return gfc_find_typebound_proc (super_type, name);
+    }
+
+  /* Nothing found.  */
+  return NULL;
+}