From patchwork Fri Sep 9 17:31:51 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Janus Weil X-Patchwork-Id: 114118 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 6EC57B7150 for ; Sat, 10 Sep 2011 03:32:54 +1000 (EST) Received: (qmail 23732 invoked by alias); 9 Sep 2011 17:32:50 -0000 Received: (qmail 23720 invoked by uid 22791); 9 Sep 2011 17:32:48 -0000 X-SWARE-Spam-Status: No, hits=-1.2 required=5.0 tests=AWL, BAYES_00, DKIM_SIGNED, DKIM_VALID, FREEMAIL_ENVFROM_END_DIGIT, FREEMAIL_FROM, SPF_NEUTRAL X-Spam-Check-By: sourceware.org Received: from eggs.gnu.org (HELO eggs.gnu.org) (140.186.70.92) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 09 Sep 2011 17:32:36 +0000 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1R24wM-00079P-Na for gcc-patches@gcc.gnu.org; Fri, 09 Sep 2011 13:32:36 -0400 Received: from mail-gx0-f173.google.com ([209.85.161.173]:33750) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1R24w1-0006uk-2X; Fri, 09 Sep 2011 13:32:13 -0400 Received: by gxk26 with SMTP id 26so1680498gxk.18 for ; Fri, 09 Sep 2011 10:31:51 -0700 (PDT) MIME-Version: 1.0 Received: by 10.150.164.1 with SMTP id m1mr2421079ybe.297.1315589511510; Fri, 09 Sep 2011 10:31:51 -0700 (PDT) Received: by 10.147.83.10 with HTTP; Fri, 9 Sep 2011 10:31:51 -0700 (PDT) Date: Fri, 9 Sep 2011 19:31:51 +0200 Message-ID: Subject: [Patch, Fortran, OOP] PR 47978: Invalid INTENT in overriding TBP not detected From: Janus Weil To: gfortran , gcc-patches X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6 (newer, 2) X-Received-From: 209.85.161.173 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 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 178722) +++ 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 178722) +++ 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 178722) +++ gcc/fortran/interface.c (working copy) @@ -977,6 +977,45 @@ 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. */ + if (s1->attr.optional != s2->attr.optional) + { + snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'", + s1->name); + return FAILURE; + } + + /* FIXME: Do more comprehensive testing of dummy characteristics, + e.g. array shape, string length and attributes like + ALLOCATABLE, POINTER, TARGET, etc. */ + + 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 +1098,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 +3498,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 +3667,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; }