From patchwork Sun Sep 11 13:42:16 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Janus Weil X-Patchwork-Id: 114224 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 2F367B71E8 for ; Sun, 11 Sep 2011 23:42:40 +1000 (EST) Received: (qmail 5997 invoked by alias); 11 Sep 2011 13:42:34 -0000 Received: (qmail 5984 invoked by uid 22791); 11 Sep 2011 13:42:33 -0000 X-SWARE-Spam-Status: No, hits=-2.1 required=5.0 tests=AWL, BAYES_00, DKIM_SIGNED, DKIM_VALID, FREEMAIL_ENVFROM_END_DIGIT, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW X-Spam-Check-By: sourceware.org Received: from mail-wy0-f175.google.com (HELO mail-wy0-f175.google.com) (74.125.82.175) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sun, 11 Sep 2011 13:42:17 +0000 Received: by wyf19 with SMTP id 19so2775455wyf.20 for ; Sun, 11 Sep 2011 06:42:16 -0700 (PDT) MIME-Version: 1.0 Received: by 10.216.72.65 with SMTP id s43mr1978440wed.40.1315748536119; Sun, 11 Sep 2011 06:42:16 -0700 (PDT) Received: by 10.216.64.139 with HTTP; Sun, 11 Sep 2011 06:42:16 -0700 (PDT) In-Reply-To: References: Date: Sun, 11 Sep 2011 15:42:16 +0200 Message-ID: Subject: Re: [Patch, Fortran, OOP] PR 47978: Invalid INTENT in overriding TBP not detected From: Janus Weil To: gfortran , 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 Update: Here is an extended version of the patch, which adds a few additional checks: * a simple check for the array shape (not complete yet, but fixing at least comment #0 of PR 35831) * a check for the string length, as recently implemented for character results (PR49638) * furthermore it checks more of the attributes listed in 12.3.2 (I did not add test cases for those, and I would argue that we don't really need a test case for every single attribute) The patch still regtests cleanly. Ok for trunk? Or should I rather commit the simple version first? Cheers, Janus 2011-09-11 Janus Weil PR fortran/35831 PR fortran/47978 * interface.c (check_dummy_characteristics): New function to check the characteristics of dummy arguments. (gfc_compare_interfaces,gfc_check_typebound_override): Call it here. 2011-09-11 Janus Weil PR fortran/35831 PR fortran/47978 * gfortran.dg/dynamic_dispatch_5.f03: Fix invalid test case. * gfortran.dg/typebound_proc_6.f03: Changed wording in error message. * gfortran.dg/proc_decl_26.f90: New. * gfortran.dg/typebound_override_2.f90: New. 2011/9/9 Janus Weil : > Hi all, > > here is another small patch for an accepts-invalid OOP problem: When > overriding a type-bound procedure, we need to check that the intents > of the formal args agree (or more general: their 'characteristics', as > defined in chapter 12.3.2 of the F08 standard). For now I'm only > checking type+rank as well as the INTENT and OPTIONAL attributes, but > I added a FIXME for more comprehensive checking (which could be added > in a follow-up patch). > > On the technical side of things, I'm adding a new function > 'check_dummy_characteristics', which is called in two places: >  * gfc_compare_interfaces and >  * gfc_check_typebound_override. > > A slight subtlety is given by the fact that for the PASS argument, the > type of the argument does not have to agree when overriding. > > The improved checking also caught an invalid test case in the > testsuite (dynamic_dispatch_5), for another one the error message > changed slightly (typebound_proc_6). > > Regtested on x86_64-unknown-linux-gnu. Ok for trunk? > > Cheers, > Janus > > > 2011-09-09  Janus Weil   > >        PR fortran/47978 >        * interface.c (check_dummy_characteristics): New function to check the >        characteristics of dummy arguments. >        (gfc_compare_interfaces,gfc_check_typebound_override): Call it here. > > > 2011-09-09  Janus Weil   > >        PR fortran/47978 >        * gfortran.dg/dynamic_dispatch_5.f03: Fix invalid test case. >        * gfortran.dg/typebound_proc_6.f03: Changed wording in error message. >        * gfortran.dg/typebound_override_1.f90: New. > Index: gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 =================================================================== --- gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 (revision 178757) +++ gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 (working copy) @@ -56,7 +56,7 @@ module s_base_mat_mod contains subroutine s_scals(d,a,info) implicit none - class(s_base_sparse_mat), intent(in) :: a + class(s_base_sparse_mat), intent(inout) :: a real(spk_), intent(in) :: d integer, intent(out) :: info @@ -73,7 +73,7 @@ contains subroutine s_scal(d,a,info) implicit none - class(s_base_sparse_mat), intent(in) :: a + class(s_base_sparse_mat), intent(inout) :: a real(spk_), intent(in) :: d(:) integer, intent(out) :: info Index: gcc/testsuite/gfortran.dg/typebound_proc_6.f03 =================================================================== --- gcc/testsuite/gfortran.dg/typebound_proc_6.f03 (revision 178757) +++ gcc/testsuite/gfortran.dg/typebound_proc_6.f03 (working copy) @@ -89,7 +89,7 @@ MODULE testmod ! For corresponding dummy arguments. PROCEDURE, PASS :: corresp1 => proc_tmeint ! Ok. PROCEDURE, PASS :: corresp2 => proc_tmeintx ! { dg-error "should be named 'a'" } - PROCEDURE, PASS :: corresp3 => proc_tmereal ! { dg-error "Types mismatch for dummy argument 'a'" } + PROCEDURE, PASS :: corresp3 => proc_tmereal ! { dg-error "Type/rank mismatch in argument 'a'" } END TYPE t Index: gcc/fortran/interface.c =================================================================== --- gcc/fortran/interface.c (revision 178757) +++ gcc/fortran/interface.c (working copy) @@ -977,6 +977,113 @@ generic_correspondence (gfc_formal_arglist *f1, gf } +/* Check if the characteristics of two dummy arguments match, + cf. F08:12.3.2. */ + +static gfc_try +check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, + bool type_must_agree, char *errmsg, int err_len) +{ + /* Check type and rank. */ + if (type_must_agree && !compare_type_rank (s2, s1)) + { + if (errmsg != NULL) + snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'", + s1->name); + return FAILURE; + } + + /* Check INTENT. */ + if (s1->attr.intent != s2->attr.intent) + { + snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'", + s1->name); + return FAILURE; + } + + /* Check OPTIONAL attribute. */ + if (s1->attr.optional != s2->attr.optional) + { + snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'", + s1->name); + return FAILURE; + } + + /* Check ALLOCATABLE attribute. */ + if (s1->attr.allocatable != s2->attr.allocatable) + { + snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'", + s1->name); + return FAILURE; + } + + /* Check POINTER attribute. */ + if (s1->attr.pointer != s2->attr.pointer) + { + snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'", + s1->name); + return FAILURE; + } + + /* Check TARGET attribute. */ + if (s1->attr.target != s2->attr.target) + { + snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'", + s1->name); + return FAILURE; + } + + /* FIXME: Do more comprehensive testing of attributes, like e.g. + ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc. */ + + /* Check string length. */ + if (s1->ts.type == BT_CHARACTER + && s1->ts.u.cl && s1->ts.u.cl->length + && s2->ts.u.cl && s2->ts.u.cl->length) + { + int compval = gfc_dep_compare_expr (s1->ts.u.cl->length, + s2->ts.u.cl->length); + switch (compval) + { + case -1: + case 1: + case -3: + snprintf (errmsg, err_len, "Character length mismatch " + "in argument '%s'", s1->name); + return FAILURE; + + case -2: + /* FIXME: Implement a warning for this case. + gfc_warning ("Possible character length mismatch in argument '%s'", + s1->name);*/ + break; + + case 0: + break; + + default: + gfc_internal_error ("check_dummy_characteristics: Unexpected result " + "%i of gfc_dep_compare_expr", compval); + break; + } + } + + /* Check array shape. */ + if (s1->as && s2->as) + { + if (s1->as->type != s2->as->type) + { + snprintf (errmsg, err_len, "Shape mismatch in argument '%s'", + s1->name); + return FAILURE; + } + /* FIXME: Check exact shape. */ + } + + return SUCCESS; +} + + /* 'Compare' two formal interfaces associated with a pair of symbols. We return nonzero if there exists an actual argument list that would be ambiguous between the two interfaces, zero otherwise. @@ -1059,31 +1166,22 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol return 0; } - /* Check type and rank. */ - if (!compare_type_rank (f2->sym, f1->sym)) + if (intent_flag) { + /* Check all characteristics. */ + if (check_dummy_characteristics (f1->sym, f2->sym, + true, errmsg, err_len) == FAILURE) + return 0; + } + else if (!compare_type_rank (f2->sym, f1->sym)) + { + /* Only check type and rank. */ if (errmsg != NULL) snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'", f1->sym->name); return 0; } - /* Check INTENT. */ - if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent)) - { - snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'", - f1->sym->name); - return 0; - } - - /* Check OPTIONAL. */ - if (intent_flag && (f1->sym->attr.optional != f2->sym->attr.optional)) - { - snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'", - f1->sym->name); - return 0; - } - f1 = f1->next; f2 = f2->next; } @@ -3468,18 +3566,18 @@ gfc_free_formal_arglist (gfc_formal_arglist *p) } -/* Check that it is ok for the typebound procedure proc to override the - procedure old. */ +/* Check that it is ok for the type-bound procedure 'proc' to override the + procedure 'old', cf. 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; + const gfc_symbol *proc_target, *old_target; unsigned proc_pass_arg, old_pass_arg, argpos; - gfc_formal_arglist* proc_formal; - gfc_formal_arglist* old_formal; + gfc_formal_arglist *proc_formal, *old_formal; + bool check_type; + char err[200]; /* This procedure should only be called for non-GENERIC proc. */ gcc_assert (!proc->n.tb->is_generic); @@ -3637,15 +3735,12 @@ gfc_check_typebound_override (gfc_symtree* proc, g 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)) + check_type = proc_pass_arg != argpos && old_pass_arg != argpos; + if (check_dummy_characteristics (proc_formal->sym, old_formal->sym, + check_type, err, sizeof(err)) == FAILURE) { - gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L " - "in respect to the overridden procedure", - proc_formal->sym->name, proc->name, &where); + gfc_error (strcat (err, " of '%s' at %L with respect to the " + "overridden procedure"), proc->name, &where); return FAILURE; }