-/* 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;
-
- /* This procedure should only be called for non-GENERIC proc. */
- gcc_assert (!proc->n.tb->is_generic);
-
- /* If the overwritten procedure is GENERIC, this is an error. */
- if (old->n.tb->is_generic)
- {
- gfc_error ("Can't overwrite GENERIC '%s' at %L",
- old->name, &proc->n.tb->where);
- return FAILURE;
- }
-
- where = proc->n.tb->where;
- proc_target = proc->n.tb->u.specific->n.sym;
- old_target = old->n.tb->u.specific->n.sym;
-
- /* Check that overridden binding is not NON_OVERRIDABLE. */
- if (old->n.tb->non_overridable)
- {
- gfc_error ("'%s' at %L overrides a procedure binding declared"
- " NON_OVERRIDABLE", proc->name, &where);
- return FAILURE;
- }
-
- /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
- if (!old->n.tb->deferred && proc->n.tb->deferred)
- {
- gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
- " non-DEFERRED binding", 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->n.tb->access == ACCESS_PUBLIC
- && proc->n.tb->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->n.tb->nopass && !proc->n.tb->pass_arg)
- proc_pass_arg = 1;
- if (!old->n.tb->nopass && !old->n.tb->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->n.tb->pass_arg
- && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
- proc_pass_arg = argpos;
- if (old->n.tb->pass_arg
- && !strcmp (old->n.tb->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 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->n.tb->nopass && !proc->n.tb->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->n.tb->nopass)
- {
- if (proc->n.tb->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;
-}
-
-