From patchwork Mon Feb 6 22:27:05 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 139816 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 1F636B7269 for ; Tue, 7 Feb 2012 09:28:15 +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=1329172097; 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=T+/kClE hX3VTfoxTH1mxKwGAQKY=; b=LCxNUIDdNLTYqRhJyzznhmDCstA+3IN0mczjatO E//EO3rE08PQQKQUvHvEA4jT1cIbAGPstp6Gy7pbdjQP6BFQQ++D46UzACg48XL8 ssXn0ZmkreHFzoTEABD48TFK4XiaNVgPjj5L/m412mu0htKfFX8BxMZup0PZb7G3 f1zc= 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=Z9NS6z47kY9CwIc5T1q6jy1IQnEBFYxNsCOJfOKXGRZsjfS2AlB6ZZdRNLfvk3 uvya+bbMeuxm3rClBoy/4d7hFSfWaI61nvpD+U1oUhxY7fZO9AiYMVjW00Atn6E1 2rIM1v78y39HU73HRdkMvvlfhq4JNNgBWAOs/uRACo8GM=; Received: (qmail 15512 invoked by alias); 6 Feb 2012 22:27:56 -0000 Received: (qmail 15473 invoked by uid 22791); 6 Feb 2012 22:27:53 -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; Mon, 06 Feb 2012 22:27:07 +0000 Received: from [192.168.178.22] (port-92-204-22-132.dynamic.qsc.de [92.204.22.132]) by mx02.qsc.de (Postfix) with ESMTP id 2DE861E73C; Mon, 6 Feb 2012 23:27:05 +0100 (CET) Message-ID: <4F3053B9.2080302@net-b.de> Date: Mon, 06 Feb 2012 23:27:05 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:10.0) Gecko/20120129 Thunderbird/10.0 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR51514 - fix passing a CLASS to a TYPE 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 When passing a CLASS to a TYPE, the "_data" component wasn't added for scalar variables. (Polymorphic arrays are/were handled correctly.) This patch adds the _data, fixing this wrong-code issue. Build and regtested on x86-64-linux. OK for the trunk? Tobias 2012-02-06 Tobias Burnus PR fortran/51514 * trans-expr.c (gfc_conv_procedure_call): Add _data component for calls of scalar CLASS actuals to TYPE dummies. 2012-02-06 Tobias Burnus PR fortran/51514 * gfortran.dg/class_to_type_2.f90: New. Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (Revision 183942) +++ gcc/fortran/trans-expr.c (Arbeitskopie) @@ -3619,6 +3619,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * && CLASS_DATA (e)->attr.dimension) gfc_conv_class_to_class (&parmse, e, fsym->ts, false); + if (fsym && fsym->ts.type == BT_DERIVED + && e->ts.type == BT_CLASS + && !CLASS_DATA (e)->attr.dimension + && !CLASS_DATA (e)->attr.codimension) + parmse.expr = gfc_class_data_get (parmse.expr); + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ if (fsym && fsym->attr.allocatable Index: gcc/testsuite/gfortran.dg/class_to_type_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/class_to_type_2.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/class_to_type_2.f90 (Arbeitskopie) @@ -0,0 +1,97 @@ +! { dg-do run } +! +! PR fortran/51514 +! +! Check that passing a CLASS to a TYPE works +! +! Based on a test case of Reinhold Bader. +! + +module mod_subpr + implicit none + + type :: foo + integer :: i = 2 + end type + + type, extends(foo) :: foo_1 + real :: r(2) + end type + +contains + + subroutine subpr (x) + type(foo) :: x + x%i = 3 + end subroutine + + elemental subroutine subpr_elem (x) + type(foo), intent(inout):: x + x%i = 3 + end subroutine + + subroutine subpr_array (x) + type(foo), intent(inout):: x(:) + x(:)%i = 3 + end subroutine + + subroutine subpr2 (x) + type(foo) :: x + if (x%i /= 55) call abort () + end subroutine + + subroutine subpr2_array (x) + type(foo) :: x(:) + if (any(x(:)%i /= 55)) call abort () + end subroutine + + function f () + class(foo), allocatable :: f + allocate (f) + f%i = 55 + end function f + + function g () result(res) + class(foo), allocatable :: res(:) + allocate (res(3)) + res(:)%i = 55 + end function g +end module + +program prog + use mod_subpr + implicit none + class(foo), allocatable :: xx, yy(:) + + allocate (foo_1 :: xx) + xx%i = 33 + call subpr (xx) + if (xx%i /= 3) call abort () + + xx%i = 33 + call subpr_elem (xx) + if (xx%i /= 3) call abort () + + call subpr (f ()) + + allocate (foo_1 :: yy(2)) + yy(:)%i = 33 + call subpr_elem (yy) + if (any (yy%i /= 3)) call abort () + + yy(:)%i = 33 + call subpr_elem (yy(1)) + if (yy(1)%i /= 3) call abort () + + yy(:)%i = 33 + call subpr_array (yy) + if (any (yy%i /= 3)) call abort () + + yy(:)%i = 33 + call subpr_array (yy(1:2)) + if (any (yy(1:2)%i /= 3)) call abort () + + call subpr2_array (g ()) +end program + +! { dg-final { cleanup-modules "mod_subpr" } }