From patchwork Sun May 6 17:05:32 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 157113 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 661D2B6F13 for ; Mon, 7 May 2012 03:05:55 +1000 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1336928756; h=Comment: DomainKey-Signature:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:Subject: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=R7zbHHV c3gW5QLLKpZXVmkzwSbo=; b=QJYjoitXIB5xLPdXMOMBj/WOrx6xmXnCfjRbTXH 8otNYpYy7bghDTn6Cu0+EWW4owLewg1P8yuWuW+H0HRy266FAnOeotAZsts5XmTr zSKM0bMCTV5dtPT4MR5ku9fn80A7vspcadVmlhvjU1Zg/CYBLEkhwBeOCeLO23jT 3DYo= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Message-ID:Date:From:User-Agent:MIME-Version:To:Subject:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=NUHBNK6aBGMiwRq9ojOz8t3xM1/VuwoGDjraiuqIYcMHLv9mp9aztUGXWdDfkn ypnfWSHTCW/+vZFO5k4rrNIrKUL76nXSh5wyYfsV9Z0YbVsKJ5hFIvVCDXJXRpOO qC2vd7re90VLypxV6xZA5zVNwXWX1907A7yCD+2xqc/SU=; Received: (qmail 28113 invoked by alias); 6 May 2012 17:05:50 -0000 Received: (qmail 28097 invoked by uid 22791); 6 May 2012 17:05:49 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE X-Spam-Check-By: sourceware.org Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sun, 06 May 2012 17:05:34 +0000 Received: from [192.168.178.22] (port-92-204-82-207.dynamic.qsc.de [92.204.82.207]) by mx02.qsc.de (Postfix) with ESMTP id 76B661E6E7; Sun, 6 May 2012 19:05:32 +0200 (CEST) Message-ID: <4FA6AF5C.5020704@net-b.de> Date: Sun, 06 May 2012 19:05:32 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:11.0) Gecko/20120328 Thunderbird/11.0.1 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR53255 - fix type-bound operator handling 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 Dear all, if one uses TYPE(extended), the overridden specific procedure ("trace_ext" to the TBP "trace") associated with an operator (".tr.") is not called - but the TBP of the base type. It correctly works for polymorphic types. Build and regtested on x86-64-linux. OK for the trunk? As it is a nasty wrong-code bug (but no regression), I wonder whether it should be backported - and, if so, to which version - 4.7 only? (Affected are GCC 4.5 to 4.8.) Tobias 2012-05-06 Tobias Burnus PR fortran/53255 * resolve.c (resolve_typebound_static): Fix handling of overridden specific to generic operator. 2012-05-06 Tobias Burnus PR fortran/53255 * gfortran.dg/typebound_operator_15.f90: New. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e5a49bc..cacc033 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5671,12 +5702,11 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target, e->value.compcall.actual = NULL; /* If we find a deferred typebound procedure, check for derived types - that an over-riding typebound procedure has not been missed. */ - if (e->value.compcall.tbp->deferred - && e->value.compcall.name - && !e->value.compcall.tbp->non_overridable - && e->value.compcall.base_object - && e->value.compcall.base_object->ts.type == BT_DERIVED) + that an overriding typebound procedure has not been missed. */ + if (e->value.compcall.name + && !e->value.compcall.tbp->non_overridable + && e->value.compcall.base_object + && e->value.compcall.base_object->ts.type == BT_DERIVED) { gfc_symtree *st; gfc_symbol *derived; --- /dev/null 2012-05-04 18:48:20.115791170 +0200 +++ gcc/gcc/testsuite/gfortran.dg/typebound_operator_15.f90 2012-05-06 18:30:18.000000000 +0200 @@ -0,0 +1,78 @@ +! { dg-do run } +! +! PR fortran/53255 +! +! Contributed by Reinhold Bader. +! +! Before TYPE(ext)'s .tr. wronly called the base type's trace +! instead of ext's trace_ext. +! +module mod_base + implicit none + private + integer, public :: base_cnt = 0 + type, public :: base + private + real :: r(2,2) = reshape( (/ 1.0, 2.0, 3.0, 4.0 /), (/ 2, 2 /)) + contains + procedure, private :: trace + generic :: operator(.tr.) => trace + end type base +contains + complex function trace(this) + class(base), intent(in) :: this + base_cnt = base_cnt + 1 +! write(*,*) 'executing base' + trace = this%r(1,1) + this%r(2,2) + end function trace +end module mod_base + +module mod_ext + use mod_base + implicit none + private + integer, public :: ext_cnt = 0 + public :: base, base_cnt + type, public, extends(base) :: ext + private + real :: i(2,2) = reshape( (/ 1.0, 1.0, 1.0, 1.5 /), (/ 2, 2 /)) + contains + procedure, private :: trace => trace_ext + end type ext +contains + complex function trace_ext(this) + class(ext), intent(in) :: this + +! the following should be executed through invoking .tr. p below +! write(*,*) 'executing override' + ext_cnt = ext_cnt + 1 + trace_ext = .tr. this%base + (0.0, 1.0) * ( this%i(1,1) + this%i(2,2) ) + end function trace_ext + +end module mod_ext +program test_override + use mod_ext + implicit none + type(base) :: o + type(ext) :: p + real :: r + + ! Note: ext's ".tr." (trace_ext) calls also base's "trace" + +! write(*,*) .tr. o +! write(*,*) .tr. p + if (base_cnt /= 0 .or. ext_cnt /= 0) call abort () + r = .tr. o + if (base_cnt /= 1 .or. ext_cnt /= 0) call abort () + r = .tr. p + if (base_cnt /= 2 .or. ext_cnt /= 1) call abort () + + if (abs(.tr. o - 5.0 ) < 1.0e-6 .and. abs( .tr. p - (5.0,2.5)) < 1.0e-6) & + then + if (base_cnt /= 4 .or. ext_cnt /= 2) call abort () +! write(*,*) 'OK' + else + call abort() +! write(*,*) 'FAIL' + end if +end program test_override