re PR fortran/37425 (Fortran 2003: GENERIC bindings as operators)

2009-08-10  Daniel Kraft  <d@domob.eu>

	PR fortran/37425
	* gfortran.dg/typebound_operator_1.f03: New test.
	* gfortran.dg/typebound_operator_2.f03: New test.

2009-08-10  Daniel Kraft  <d@domob.eu>

	PR fortran/37425
	* gfortran.h (struct gfc_namespace): New fields tb_uop_root and tb_op.
	(gfc_find_typebound_user_op): New routine.
	(gfc_find_typebound_intrinsic_op): Ditto.
	(gfc_check_operator_interface): Now public routine.
	* decl.c (gfc_match_generic): Match OPERATOR(X) or ASSIGNMENT(=).
	* interface.c (check_operator_interface): Made public, renamed to
	`gfc_check_operator_interface' accordingly and hand in the interface
	as gfc_symbol rather than gfc_interface so it is useful for type-bound
	operators, too.  Return boolean result.
	(gfc_check_interfaces): Adapt call to `check_operator_interface'.
	* symbol.c (gfc_get_namespace): Initialize new field `tb_op'.
	(gfc_free_namespace): Free `tb_uop_root'-based tree.
	(find_typebound_proc_uop): New helper function.
	(gfc_find_typebound_proc): Use it.
	(gfc_find_typebound_user_op): New method.
	(gfc_find_typebound_intrinsic_op): Ditto.
	* resolve.c (resolve_tb_generic_targets): New helper function.
	(resolve_typebound_generic): Use it.
	(resolve_typebound_intrinsic_op), (resolve_typebound_user_op): New.
	(resolve_typebound_procedures): Resolve operators, too.
	(check_uop_procedure): New, code from gfc_resolve_uops.
	(gfc_resolve_uops): Moved main code to new `check_uop_procedure'.

From-SVN: r150622

6 files changed, 539 insertions, 158 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6158a72..1e8d739 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,29 @@
+2009-08-10  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37425
+	* gfortran.h (struct gfc_namespace): New fields tb_uop_root and tb_op.
+	(gfc_find_typebound_user_op): New routine.
+	(gfc_find_typebound_intrinsic_op): Ditto.
+	(gfc_check_operator_interface): Now public routine.
+	* decl.c (gfc_match_generic): Match OPERATOR(X) or ASSIGNMENT(=).
+	* interface.c (check_operator_interface): Made public, renamed to
+	`gfc_check_operator_interface' accordingly and hand in the interface
+	as gfc_symbol rather than gfc_interface so it is useful for type-bound
+	operators, too.  Return boolean result.
+	(gfc_check_interfaces): Adapt call to `check_operator_interface'.
+	* symbol.c (gfc_get_namespace): Initialize new field `tb_op'.
+	(gfc_free_namespace): Free `tb_uop_root'-based tree.
+	(find_typebound_proc_uop): New helper function.
+	(gfc_find_typebound_proc): Use it.
+	(gfc_find_typebound_user_op): New method.
+	(gfc_find_typebound_intrinsic_op): Ditto.
+	* resolve.c (resolve_tb_generic_targets): New helper function.
+	(resolve_typebound_generic): Use it.
+	(resolve_typebound_intrinsic_op), (resolve_typebound_user_op): New.
+	(resolve_typebound_procedures): Resolve operators, too.
+	(check_uop_procedure): New, code from gfc_resolve_uops.
+	(gfc_resolve_uops): Moved main code to new `check_uop_procedure'.
+
 2009-08-10  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/40940
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 6b6203e..abe2147 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -7406,11 +7406,13 @@ match
 gfc_match_generic (void)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
+  char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...).  */
   gfc_symbol* block;
   gfc_typebound_proc tbattr; /* Used for match_binding_attributes.  */
   gfc_typebound_proc* tb;
-  gfc_symtree* st;
   gfc_namespace* ns;
+  interface_type op_type;
+  gfc_intrinsic_op op;
   match m;
 
   /* Check current state.  */
@@ -7437,49 +7439,126 @@ gfc_match_generic (void)
       goto error;
     }
 
-  /* The binding name and =>.  */
-  m = gfc_match (" %n =>", name);
+  /* Match the binding name; depending on type (operator / generic) format
+     it for future error messages into bind_name.  */
+ 
+  m = gfc_match_generic_spec (&op_type, name, &op);
   if (m == MATCH_ERROR)
     return MATCH_ERROR;
   if (m == MATCH_NO)
     {
-      gfc_error ("Expected generic name at %C");
+      gfc_error ("Expected generic name or operator descriptor 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->tb_sym_root, name);
-  if (st)
+  switch (op_type)
     {
-      gcc_assert (st->n.tb);
-      tb = st->n.tb;
+    case INTERFACE_GENERIC:
+      snprintf (bind_name, sizeof (bind_name), "%s", name);
+      break;
+ 
+    case INTERFACE_USER_OP:
+      snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
+      break;
+ 
+    case INTERFACE_INTRINSIC_OP:
+      snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
+		gfc_op2string (op));
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
 
+  /* Match the required =>.  */
+  if (gfc_match (" =>") != MATCH_YES)
+    {
+      gfc_error ("Expected '=>' at %C");
+      goto error;
+    }
+  
+  /* Try to find existing GENERIC binding with this name / for this operator;
+     if there is something, check that it is another GENERIC and then extend
+     it rather than building a new node.  Otherwise, create it and put it
+     at the right position.  */
+
+  switch (op_type)
+    {
+    case INTERFACE_USER_OP:
+    case INTERFACE_GENERIC:
+      {
+	const bool is_op = (op_type == INTERFACE_USER_OP);
+	gfc_symtree* st;
+
+	st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
+	if (st)
+	  {
+	    tb = st->n.tb;
+	    gcc_assert (tb);
+	  }
+	else
+	  tb = NULL;
+
+	break;
+      }
+
+    case INTERFACE_INTRINSIC_OP:
+      tb = ns->tb_op[op];
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+
+  if (tb)
+    {
       if (!tb->is_generic)
 	{
+	  gcc_assert (op_type == INTERFACE_GENERIC);
 	  gfc_error ("There's already a non-generic procedure with binding name"
 		     " '%s' for the derived type '%s' at %C",
-		     name, block->name);
+		     bind_name, block->name);
 	  goto error;
 	}
 
       if (tb->access != tbattr.access)
 	{
 	  gfc_error ("Binding at %C must have the same access as already"
-		     " defined binding '%s'", name);
+		     " defined binding '%s'", bind_name);
 	  goto error;
 	}
     }
   else
     {
-      st = gfc_new_symtree (&ns->tb_sym_root, name);
-      gcc_assert (st);
-
-      st->n.tb = tb = gfc_get_typebound_proc ();
+      tb = gfc_get_typebound_proc ();
       tb->where = gfc_current_locus;
       tb->access = tbattr.access;
       tb->is_generic = 1;
       tb->u.generic = NULL;
+
+      switch (op_type)
+	{
+	case INTERFACE_GENERIC:
+	case INTERFACE_USER_OP:
+	  {
+	    const bool is_op = (op_type == INTERFACE_USER_OP);
+	    gfc_symtree* st;
+
+	    st = gfc_new_symtree (is_op ? &ns->tb_uop_root : &ns->tb_sym_root,
+				  name);
+	    gcc_assert (st);
+	    st->n.tb = tb;
+
+	    break;
+	  }
+	  
+	case INTERFACE_INTRINSIC_OP:
+	  ns->tb_op[op] = tb;
+	  break;
+
+	default:
+	  gcc_unreachable ();
+	}
     }
 
   /* Now, match all following names as specific targets.  */
@@ -7504,7 +7583,7 @@ gfc_match_generic (void)
 	if (target_st == target->specific_st)
 	  {
 	    gfc_error ("'%s' already defined as specific binding for the"
-		       " generic '%s' at %C", name, st->name);
+		       " generic '%s' at %C", name, bind_name);
 	    goto error;
 	  }
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 3d95d217..cb456bc 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1287,6 +1287,10 @@ typedef struct gfc_namespace
 
   /* Tree containing type-bound procedures.  */
   gfc_symtree *tb_sym_root;
+  /* Type-bound user operators.  */
+  gfc_symtree *tb_uop_root;
+  /* For derived-types, store type-bound intrinsic operators here.  */
+  gfc_typebound_proc *tb_op[GFC_INTRINSIC_OPS];
   /* Linked list of finalizer procedures.  */
   struct gfc_finalizer *finalizers;
 
@@ -2448,6 +2452,10 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
 gfc_typebound_proc* gfc_get_typebound_proc (void);
 gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
 gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool);
+gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
+					 const char*, bool);
+gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*,
+						     gfc_intrinsic_op, bool);
 gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
 
 void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *);
@@ -2636,6 +2644,7 @@ gfc_interface *gfc_current_interface_head (void);
 void gfc_set_current_interface_head (gfc_interface *);
 gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*);
 bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*);
+bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus);
 
 /* io.c */
 extern gfc_st_label format_asterisk;
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 982aa29..daa46d8 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -544,17 +544,16 @@ find_keyword_arg (const char *name, gfc_formal_arglist *f)
 /* Given an operator interface and the operator, make sure that all
    interfaces for that operator are legal.  */
 
-static void
-check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
+bool
+gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
+			      locus opwhere)
 {
   gfc_formal_arglist *formal;
   sym_intent i1, i2;
-  gfc_symbol *sym;
   bt t1, t2;
   int args, r1, r2, k1, k2;
 
-  if (intr == NULL)
-    return;
+  gcc_assert (sym);
 
   args = 0;
   t1 = t2 = BT_UNKNOWN;
@@ -562,34 +561,32 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
   r1 = r2 = -1;
   k1 = k2 = -1;
 
-  for (formal = intr->sym->formal; formal; formal = formal->next)
+  for (formal = sym->formal; formal; formal = formal->next)
     {
-      sym = formal->sym;
-      if (sym == NULL)
+      gfc_symbol *fsym = formal->sym;
+      if (fsym == NULL)
 	{
 	  gfc_error ("Alternate return cannot appear in operator "
-		     "interface at %L", &intr->sym->declared_at);
-	  return;
+		     "interface at %L", &sym->declared_at);
+	  return false;
 	}
       if (args == 0)
 	{
-	  t1 = sym->ts.type;
-	  i1 = sym->attr.intent;
-	  r1 = (sym->as != NULL) ? sym->as->rank : 0;
-	  k1 = sym->ts.kind;
+	  t1 = fsym->ts.type;
+	  i1 = fsym->attr.intent;
+	  r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
+	  k1 = fsym->ts.kind;
 	}
       if (args == 1)
 	{
-	  t2 = sym->ts.type;
-	  i2 = sym->attr.intent;
-	  r2 = (sym->as != NULL) ? sym->as->rank : 0;
-	  k2 = sym->ts.kind;
+	  t2 = fsym->ts.type;
+	  i2 = fsym->attr.intent;
+	  r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
+	  k2 = fsym->ts.kind;
 	}
       args++;
     }
 
-  sym = intr->sym;
-
   /* Only +, - and .not. can be unary operators.
      .not. cannot be a binary operator.  */
   if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
@@ -598,8 +595,8 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
       || (args == 2 && op == INTRINSIC_NOT))
     {
       gfc_error ("Operator interface at %L has the wrong number of arguments",
-		 &intr->sym->declared_at);
-      return;
+		 &sym->declared_at);
+      return false;
     }
 
   /* Check that intrinsics are mapped to functions, except
@@ -609,20 +606,20 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
       if (!sym->attr.subroutine)
 	{
 	  gfc_error ("Assignment operator interface at %L must be "
-		     "a SUBROUTINE", &intr->sym->declared_at);
-	  return;
+		     "a SUBROUTINE", &sym->declared_at);
+	  return false;
 	}
       if (args != 2)
 	{
 	  gfc_error ("Assignment operator interface at %L must have "
-		     "two arguments", &intr->sym->declared_at);
-	  return;
+		     "two arguments", &sym->declared_at);
+	  return false;
 	}
 
       /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
-         - First argument an array with different rank than second,
-         - Types and kinds do not conform, and
-         - First argument is of derived type.  */
+	 - First argument an array with different rank than second,
+	 - Types and kinds do not conform, and
+	 - First argument is of derived type.  */
       if (sym->formal->sym->ts.type != BT_DERIVED
 	  && (r1 == 0 || r1 == r2)
 	  && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
@@ -630,8 +627,8 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
 		  && gfc_numeric_ts (&sym->formal->next->sym->ts))))
 	{
 	  gfc_error ("Assignment operator interface at %L must not redefine "
-		     "an INTRINSIC type assignment", &intr->sym->declared_at);
-	  return;
+		     "an INTRINSIC type assignment", &sym->declared_at);
+	  return false;
 	}
     }
   else
@@ -639,8 +636,8 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
       if (!sym->attr.function)
 	{
 	  gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
-		     &intr->sym->declared_at);
-	  return;
+		     &sym->declared_at);
+	  return false;
 	}
     }
 
@@ -648,22 +645,34 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
   if (op == INTRINSIC_ASSIGN)
     {
       if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
-	gfc_error ("First argument of defined assignment at %L must be "
-		   "INTENT(OUT) or INTENT(INOUT)", &intr->sym->declared_at);
+	{
+	  gfc_error ("First argument of defined assignment at %L must be "
+		     "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
+	  return false;
+	}
 
       if (i2 != INTENT_IN)
-	gfc_error ("Second argument of defined assignment at %L must be "
-		   "INTENT(IN)", &intr->sym->declared_at);
+	{
+	  gfc_error ("Second argument of defined assignment at %L must be "
+		     "INTENT(IN)", &sym->declared_at);
+	  return false;
+	}
     }
   else
     {
       if (i1 != INTENT_IN)
-	gfc_error ("First argument of operator interface at %L must be "
-		   "INTENT(IN)", &intr->sym->declared_at);
+	{
+	  gfc_error ("First argument of operator interface at %L must be "
+		     "INTENT(IN)", &sym->declared_at);
+	  return false;
+	}
 
       if (args == 2 && i2 != INTENT_IN)
-	gfc_error ("Second argument of operator interface at %L must be "
-		   "INTENT(IN)", &intr->sym->declared_at);
+	{
+	  gfc_error ("Second argument of operator interface at %L must be "
+		     "INTENT(IN)", &sym->declared_at);
+	  return false;
+	}
     }
 
   /* From now on, all we have to do is check that the operator definition
@@ -686,7 +695,7 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
       if (t1 == BT_LOGICAL)
 	goto bad_repl;
       else
-	return;
+	return true;
     }
 
   if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
@@ -694,20 +703,20 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
       if (IS_NUMERIC_TYPE (t1))
 	goto bad_repl;
       else
-	return;
+	return true;
     }
 
   /* Character intrinsic operators have same character kind, thus
      operator definitions with operands of different character kinds
      are always safe.  */
   if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
-    return;
+    return true;
 
   /* Intrinsic operators always perform on arguments of same rank,
      so different ranks is also always safe.  (rank == 0) is an exception
      to that, because all intrinsic operators are elemental.  */
   if (r1 != r2 && r1 != 0 && r2 != 0)
-    return;
+    return true;
 
   switch (op)
   {
@@ -760,14 +769,14 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
       break;
   }
 
-  return;
+  return true;
 
 #undef IS_NUMERIC_TYPE
 
 bad_repl:
   gfc_error ("Operator interface at %L conflicts with intrinsic interface",
-	     &intr->where);
-  return;
+	     &opwhere);
+  return false;
 }
 
 
@@ -1229,7 +1238,9 @@ gfc_check_interfaces (gfc_namespace *ns)
       if (check_interface0 (ns->op[i], interface_name))
 	continue;
 
-      check_operator_interface (ns->op[i], (gfc_intrinsic_op) i);
+      if (ns->op[i])
+	gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
+				      ns->op[i]->where);
 
       for (ns2 = ns; ns2; ns2 = ns2->parent)
 	{
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 81c8ccd..5c43704 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8793,37 +8793,27 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
 }
 
 
-/* Resolve a GENERIC procedure binding for a derived type.  */
+/* Worker function for resolving a generic procedure binding; this is used to
+   resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
+
+   The difference between those cases is finding possible inherited bindings
+   that are overridden, as one has to look for them in tb_sym_root,
+   tb_uop_root or tb_op, respectively.  Thus the caller must already find
+   the super-type and set p->overridden correctly.  */
 
 static gfc_try
-resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
+resolve_tb_generic_targets (gfc_symbol* super_type,
+			    gfc_typebound_proc* p, const char* name)
 {
   gfc_tbp_generic* target;
   gfc_symtree* first_target;
-  gfc_symbol* super_type;
   gfc_symtree* inherited;
-  locus where;
-
-  gcc_assert (st->n.tb);
-  gcc_assert (st->n.tb->is_generic);
-
-  where = st->n.tb->where;
-  super_type = gfc_get_derived_super_type (derived);
-
-  /* Find the overridden binding if any.  */
-  st->n.tb->overridden = NULL;
-  if (super_type)
-    {
-      gfc_symtree* overridden;
-      overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
 
-      if (overridden && overridden->n.tb)
-	st->n.tb->overridden = overridden->n.tb;
-    }
+  gcc_assert (p && p->is_generic);
 
   /* Try to find the specific bindings for the symtrees in our target-list.  */
-  gcc_assert (st->n.tb->u.generic);
-  for (target = st->n.tb->u.generic; target; target = target->next)
+  gcc_assert (p->u.generic);
+  for (target = p->u.generic; target; target = target->next)
     if (!target->specific)
       {
 	gfc_typebound_proc* overridden_tbp;
@@ -8854,7 +8844,7 @@ resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
 	  }
 
 	gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
-		   " at %L", target_name, st->name, &where);
+		   " at %L", target_name, name, &p->where);
 	return FAILURE;
 
 	/* Once we've found the specific binding, check it is not ambiguous with
@@ -8866,19 +8856,19 @@ specific_found:
 	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);
+		       " '%s' is GENERIC, too", name, &p->where, target_name);
 	    return FAILURE;
 	  }
 
 	/* Check those already resolved on this type directly.  */
-	for (g = st->n.tb->u.generic; g; g = g->next)
+	for (g = p->u.generic; g; g = g->next)
 	  if (g != target && g->specific
-	      && check_generic_tbp_ambiguity (target, g, st->name, where)
+	      && check_generic_tbp_ambiguity (target, g, name, p->where)
 		  == FAILURE)
 	    return FAILURE;
 
 	/* Check for ambiguity with inherited specific targets.  */
-	for (overridden_tbp = st->n.tb->overridden; overridden_tbp;
+	for (overridden_tbp = p->overridden; overridden_tbp;
 	     overridden_tbp = overridden_tbp->overridden)
 	  if (overridden_tbp->is_generic)
 	    {
@@ -8886,36 +8876,167 @@ specific_found:
 		{
 		  gcc_assert (g->specific);
 		  if (check_generic_tbp_ambiguity (target, g,
-						   st->name, where) == FAILURE)
+						   name, p->where) == FAILURE)
 		    return FAILURE;
 		}
 	    }
       }
 
   /* If we attempt to "overwrite" a specific binding, this is an error.  */
-  if (st->n.tb->overridden && !st->n.tb->overridden->is_generic)
+  if (p->overridden && !p->overridden->is_generic)
     {
       gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
-		 " the same name", st->name, &where);
+		 " the same name", name, &p->where);
       return FAILURE;
     }
 
   /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
      all must have the same attributes here.  */
-  first_target = st->n.tb->u.generic->specific->u.specific;
+  first_target = p->u.generic->specific->u.specific;
   gcc_assert (first_target);
-  st->n.tb->subroutine = first_target->n.sym->attr.subroutine;
-  st->n.tb->function = first_target->n.sym->attr.function;
+  p->subroutine = first_target->n.sym->attr.subroutine;
+  p->function = first_target->n.sym->attr.function;
 
   return SUCCESS;
 }
 
 
-/* Resolve the type-bound procedures for a derived type.  */
+/* Resolve a GENERIC procedure binding for a derived type.  */
+
+static gfc_try
+resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
+{
+  gfc_symbol* super_type;
+
+  /* Find the overridden binding if any.  */
+  st->n.tb->overridden = NULL;
+  super_type = gfc_get_derived_super_type (derived);
+  if (super_type)
+    {
+      gfc_symtree* overridden;
+      overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
+
+      if (overridden && overridden->n.tb)
+	st->n.tb->overridden = overridden->n.tb;
+    }
+
+  /* Resolve using worker function.  */
+  return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
+}
+
+
+/* Resolve a type-bound intrinsic operator.  */
+
+static gfc_try
+resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
+				gfc_typebound_proc* p)
+{
+  gfc_symbol* super_type;
+  gfc_tbp_generic* target;
+  
+  /* If there's already an error here, do nothing (but don't fail again).  */
+  if (p->error)
+    return SUCCESS;
+
+  /* Operators should always be GENERIC bindings.  */
+  gcc_assert (p->is_generic);
+
+  /* Look for an overridden binding.  */
+  super_type = gfc_get_derived_super_type (derived);
+  if (super_type && super_type->f2k_derived)
+    p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
+						     op, true);
+  else
+    p->overridden = NULL;
+
+  /* Resolve general GENERIC properties using worker function.  */
+  if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
+    goto error;
+
+  /* Check the targets to be procedures of correct interface.  */
+  for (target = p->u.generic; target; target = target->next)
+    {
+      gfc_symbol* target_proc;
+
+      gcc_assert (target->specific && !target->specific->is_generic);
+      target_proc = target->specific->u.specific->n.sym;
+      gcc_assert (target_proc);
+
+      if (!gfc_check_operator_interface (target_proc, op, p->where))
+	return FAILURE;
+    }
+
+  return SUCCESS;
+
+error:
+  p->error = 1;
+  return FAILURE;
+}
+
+
+/* Resolve a type-bound user operator (tree-walker callback).  */
 
 static gfc_symbol* resolve_bindings_derived;
 static gfc_try resolve_bindings_result;
 
+static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
+
+static void
+resolve_typebound_user_op (gfc_symtree* stree)
+{
+  gfc_symbol* super_type;
+  gfc_tbp_generic* target;
+
+  gcc_assert (stree && stree->n.tb);
+
+  if (stree->n.tb->error)
+    return;
+
+  /* Operators should always be GENERIC bindings.  */
+  gcc_assert (stree->n.tb->is_generic);
+
+  /* Find overridden procedure, if any.  */
+  super_type = gfc_get_derived_super_type (resolve_bindings_derived);
+  if (super_type && super_type->f2k_derived)
+    {
+      gfc_symtree* overridden;
+      overridden = gfc_find_typebound_user_op (super_type, NULL,
+					       stree->name, true);
+
+      if (overridden && overridden->n.tb)
+	stree->n.tb->overridden = overridden->n.tb;
+    }
+  else
+    stree->n.tb->overridden = NULL;
+
+  /* Resolve basically using worker function.  */
+  if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
+	== FAILURE)
+    goto error;
+
+  /* Check the targets to be functions of correct interface.  */
+  for (target = stree->n.tb->u.generic; target; target = target->next)
+    {
+      gfc_symbol* target_proc;
+
+      gcc_assert (target->specific && !target->specific->is_generic);
+      target_proc = target->specific->u.specific->n.sym;
+      gcc_assert (target_proc);
+
+      if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
+	goto error;
+    }
+
+  return;
+
+error:
+  resolve_bindings_result = FAILURE;
+  stree->n.tb->error = 1;
+}
+
+
+/* Resolve the type-bound procedures for a derived type.  */
+
 static void
 resolve_typebound_procedure (gfc_symtree* stree)
 {
@@ -9082,13 +9203,42 @@ error:
 static gfc_try
 resolve_typebound_procedures (gfc_symbol* derived)
 {
+  int op;
+  bool found_op;
+
   if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
     return SUCCESS;
 
   resolve_bindings_derived = derived;
   resolve_bindings_result = SUCCESS;
-  gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
-			&resolve_typebound_procedure);
+
+  if (derived->f2k_derived->tb_sym_root)
+    gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
+			  &resolve_typebound_procedure);
+
+  found_op = (derived->f2k_derived->tb_uop_root != NULL);
+  if (derived->f2k_derived->tb_uop_root)
+    gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
+			  &resolve_typebound_user_op);
+
+  for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
+    {
+      gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
+      if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
+					       p) == FAILURE)
+	resolve_bindings_result = FAILURE;
+      if (p)
+	found_op = true;
+    }
+
+  /* FIXME: Remove this (and found_op) once calls are fully implemented.  */
+  if (found_op)
+    {
+      gfc_error ("Derived type '%s' at %L contains type-bound OPERATOR's,"
+		 " they are not yet implemented.",
+		 derived->name, &derived->declared_at);
+      resolve_bindings_result = FAILURE;
+    }
 
   return resolve_bindings_result;
 }
@@ -11063,67 +11213,94 @@ resolve_fntype (gfc_namespace *ns)
       }
 }
 
+
 /* 12.3.2.1.1 Defined operators.  */
 
-static void
-gfc_resolve_uops (gfc_symtree *symtree)
+static gfc_try
+check_uop_procedure (gfc_symbol *sym, locus where)
 {
-  gfc_interface *itr;
-  gfc_symbol *sym;
   gfc_formal_arglist *formal;
 
-  if (symtree == NULL)
-    return;
+  if (!sym->attr.function)
+    {
+      gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
+		 sym->name, &where);
+      return FAILURE;
+    }
 
-  gfc_resolve_uops (symtree->left);
-  gfc_resolve_uops (symtree->right);
+  if (sym->ts.type == BT_CHARACTER
+      && !(sym->ts.cl && sym->ts.cl->length)
+      && !(sym->result && sym->result->ts.cl
+	   && sym->result->ts.cl->length))
+    {
+      gfc_error ("User operator procedure '%s' at %L cannot be assumed "
+		 "character length", sym->name, &where);
+      return FAILURE;
+    }
 
-  for (itr = symtree->n.uop->op; itr; itr = itr->next)
+  formal = sym->formal;
+  if (!formal || !formal->sym)
     {
-      sym = itr->sym;
-      if (!sym->attr.function)
-	gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
-		   sym->name, &sym->declared_at);
+      gfc_error ("User operator procedure '%s' at %L must have at least "
+		 "one argument", sym->name, &where);
+      return FAILURE;
+    }
 
-      if (sym->ts.type == BT_CHARACTER
-	  && !(sym->ts.cl && sym->ts.cl->length)
-	  && !(sym->result && sym->result->ts.cl
-	       && sym->result->ts.cl->length))
-	gfc_error ("User operator procedure '%s' at %L cannot be assumed "
-		   "character length", sym->name, &sym->declared_at);
+  if (formal->sym->attr.intent != INTENT_IN)
+    {
+      gfc_error ("First argument of operator interface at %L must be "
+		 "INTENT(IN)", &where);
+      return FAILURE;
+    }
 
-      formal = sym->formal;
-      if (!formal || !formal->sym)
-	{
-	  gfc_error ("User operator procedure '%s' at %L must have at least "
-		     "one argument", sym->name, &sym->declared_at);
-	  continue;
-	}
+  if (formal->sym->attr.optional)
+    {
+      gfc_error ("First argument of operator interface at %L cannot be "
+		 "optional", &where);
+      return FAILURE;
+    }
 
-      if (formal->sym->attr.intent != INTENT_IN)
-	gfc_error ("First argument of operator interface at %L must be "
-		   "INTENT(IN)", &sym->declared_at);
+  formal = formal->next;
+  if (!formal || !formal->sym)
+    return SUCCESS;
 
-      if (formal->sym->attr.optional)
-	gfc_error ("First argument of operator interface at %L cannot be "
-		   "optional", &sym->declared_at);
+  if (formal->sym->attr.intent != INTENT_IN)
+    {
+      gfc_error ("Second argument of operator interface at %L must be "
+		 "INTENT(IN)", &where);
+      return FAILURE;
+    }
 
-      formal = formal->next;
-      if (!formal || !formal->sym)
-	continue;
+  if (formal->sym->attr.optional)
+    {
+      gfc_error ("Second argument of operator interface at %L cannot be "
+		 "optional", &where);
+      return FAILURE;
+    }
 
-      if (formal->sym->attr.intent != INTENT_IN)
-	gfc_error ("Second argument of operator interface at %L must be "
-		   "INTENT(IN)", &sym->declared_at);
+  if (formal->next)
+    {
+      gfc_error ("Operator interface at %L must have, at most, two "
+		 "arguments", &where);
+      return FAILURE;
+    }
 
-      if (formal->sym->attr.optional)
-	gfc_error ("Second argument of operator interface at %L cannot be "
-		   "optional", &sym->declared_at);
+  return SUCCESS;
+}
 
-      if (formal->next)
-	gfc_error ("Operator interface at %L must have, at most, two "
-		   "arguments", &sym->declared_at);
-    }
+static void
+gfc_resolve_uops (gfc_symtree *symtree)
+{
+  gfc_interface *itr;
+
+  if (symtree == NULL)
+    return;
+
+  gfc_resolve_uops (symtree->left);
+  gfc_resolve_uops (symtree->right);
+
+  for (itr = symtree->n.uop->op; itr; itr = itr->next)
+    check_uop_procedure (itr->sym, itr->sym->declared_at);
 }
 
 
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index b86afc0..c2666ae 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2220,7 +2220,10 @@ gfc_get_namespace (gfc_namespace *parent, int parent_types)
   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++)
@@ -2948,7 +2951,6 @@ free_common_tree (gfc_symtree * common_tree)
 static void
 free_uop_tree (gfc_symtree *uop_tree)
 {
-
   if (uop_tree == NULL)
     return;
 
@@ -2956,7 +2958,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);
 }
@@ -3128,6 +3129,7 @@ gfc_free_namespace (gfc_namespace *ns)
   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);
@@ -4519,22 +4521,27 @@ gfc_get_derived_super_type (gfc_symbol* derived)
 }
 
 
-/* Find a type-bound procedure by name for a derived-type (looking recursively
-   through the super-types).  */
+/* General worker function to find either a type-bound procedure or a
+   type-bound user operator.  */
 
-gfc_symtree*
-gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
-			 const char* name, bool noaccess)
+static gfc_symtree*
+find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
+			 const char* name, bool noaccess, bool uop)
 {
   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.  */
-  gcc_assert (derived->f2k_derived);
-  res = gfc_find_symtree (derived->f2k_derived->tb_sym_root, name);
+  res = gfc_find_symtree (root, name);
   if (res && res->n.tb)
     {
       /* We found one.  */
@@ -4558,7 +4565,79 @@ 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 find_typebound_proc_uop (super_type, t, name, noaccess, uop);
+    }
+
+  /* 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)
+{
+  return find_typebound_proc_uop (derived, t, name, noaccess, false);
+}
+
+gfc_symtree*
+gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
+			    const char* name, bool noaccess)
+{
+  return find_typebound_proc_uop (derived, t, name, noaccess, true);
+}
+
+
+/* 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)
+{
+  gfc_typebound_proc* res;
+
+  /* Set default to failure.  */
+  if (t)
+    *t = FAILURE;
+
+  /* Try to find it in the current type's namespace.  */
+  if (derived->f2k_derived)
+    res = derived->f2k_derived->tb_op[op];
+  else  
+    res = NULL;
+
+  /* Check access.  */
+  if (res)
+    {
+      /* We found one.  */
+      if (t)
+	*t = SUCCESS;
+
+      if (!noaccess && derived->attr.use_assoc
+	  && res->access == ACCESS_PRIVATE)
+	{
+	  gfc_error ("'%s' of '%s' is PRIVATE at %C",
+		     gfc_op2string (op), derived->name);
+	  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 gfc_find_typebound_intrinsic_op (super_type, t, op, noaccess);
     }
 
   /* Nothing found.  */