From patchwork Sat Jan 28 16:58:58 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 138397 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 A5DB4B6F68 for ; Sun, 29 Jan 2012 03:59:31 +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=1328374775; 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=A8L+u9E FulZvX9roNBalPULcEHM=; b=Nzs9HS3tvJXTtLIbCIEcjrT5wybcqEq1SpBqbql CPBcn6le3iNEF/gO/xiEZc/oYzUv+ckNg9Qo5H6g4ybPaXX0OsSqT0mSQeDVoGsO zlcieeg38bU4zsSAnDY8BI9t1pRadirDs6WSXpzaXVWcqvckyBwQit7suaEInLDS UJzo= 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=ZZDM6KIF/cr3nT00Np07CfK7IFWR/WtqCEvDyIvIbQ9/ljWAv+0uCcd5XaVko7 93FCoNBxkM2jI8uZVAS05E0t2FGVzUsJrEWGeYhuMJkGx8lZMztC54fqC2zmaHc3 qllFBBhQg9pkGPX/zFGaVVHM1F9VxxDtu9mS1nyTAKSxk=; Received: (qmail 20867 invoked by alias); 28 Jan 2012 16:59:23 -0000 Received: (qmail 20847 invoked by uid 22791); 28 Jan 2012 16:59:22 -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; Sat, 28 Jan 2012 16:59:00 +0000 Received: from [192.168.178.22] (port-92-204-113-100.dynamic.qsc.de [92.204.113.100]) by mx02.qsc.de (Postfix) with ESMTP id 6A8DD1E847; Sat, 28 Jan 2012 17:58:58 +0100 (CET) Message-ID: <4F242952.9080505@net-b.de> Date: Sat, 28 Jan 2012 17:58:58 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:9.0) Gecko/20111220 Thunderbird/9.0 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran, committed] PR 51972 fix null-setting of ALLOCATE with polymorphic SOURCE= 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 I have committed the attached patch as obvious. The problem was: If the allocate object had allocatable components, one set all those to zero. Otherwise for polymorphic types one sets the whole allocated memory to zero. If now the declared type had allocatable components but the effective type added more such components, the latter never got nullified. Solution: Checking the type BT_DERIVED on the allocate object ("al->expr") and not on "expr". The latter is "al->expr->_data" and thus always BT_CLASS. Build, regtested and committed (Rev. 183667) on x86-64-linux NOTE: This patch does not solve all issues of the PR as there is also a bug in _copy, which does only an incomplete deep copy. For details and a possible solution see PR. Tobias 2012-01-28 Tobias Burnus PR fortran/51972 * trans-stmt.c (gfc_trans_allocate): Properly check whether we have a BT_CLASS which needs to be memset. 2012-01-28 Tobias Burnus PR fortran/51972 * gfortran.dg/class_allocate_12.f90: New. Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (Revision 183667) +++ gcc/fortran/trans-stmt.c (Arbeitskopie) @@ -4950,7 +4950,8 @@ gfc_trans_allocate (gfc_code * code) else gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat); - if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) + if (al->expr->ts.type == BT_DERIVED + && expr->ts.u.derived->attr.alloc_comp) { tmp = build_fold_indirect_ref_loc (input_location, se.expr); tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0); Index: gcc/testsuite/gfortran.dg/class_allocate_12.f90 =================================================================== --- gcc/testsuite/gfortran.dg/class_allocate_12.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/class_allocate_12.f90 (Arbeitskopie) @@ -0,0 +1,97 @@ +! { dg-do run } +! +! PR fortran/51972 +! +! Contributed by Damian Rouson +! +! TODO: Remove the STOP line below after fixing +! The remaining issue of the PR +! + +module surrogate_module + type ,abstract :: surrogate + end type +end module + +module strategy_module + use surrogate_module + + type :: strategy + end type +end module + +module integrand_module + use surrogate_module + use strategy_module + implicit none + + type ,abstract, extends(surrogate) :: integrand + class(strategy), allocatable :: quadrature + end type +end module integrand_module + +module lorenz_module + use strategy_module + use integrand_module + implicit none + + type ,extends(integrand) :: lorenz + real, dimension(:), allocatable :: state + contains + procedure ,public :: assign => assign_lorenz + end type +contains + type(lorenz) function constructor(initial_state, this_strategy) + real ,dimension(:) ,intent(in) :: initial_state + class(strategy) ,intent(in) :: this_strategy + constructor%state=initial_state + allocate (constructor%quadrature, source=this_strategy) + end function + + subroutine assign_lorenz(lhs,rhs) + class(lorenz) ,intent(inout) :: lhs + class(integrand) ,intent(in) :: rhs + select type(rhs) + class is (lorenz) + allocate (lhs%quadrature, source=rhs%quadrature) + lhs%state=rhs%state + end select + end subroutine +end module lorenz_module + +module runge_kutta_2nd_module + use surrogate_module,only : surrogate + use strategy_module ,only : strategy + use integrand_module,only : integrand + implicit none + + type, extends(strategy) ,public :: runge_kutta_2nd + contains + procedure, nopass :: integrate + end type +contains + subroutine integrate(this) + class(surrogate) ,intent(inout) :: this + class(integrand) ,allocatable :: this_half + + select type (this) + class is (integrand) + allocate (this_half, source=this) + end select + STOP 'SUCESS!' ! See TODO above + end subroutine +end module + +program main + use lorenz_module + use runge_kutta_2nd_module ,only : runge_kutta_2nd, integrate + implicit none + + type(runge_kutta_2nd) :: timed_lorenz_integrator + type(lorenz) :: attractor + + attractor = constructor( [1., 1., 1.] , timed_lorenz_integrator) + call integrate(attractor) +end program main + +! { dg-final { cleanup-modules "surrogate_module strategy_module integrand_module runge_kutta_2nd_module" } }