From 99fc1b90cda7c80de9a1b7fdb3261185604c7586 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Sun, 7 Aug 2011 12:12:09 +0200 Subject: [PATCH] re PR fortran/49638 ([OOP] length parameter is ignored when overriding type bound character functions with constant length.) 2011-08-07 Janus Weil 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 --- gcc/fortran/ChangeLog | 17 ++++ gcc/fortran/dependency.c | 49 +++++----- gcc/fortran/dependency.h | 4 - gcc/fortran/gfortran.h | 1 + gcc/fortran/interface.c | 194 ++++++++++++++++++++++++++++++++++++ gcc/fortran/resolve.c | 205 ++------------------------------------- 6 files changed, 241 insertions(+), 229 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 81eec356b50..0c38317ed5d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,20 @@ +2011-08-07 Janus Weil + + 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'. + 2011-08-06 Thomas Koenig PR fortran/50004 diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index cb5d10ca84b..b49cf5424ca 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -118,8 +118,8 @@ identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2) /* Return true for identical variables, checking for references if necessary. Calls identical_array_ref for checking array sections. */ -bool -gfc_are_identical_variables (gfc_expr *e1, gfc_expr *e2) +static bool +are_identical_variables (gfc_expr *e1, gfc_expr *e2) { gfc_ref *r1, *r2; @@ -169,7 +169,7 @@ gfc_are_identical_variables (gfc_expr *e1, gfc_expr *e2) break; default: - gfc_internal_error ("gfc_are_identical_variables: Bad type"); + gfc_internal_error ("are_identical_variables: Bad type"); } r1 = r1->next; r2 = r2->next; @@ -421,7 +421,7 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) return 1; case EXPR_VARIABLE: - if (gfc_are_identical_variables (e1, e2)) + if (are_identical_variables (e1, e2)) return 0; else return -2; @@ -438,7 +438,12 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0 && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0) return 0; - /* TODO Handle commutative binary operators here? */ + else if (e1->value.op.op == INTRINSIC_TIMES + && gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2) == 0 + && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1) == 0) + /* Commutativity of multiplication. */ + return 0; + return -2; case EXPR_FUNCTION: @@ -451,11 +456,11 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) } -/* Returns 1 if the two ranges are the same, 0 if they are not, and def - if the results are indeterminate. N is the dimension to compare. */ +/* Returns 1 if the two ranges are the same and 0 if they are not (or if the + results are indeterminate). 'n' is the dimension to compare. */ -int -gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def) +static int +is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n) { gfc_expr *e1; gfc_expr *e2; @@ -472,25 +477,19 @@ gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def) if (e1 && !e2) { i = gfc_expr_is_one (e1, -1); - if (i == -1) - return def; - else if (i == 0) + if (i == -1 || i == 0) return 0; } else if (e2 && !e1) { i = gfc_expr_is_one (e2, -1); - if (i == -1) - return def; - else if (i == 0) + if (i == -1 || i == 0) return 0; } else if (e1 && e2) { i = gfc_dep_compare_expr (e1, e2); - if (i == -2) - return def; - else if (i != 0) + if (i != 0) return 0; } /* The strides match. */ @@ -509,12 +508,10 @@ gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def) /* Check we have values for both. */ if (!(e1 && e2)) - return def; + return 0; i = gfc_dep_compare_expr (e1, e2); - if (i == -2) - return def; - else if (i != 0) + if (i != 0) return 0; } @@ -532,12 +529,10 @@ gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def) /* Check we have values for both. */ if (!(e1 && e2)) - return def; + return 0; i = gfc_dep_compare_expr (e1, e2); - if (i == -2) - return def; - else if (i != 0) + if (i != 0) return 0; } @@ -1091,7 +1086,7 @@ check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n) int start_comparison; /* If they are the same range, return without more ado. */ - if (gfc_is_same_range (l_ar, r_ar, n, 0)) + if (is_same_range (l_ar, r_ar, n)) return GFC_DEP_EQUAL; l_start = l_ar->start[n]; diff --git a/gcc/fortran/dependency.h b/gcc/fortran/dependency.h index d58287d10d8..d56a7f726d2 100644 --- a/gcc/fortran/dependency.h +++ b/gcc/fortran/dependency.h @@ -37,11 +37,7 @@ gfc_expr *gfc_get_noncopying_intrinsic_argument (gfc_expr *); int gfc_check_fncall_dependency (gfc_expr *, sym_intent, gfc_symbol *, gfc_actual_arglist *, gfc_dep_check); int gfc_check_dependency (gfc_expr *, gfc_expr *, bool); -int gfc_is_same_range (gfc_array_ref *, gfc_array_ref *, int, int); int gfc_expr_is_one (gfc_expr *, int); int gfc_dep_resolver(gfc_ref *, gfc_ref *, gfc_reverse *); int gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *); - -bool gfc_are_identical_variables (gfc_expr *, gfc_expr *); - diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 34afae43386..b4a4f8593ee 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2840,6 +2840,7 @@ bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*); bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus); int gfc_has_vector_subscript (gfc_expr*); gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op); +gfc_try gfc_check_typebound_override (gfc_symtree*, gfc_symtree*); /* io.c */ extern gfc_st_label format_asterisk; diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 482a75e6fe0..899807231a2 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; +} diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index b8a8ebb8a34..6245666f620 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10672,200 +10672,6 @@ error: } -/* 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; -} - - /* Check if two GENERIC targets are ambiguous and emit an error is they are. */ static gfc_try @@ -11327,11 +11133,14 @@ resolve_typebound_procedure (gfc_symtree* stree) overridden = gfc_find_typebound_proc (super_type, NULL, stree->name, true, NULL); - if (overridden && overridden->n.tb) - stree->n.tb->overridden = overridden->n.tb; + if (overridden) + { + if (overridden->n.tb) + stree->n.tb->overridden = overridden->n.tb; - if (overridden && check_typebound_override (stree, overridden) == FAILURE) - goto error; + if (gfc_check_typebound_override (stree, overridden) == FAILURE) + goto error; + } } /* See if there's a name collision with a component directly in this type. */ -- 2.30.2