From patchwork Tue Oct 15 22:38:50 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 283797 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]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client did not present a certificate) by ozlabs.org (Postfix) with ESMTPS id 0812B2C00C3 for ; Wed, 16 Oct 2013 09:39:06 +1100 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; q= dns; s=default; b=ciUkHeo6vzNSxAwQCRz3SpEZGsdOFM+YHSRfO4MBUzIXDz vMtn9GAbsQbziiVaZZnz35S0I5m2vRjVzDUG1gqxEDZTLUsTIUoecYf5EBdVHThe Mst8jRNyu7GepsC+mAyFkDOZONP/TewW1m564P8xaoiohOfGcnEaljWLbilok= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; s= default; bh=YYyKhi+btNDve1VnhFSXlgXOl7c=; b=lT3k2ToHXlx7kr//zK7w o2gjelNBz//p3KQVAR26MGMONuBoGB0OvJVrzuZ1EI1SFRpRmk77WfJ3ij6Kthug v1UcpD7BQ8IG8g+gZEOn0Er2y2ZNvDo46clCuE75nWumi8WyXA2D7pWHJukmJg8o wvKf0eGBfrpiF+y8ZT/ltFQ= Received: (qmail 25516 invoked by alias); 15 Oct 2013 22:38:55 -0000 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 Received: (qmail 25493 invoked by uid 89); 15 Oct 2013 22:38:54 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.0 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mx02.qsc.de Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Tue, 15 Oct 2013 22:38:54 +0000 Received: from archimedes.net-b.de (port-92-194-74-217.dynamic.qsc.de [92.194.74.217]) by mx02.qsc.de (Postfix) with ESMTP id C058127972; Wed, 16 Oct 2013 00:38:50 +0200 (CEST) Message-ID: <525DC3FA.5080804@net-b.de> Date: Wed, 16 Oct 2013 00:38:50 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:24.0) Gecko/20100101 Thunderbird/24.0 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR58652 - accept CLASS(*) as argument to CLASS(*) As the test case (see also PR) showed, gfortran was rejecting: subroutine list_move_alloc(self,item) class(list_node),intent(inout) :: self class(*),intent(inout),allocatable :: item ... class(*), allocatable :: expr ... call ast%move_alloc(expr) with the bogus message: call ast%move_alloc(expr) 1 Error: Actual argument to 'item' at (1) must have the same declared type The attached patch now also accepts passing CLASS(*) to CLASS(*). Built and currently regtesting on x86-64-gnu-linux (when successful:) OK for the trunk? Tobias 2013-10-16 Tobias Burnus PR fortran/58652 * interface.c (compare_parameter): Accept passing CLASS(*) to CLASS(*). 2013-10-16 Tobias Burnus PR fortran/58652 * gfortran.dg/unlimited_polymorphic_12.f90: New. diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index b878644..b3ddf5f 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1990,8 +1990,9 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (!gfc_expr_attr (actual).class_ok) return 0; - if (!gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived, - CLASS_DATA (formal)->ts.u.derived)) + if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual)) + && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived, + CLASS_DATA (formal)->ts.u.derived)) { if (where) gfc_error ("Actual argument to '%s' at %L must have the same " diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_12.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_12.f90 new file mode 100644 index 0000000..c583c6b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_12.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! +! PR fortran/58652 +! +! Contributed by Vladimir Fuka +! +! The passing of a CLASS(*) to a CLASS(*) was reject before +! +module gen_lists + type list_node + class(*),allocatable :: item + contains + procedure :: move_alloc => list_move_alloc + end type + + contains + + subroutine list_move_alloc(self,item) + class(list_node),intent(inout) :: self + class(*),intent(inout),allocatable :: item + + call move_alloc(item, self%item) + end subroutine +end module + +module lists + use gen_lists, only: node => list_node +end module lists + + +module sexp + use lists +contains + subroutine parse(ast) + class(*), allocatable, intent(out) :: ast + class(*), allocatable :: expr + integer :: ierr + allocate(node::ast) + select type (ast) + type is (node) + call ast%move_alloc(expr) + end select + end subroutine +end module