From patchwork Sat Aug 6 18:19:30 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Janus Weil X-Patchwork-Id: 108792 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 9F4CDB6F7A for ; Sun, 7 Aug 2011 04:20:10 +1000 (EST) Received: (qmail 19943 invoked by alias); 6 Aug 2011 18:20:06 -0000 Received: (qmail 19906 invoked by uid 22791); 6 Aug 2011 18:20:01 -0000 X-SWARE-Spam-Status: No, hits=0.1 required=5.0 tests=AWL, BAYES_80, DKIM_SIGNED, DKIM_VALID, FREEMAIL_ENVFROM_END_DIGIT, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW X-Spam-Check-By: sourceware.org Received: from mail-gy0-f175.google.com (HELO mail-gy0-f175.google.com) (209.85.160.175) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sat, 06 Aug 2011 18:19:31 +0000 Received: by gyg4 with SMTP id 4so2068426gyg.20 for ; Sat, 06 Aug 2011 11:19:30 -0700 (PDT) MIME-Version: 1.0 Received: by 10.236.78.102 with SMTP id f66mr4728030yhe.7.1312654770555; Sat, 06 Aug 2011 11:19:30 -0700 (PDT) Received: by 10.147.137.10 with HTTP; Sat, 6 Aug 2011 11:19:30 -0700 (PDT) In-Reply-To: <201108061946.35514.mikael.morin@sfr.fr> References: <201108061946.35514.mikael.morin@sfr.fr> Date: Sat, 6 Aug 2011 20:19:30 +0200 Message-ID: Subject: Re: [Patch, Fortran, OOP] PR 49638: [OOP] length parameter is ignored when overriding type bound character functions with constant length. From: Janus Weil To: Mikael Morin Cc: fortran@gcc.gnu.org, Thomas Koenig , gcc-patches Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 2011/8/6 Mikael Morin : > On Saturday 06 August 2011 19:10:09 Janus Weil wrote: >> Now, if Thomas says it's fine for the other cases, too, then it seems >> we can really get away with a much simpler patch. Hope we're not >> missing anything, though ... >> > > What about this case: two module variables from two different modules? Yeah, ok. So we *do* need to distinguish between dummies and other variables, but maybe we can still get by without additional 'var_name_only' arguments (new patch attached). Cheers, Janus Index: gcc/fortran/interface.c =================================================================== --- gcc/fortran/interface.c (revision 177528) +++ gcc/fortran/interface.c (working copy) @@ -3466,3 +3466,207 @@ 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' (F08:4.5.7.3). */ + +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 array shape). */ + gcc_assert (proc_target->result && old_target->result); + if (!compare_type_rank (proc_target->result, old_target->result)) + { + gfc_error ("'%s' at %L and the overridden FUNCTION should have" + " matching result types and ranks", proc->name, &where); + return FAILURE; + } + + /* Check string length. */ + if (proc_target->result->ts.type == BT_CHARACTER + && proc_target->result->ts.u.cl && old_target->result->ts.u.cl + && gfc_dep_compare_expr (proc_target->result->ts.u.cl->length, + old_target->result->ts.u.cl->length) != 0) + { + gfc_error ("Character length mismatch between '%s' at '%L' " + "and overridden FUNCTION", 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; +} Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (revision 177528) +++ gcc/fortran/gfortran.h (working copy) @@ -2840,6 +2840,7 @@ bool gfc_arglist_matches_symbol (gfc_actual_arglis 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; Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 177528) +++ gcc/fortran/resolve.c (working copy) @@ -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. */ Index: gcc/fortran/dependency.c =================================================================== --- gcc/fortran/dependency.c (revision 177528) +++ gcc/fortran/dependency.c (working copy) @@ -118,13 +118,23 @@ identical_array_ref (gfc_array_ref *a1, gfc_array_ /* 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; - if (e1->symtree->n.sym != e2->symtree->n.sym) - return false; + if (e1->symtree->n.sym->attr.dummy && e2->symtree->n.sym->attr.dummy) + { + /* Dummy arguments: Only check for equal names. */ + if (e1->symtree->n.sym->name != e2->symtree->n.sym->name) + return false; + } + else + { + /* Check for equal symbols. */ + if (e1->symtree->n.sym != e2->symtree->n.sym) + return false; + } /* Volatile variables should never compare equal to themselves. */ @@ -169,7 +179,7 @@ identical_array_ref (gfc_array_ref *a1, gfc_array_ 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 +431,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 +448,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 +466,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 +487,19 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) 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 +518,10 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) /* 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 +539,10 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) /* 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 +1096,7 @@ check_section_vs_section (gfc_array_ref *l_ar, gfc 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]; Index: gcc/fortran/dependency.h =================================================================== --- gcc/fortran/dependency.h (revision 177528) +++ gcc/fortran/dependency.h (working copy) @@ -37,11 +37,8 @@ gfc_expr *gfc_get_noncopying_intrinsic_argument (g 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_is_same_range (gfc_array_ref *, gfc_array_ref *, int, bool);*/ 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 *); -