+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected generic name or operator descriptor at %C");
+ goto error;
+ }
+
+ switch (op_type)
+ {
+ 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",
+ 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'", bind_name);
+ goto error;
+ }
+ }
+ else
+ {
+ 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. */
+ do
+ {
+ gfc_symtree* target_st;
+ gfc_tbp_generic* target;
+
+ m = gfc_match_name (name);
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected specific binding name at %C");
+ goto error;
+ }
+
+ target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
+
+ /* See if this is a duplicate specification. */
+ for (target = tb->u.generic; target; target = target->next)
+ if (target_st == target->specific_st)
+ {
+ gfc_error ("'%s' already defined as specific binding for the"
+ " generic '%s' at %C", name, bind_name);
+ goto error;
+ }
+
+ target = gfc_get_tbp_generic ();
+ target->specific_st = target_st;
+ target->specific = NULL;
+ target->next = tb->u.generic;
+ tb->u.generic = target;
+ }
+ while (gfc_match (" ,") == MATCH_YES);
+
+ /* Here should be the end. */
+ if (gfc_match_eos () != MATCH_YES)
+ {
+ gfc_error ("Junk after GENERIC binding at %C");
+ goto error;
+ }