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

1 files changed, 96 insertions, 17 deletions

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;
 	  }