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

gcc/fortran/ChangeLog

+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

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

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;

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)
 	{

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.  */

gcc/testsuite/ChangeLog

+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  Richard Guenther  <rguenther@suse.de>
 
 	PR middle-end/41006

gcc/testsuite/gfortran.dg/typebound_operator_1.f03

+! { dg-do compile }
+! { dg-options "-w" }
+! FIXME: Remove -w once CLASS is fully supported.
+
+! Type-bound procedures
+! Check correct type-bound operator definitions.
+
+MODULE m
+  IMPLICIT NONE
+
+  TYPE t ! { dg-error "not yet implemented" }
+  CONTAINS
+    PROCEDURE, PASS :: onearg
+    PROCEDURE, PASS :: twoarg1
+    PROCEDURE, PASS :: twoarg2
+    PROCEDURE, PASS(me) :: assign_proc
+
+    GENERIC :: OPERATOR(.BINARY.) => twoarg1, twoarg2
+    GENERIC :: OPERATOR(.UNARY.) => onearg
+    GENERIC :: ASSIGNMENT(=) => assign_proc
+  END TYPE t
+
+CONTAINS
+
+  INTEGER FUNCTION onearg (me)
+    CLASS(t), INTENT(IN) :: me
+    onearg = 5
+  END FUNCTION onearg
+
+  INTEGER FUNCTION twoarg1 (me, a)
+    CLASS(t), INTENT(IN) :: me
+    INTEGER, INTENT(IN) :: a
+    twoarg1 = 42
+  END FUNCTION twoarg1
+
+  INTEGER FUNCTION twoarg2 (me, a)
+    CLASS(t), INTENT(IN) :: me
+    REAL, INTENT(IN) :: a
+    twoarg2 = 123
+  END FUNCTION twoarg2
+
+  SUBROUTINE assign_proc (me, b)
+    CLASS(t), INTENT(OUT) :: me
+    CLASS(t), INTENT(IN) :: b
+    me = t ()
+  END SUBROUTINE assign_proc
+
+END MODULE m
+
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/typebound_operator_2.f03

+! { dg-do compile }
+! { dg-options "-w" }
+! FIXME: Remove -w once CLASS is fully supported.
+
+! Type-bound procedures
+! Checks for correct errors with invalid OPERATOR/ASSIGNMENT usage.
+
+MODULE m
+  IMPLICIT NONE
+
+  TYPE t ! { dg-error "not yet implemented" }
+  CONTAINS
+    PROCEDURE, PASS :: onearg
+    PROCEDURE, PASS :: onearg_alt => onearg
+    PROCEDURE, PASS :: onearg_alt2 => onearg
+    PROCEDURE, PASS :: threearg
+    PROCEDURE, NOPASS :: noarg
+    PROCEDURE, PASS :: sub
+    PROCEDURE, PASS :: sub2 ! { dg-error "must be a FUNCTION" }
+    PROCEDURE, PASS :: func
+
+    ! These give errors at the targets' definitions.
+    GENERIC :: OPERATOR(.AND.) => sub2
+    GENERIC :: OPERATOR(*) => onearg
+    GENERIC :: ASSIGNMENT(=) => func
+
+    GENERIC :: OPERATOR(.UOPA.) => sub ! { dg-error "must be a FUNCTION" }
+    GENERIC :: OPERATOR(.UOPB.) => threearg ! { dg-error "at most, two arguments" }
+    GENERIC :: OPERATOR(.UOPC.) => noarg ! { dg-error "at least one argument" }
+
+    GENERIC :: OPERATOR(.UNARY.) => onearg_alt
+    GENERIC, PRIVATE :: OPERATOR(.UNARY.) => onearg_alt2 ! { dg-error "must have the same access" }
+  END TYPE t
+
+CONTAINS
+
+  INTEGER FUNCTION onearg (me) ! { dg-error "wrong number of arguments" }
+    CLASS(t), INTENT(IN) :: me
+    onearg = 5
+  END FUNCTION onearg
+
+  INTEGER FUNCTION threearg (a, b, c)
+    CLASS(t), INTENT(IN) :: a, b, c
+    threearg = 42
+  END FUNCTION threearg
+
+  INTEGER FUNCTION noarg ()
+    noarg = 42
+  END FUNCTION noarg
+
+  LOGICAL FUNCTION func (me, b) ! { dg-error "must be a SUBROUTINE" }
+    CLASS(t), INTENT(OUT) :: me
+    CLASS(t), INTENT(IN) :: b
+    me = t ()
+    func = .TRUE.
+  END FUNCTION func
+
+  SUBROUTINE sub (a)
+    CLASS(t), INTENT(IN) :: a
+  END SUBROUTINE sub
+
+  SUBROUTINE sub2 (a, x)
+    CLASS(t), INTENT(IN) :: a
+    INTEGER, INTENT(IN) :: x
+  END SUBROUTINE sub2
+
+END MODULE m
+
+! { dg-final { cleanup-modules "m" } }