diff options
| author | Janus Weil <janus@gcc.gnu.org> | 2011-08-07 12:12:09 +0200 |
|---|---|---|
| committer | Janus Weil <janus@gcc.gnu.org> | 2011-08-07 12:12:09 +0200 |
| commit | 99fc1b90cda7c80de9a1b7fdb3261185604c7586 (patch) | |
| tree | 609c767e03ac951170167c3efe780f0cf1058588 /gcc/fortran/interface.c | |
| parent | f446d60e814fdafc3bd7b11b748f2faeb0012a5a (diff) | |
| download | gcc-99fc1b90cda7c80de9a1b7fdb3261185604c7586.zip gcc-99fc1b90cda7c80de9a1b7fdb3261185604c7586.tar.gz gcc-99fc1b90cda7c80de9a1b7fdb3261185604c7586.tar.bz2 | |
re PR fortran/49638 ([OOP] length parameter is ignored when overriding type bound character functions with constant length.)
2011-08-07 Janus Weil <janus@gcc.gnu.org>
PR fortran/49638
* dependency.h (gfc_is_same_range,gfc_are_identical_variables): Remove
two prototypes.
* dependency.c (gfc_are_identical_variables,are_identical_variables):
Renamed the former to the latter and made static.
(gfc_dep_compare_expr): Renamed 'gfc_are_identical_variables', handle
commutativity of multiplication.
(gfc_is_same_range,is_same_range): Renamed the former to the latter,
made static and removed argument 'def'.
(check_section_vs_section): Renamed 'gfc_is_same_range'.
* gfortran.h (gfc_check_typebound_override): New prototype.
* interface.c (gfc_check_typebound_override): Moved here from ...
* resolve.c (check_typebound_override): ... here (and renamed).
(resolve_typebound_procedure): Renamed 'check_typebound_override'.
From-SVN: r177545
Diffstat (limited to 'gcc/fortran/interface.c')
| -rw-r--r-- | gcc/fortran/interface.c | 194 |
1 files changed, 194 insertions, 0 deletions
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 482a75e..8998072 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -3466,3 +3466,197 @@ gfc_free_formal_arglist (gfc_formal_arglist *p) free (p); } } + + +/* Check that it is ok for the typebound procedure proc to override the + procedure old. */ + +gfc_try +gfc_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; +} |