From patchwork Tue Jan 3 20:30:28 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 134078 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 23D761007D5 for ; Wed, 4 Jan 2012 07:30:53 +1100 (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=1326227454; h=Comment: DomainKey-Signature:Received:Received:Received:Received: MIME-Version:Received:Received:Date:Message-ID:Subject:From:To: Cc:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=xtu1uhm l3ebxrNi1NLz42FEnQGg=; b=g4uxuOr/iDVriHoY94myH+/QRWv7/K3f3OSGGgb fHFt7T+rnZ4ZCxE83x4Zdxa6KbF4yU+cUSYh0rPxZ80Ism/DrNgykEgHx3cGvsTd sB9XFs4MQYpXKrRMUXfsrS4EoVwb21eDnJ0YnIX8D6QU4LRZwP37nPKjZjLCvewm +zZ0= 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:MIME-Version:Received:Received:Date:Message-ID:Subject:From:To:Cc:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=wE/0SlkY9R2oE5OLRVgQ3mpVF9hRyXwo3u3e9ghj34S3Zr3FxlQ49vUWtY0H9Y eVHUtxQ3/ZkYUW2S0o3SW7nD4/LoEyQ5LWZbByzHwqNt/dLjKG4NmmTGoxyeFWD0 KMFZxRebycFEfHnWsRLwy7zOag3h9DjcIYCANj4vOw/Fc=; Received: (qmail 2444 invoked by alias); 3 Jan 2012 20:30:47 -0000 Received: (qmail 2423 invoked by uid 22791); 3 Jan 2012 20:30:45 -0000 X-SWARE-Spam-Status: No, hits=-2.4 required=5.0 tests=AWL, BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW X-Spam-Check-By: sourceware.org Received: from mail-ee0-f47.google.com (HELO mail-ee0-f47.google.com) (74.125.83.47) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 03 Jan 2012 20:30:30 +0000 Received: by eeit10 with SMTP id t10so11933001eei.20 for ; Tue, 03 Jan 2012 12:30:29 -0800 (PST) MIME-Version: 1.0 Received: by 10.213.108.210 with SMTP id g18mr8271511ebp.123.1325622628917; Tue, 03 Jan 2012 12:30:28 -0800 (PST) Received: by 10.14.100.5 with HTTP; Tue, 3 Jan 2012 12:30:28 -0800 (PST) Date: Tue, 3 Jan 2012 21:30:28 +0100 Message-ID: Subject: [Patch, fortran] PR48946 - Deferred Overloaded Assignment From: Paul Richard Thomas To: fortran@gcc.gnu.org, gcc-patches Cc: Tobias Burnus 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, This is a straightforward patch that adds a last ditch attempt to find a specific typebound procedure when all that has been found for a derived type base object is 'deferred'. typebound_operator_7.f03 has been extended to test derived type as well as class base objects. Bootstrapped and regtested on x86_64/FC9 - OK for trunk? Paul 2012-01-03 Paul Thomas PR fortran/PR48946 * resolve.c (resolve_typebound_static): If the typebound procedure is 'deferred' have a go at finding the right specific procedure in the derived type operator space itself. 2012-01-03 Paul Thomas PR fortran/PR48946 * gfortran.dg/typebound_operator_7.f03: Add test for derived type typebound operators as well as class bound operators. Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 182853) --- gcc/fortran/resolve.c (working copy) *************** resolve_typebound_static (gfc_expr* e, g *** 5614,5619 **** --- 5614,5646 ---- e->ref = NULL; 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) + { + gfc_symtree *st; + gfc_symbol *derived; + + /* Use the derived type of the base_object. */ + derived = e->value.compcall.base_object->ts.u.derived; + st = NULL; + + /* Look for the typebound procedure 'name'. */ + if (derived->f2k_derived && derived->f2k_derived->tb_sym_root) + st = gfc_find_symtree (derived->f2k_derived->tb_sym_root, + e->value.compcall.name); + + /* Now find the specific name in the derived type namespace. */ + if (st && st->n.tb && st->n.tb->u.specific) + gfc_find_sym_tree (st->n.tb->u.specific->name, + derived->ns, 1, &st); + if (st) + *target = st; + } return SUCCESS; } Index: gcc/testsuite/gfortran.dg/typebound_operator_7.f03 =================================================================== *** gcc/testsuite/gfortran.dg/typebound_operator_7.f03 (revision 182853) --- gcc/testsuite/gfortran.dg/typebound_operator_7.f03 (working copy) *************** *** 1,5 **** --- 1,6 ---- ! { dg-do run } ! PR46328 - complex expressions involving typebound operators of class objects. + ! PR48946 - complex expressions involving typebound operators of derived types. ! module field_module implicit none *************** end module *** 87,103 **** program main use i_field_module implicit none ! class(i_field) ,allocatable :: u ! allocate (u, source = i_field (99)) ! ! u = u*2. ! u = (u*2.0*4.0) + u*4.0 ! u = u%multiply_real (2.0)*4.0 ! u = i_multiply_real (u, 2.0) * 4.0 ! ! select type (u) ! type is (i_field); if (u%i .ne. 152064) call abort ! end select end program ! { dg-final { cleanup-modules "field_module i_field_module" } } --- 88,118 ---- program main use i_field_module implicit none ! call check_class_tbos ! call check_derived_type_tbos ! contains ! subroutine check_class_tbos ! class(i_field) ,allocatable :: u ! allocate (u, source = i_field (99)) ! u = u*2. ! u = (u*2.0*4.0) + u*4.0 ! u = u%multiply_real (2.0)*4.0 ! u = i_multiply_real (u, 2.0) * 4.0 ! select type (u) ! type is (i_field); if (u%i .ne. 152064) call abort ! end select ! deallocate (u) ! end subroutine ! subroutine check_derived_type_tbos ! type(i_field) ,allocatable :: u ! allocate (u, source = i_field (99)) ! u = u*2. ! u = (u*2.0*4.0) + u*4.0 ! u = u%multiply_real (2.0)*4.0 ! u = i_multiply_real (u, 2.0) * 4.0 ! if (u%i .ne. 152064) call abort ! deallocate (u) ! end subroutine end program ! { dg-final { cleanup-modules "field_module i_field_module" } }