From patchwork Sun Dec 9 19:04:46 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 204772 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 74A1F2C0193 for ; Mon, 10 Dec 2012 06:05:05 +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=1355684706; h=Comment: DomainKey-Signature:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:CC:Subject: References:In-Reply-To:Content-Type:Mailing-List:Precedence: List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender: Delivered-To; bh=zRxtEHOjB4M0yDkm91iaThDGDPo=; b=uL4ge3GUZ9wq7/i 5uoOO7jc75x3oceHMSZwv+NAQC36vzZOfYY3gBbNscu5QeUZst+bQYGGq7doozJm sJHGMt64Ssxuaxx+B3Xc+kHspy1InOiZnVHazdG0oHHPjia8QhNI0URYVfvBchBS PTtVrDrWFCuu0hpaoicmDMLgYhcE= 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:CC:Subject:References:In-Reply-To:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=NKZL3TuuixtYnsqBBmdgSpu+/UmOIHjxb4LNZcFPj9iv4iZ7iV5Jd0Z+HRfS2z ArzWwKPQwtpv+c+xz91/Ajv3NxJPRV4xDYe8EkrH4BkG4Ouv+wTJmU2yZfy1X6pm lExKHJiBfN+IS8aIu2W+8K8fEc4JYr3xzoYMXhANwiRzs=; Received: (qmail 22079 invoked by alias); 9 Dec 2012 19:04:59 -0000 Received: (qmail 22053 invoked by uid 22791); 9 Dec 2012 19:04:57 -0000 X-SWARE-Spam-Status: No, hits=-2.8 required=5.0 tests=AWL, BAYES_00, KHOP_THREADED, RCVD_IN_DNSWL_NONE, TW_VP 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, 09 Dec 2012 19:04:50 +0000 Received: from archimedes.net-b.de (port-92-195-120-23.dynamic.qsc.de [92.195.120.23]) by mx02.qsc.de (Postfix) with ESMTP id 1EFB825227; Sun, 9 Dec 2012 20:04:47 +0100 (CET) Message-ID: <50C4E0CE.9000906@net-b.de> Date: Sun, 09 Dec 2012 20:04:46 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/17.0 Thunderbird/17.0 MIME-Version: 1.0 To: Janus Weil CC: gcc patches , gfortran Subject: [Patch, Fortran] reset dynamic type with MOVE_ALLOC (was: Re: [Patch, Fortran] Small patch for calls to gfc_deallocate_scalar_with_status) References: <50BF7120.6040806@net-b.de> In-Reply-To: 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 Janus Weil wrote: >> >The expr to al->expr change is to pass a BT_CLASS instead of a >> >BT_DERIVED. And the NULL to gfc_lval_expr_from_sym change allows to access >> >var->_vtab->_final for a BT_CLASS deferred variable. > It seems that both of them will not have any effect right now, but are > useful only as preparation for FINAL, right? I think that's true. I wanted to claim that it also fixes the following, but it doesn't: class(t), allocatable :: a, b, c allocate (t2 :: a) call move_alloc (from=a, to=b) "a" should not only be deallocated but same_type_as(a,c) should be true, i.e. one has to reset the "a->_vtab" pointer to the declared type. A follow-up patch which fixes this is attached. Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias 2012-12-09 Tobias Burnus * trans-intrinsic.c (conv_intrinsic_move_alloc): Set dynamic type of the FROM variable to the declared type. 2012-12-09 Tobias Burnus * gfortran.dg/move_alloc_14.f90: New. diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 504a9f3..4f74c3f 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -7338,6 +7338,8 @@ conv_intrinsic_move_alloc (gfc_code *code) /* Set _vptr. */ if (to_expr->ts.type == BT_CLASS) { + gfc_symbol *vtab; + gfc_free_expr (to_expr2); gfc_init_se (&to_se, NULL); to_se.want_pointer = 1; @@ -7346,23 +7348,31 @@ conv_intrinsic_move_alloc (gfc_code *code) if (from_expr->ts.type == BT_CLASS) { + vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + gcc_assert (vtab); + gfc_free_expr (from_expr2); gfc_init_se (&from_se, NULL); from_se.want_pointer = 1; gfc_add_vptr_component (from_expr); gfc_conv_expr (&from_se, from_expr); - tmp = from_se.expr; + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), + from_se.expr)); + + /* Reset _vptr component to declared type. */ + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify_loc (input_location, &block, from_se.expr, + fold_convert (TREE_TYPE (from_se.expr), tmp)); } else { - gfc_symbol *vtab; vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); gcc_assert (vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), tmp)); } - - gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), tmp)); } return gfc_finish_block (&block); @@ -7371,6 +7381,8 @@ conv_intrinsic_move_alloc (gfc_code *code) /* Update _vptr component. */ if (to_expr->ts.type == BT_CLASS) { + gfc_symbol *vtab; + to_se.want_pointer = 1; to_expr2 = gfc_copy_expr (to_expr); gfc_add_vptr_component (to_expr2); @@ -7378,22 +7390,31 @@ conv_intrinsic_move_alloc (gfc_code *code) if (from_expr->ts.type == BT_CLASS) { + vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + gcc_assert (vtab); + from_se.want_pointer = 1; from_expr2 = gfc_copy_expr (from_expr); gfc_add_vptr_component (from_expr2); gfc_conv_expr (&from_se, from_expr2); - tmp = from_se.expr; + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), + from_se.expr)); + + /* Reset _vptr component to declared type. */ + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify_loc (input_location, &block, from_se.expr, + fold_convert (TREE_TYPE (from_se.expr), tmp)); } else { - gfc_symbol *vtab; vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); gcc_assert (vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), tmp)); } - gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), tmp)); gfc_free_expr (to_expr2); gfc_init_se (&to_se, NULL); @@ -7449,7 +7470,7 @@ conv_intrinsic_move_alloc (gfc_code *code) /* Move the pointer and update the array descriptor data. */ gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr); - /* Set "to" to NULL. */ + /* Set "from" to NULL. */ tmp = gfc_conv_descriptor_data_get (from_se.expr); gfc_add_modify_loc (input_location, &block, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); diff --git a/gcc/testsuite/gfortran.dg/move_alloc_14.f90 b/gcc/testsuite/gfortran.dg/move_alloc_14.f90 new file mode 100644 index 0000000..bc5e491 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/move_alloc_14.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! Ensure that move_alloc for CLASS resets the FROM variable's dynamic type +! to the declared one +! +implicit none +type t +end type t +type, extends(t) :: t2 +end type t2 + +class(t), allocatable :: a, b, c +class(t), allocatable :: a2(:), b2(:), c2(:) +allocate (t2 :: a) +allocate (t2 :: a2(5)) +call move_alloc (from=a, to=b) +call move_alloc (from=a2, to=b2) +!print *, same_type_as (a,c), same_type_as (a,b) +!print *, same_type_as (a2,c2), same_type_as (a2,b2) +if (.not. same_type_as (a,c) .or. same_type_as (a,b)) call abort () +if (.not. same_type_as (a2,c2) .or. same_type_as (a2,b2)) call abort () +end