From patchwork Tue Jun 25 21:37:31 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 254426 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 CN "localhost", Issuer "www.qmailtoaster.com" (not verified)) by ozlabs.org (Postfix) with ESMTPS id 925842C0040 for ; Wed, 26 Jun 2013 07:37:45 +1000 (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=NF1cqUKz4/ORENUrcnA/2kxwkhoaushBFzV9izoLvQRFDu kd9rpK1wEU/ezgwtf+TfjlUk7hGXxiXTkPS9ef1oRHsl2/Wv+jVw5/szCYmvlsBv veKpEyTlSytOFH9snUV0P++AEkBsXFop2M4+ZDkSAQaOJSoEJ4LnVPZFyvhQA= 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=7skYF/7TvDRr7mmedh7RzgVVEp4=; b=XfbaWOWvweB8pMFyiyta BZnNLA4mOcuTztdqoAZbyVmxadzCtmPiGmSWwhJVPEcwmvdDzd1sWZ7p0/jFx2zJ ubGsKl/qcw/4bDLelaqKxNB6Ls3gv2pUovRSXU2SjtoCR5Z605bdJwwHU9DzVSxE boocjXnJoW2nYLLygsq2EZE= Received: (qmail 21795 invoked by alias); 25 Jun 2013 21:37:39 -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 21779 invoked by uid 89); 25 Jun 2013 21:37:38 -0000 X-Spam-SWARE-Status: No, score=-2.3 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, TW_FN, TW_TM autolearn=no version=3.3.1 X-Spam-User: qpsmtpd, 2 recipients Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.84/v0.84-167-ge50287c) with ESMTP; Tue, 25 Jun 2013 21:37:36 +0000 Received: from archimedes.net-b.de (port-92-206-14-23.dynamic.qsc.de [92.206.14.23]) by mx02.qsc.de (Postfix) with ESMTP id 79FA5276E5; Tue, 25 Jun 2013 23:37:31 +0200 (CEST) Message-ID: <51CA0D9B.2070302@net-b.de> Date: Tue, 25 Jun 2013 23:37:31 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/20130510 Thunderbird/17.0.6 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] Add end-of-scope finalization (Part 2 of 2) X-Virus-Found: No This patch adds finalization calls for components. This completes the end-of-scope finalization, but it is also called for the LHS of intrinsic assignment. (LHS finalization for the variable itself is still lacking.) Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias 2013-06-25 Tobias Burnus PR fortran/37336 * trans.c (gfc_add_comp_finalizer_call): New function. * trans.h (gfc_add_comp_finalizer_call): New prototype. * trans-array.c (structure_alloc_comps): Call it. 2013-06-25 Tobias Burnus PR fortran/37336 * gfortran.dg/finalize_18.f90: New. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 96162e5..e4f78f4 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7553,19 +7553,34 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, called_dealloc_with_status = false; gfc_init_block (&tmpblock); + if ((c->ts.type == BT_DERIVED && !c->attr.pointer) + || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)) + { + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + + /* The finalizer frees allocatable components. */ + called_dealloc_with_status + = gfc_add_comp_finalizer_call (&tmpblock, comp, c, true); + } + else + comp = NULL_TREE; + if (c->attr.allocatable && (c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer) { - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); + if (comp == NULL_TREE) + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL); gfc_add_expr_to_block (&tmpblock, tmp); } else if (c->attr.allocatable) { /* Allocatable scalar components. */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); + if (comp == NULL_TREE) + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL, c->ts); @@ -7580,10 +7595,11 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) { /* Allocatable CLASS components. */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); /* Add reference to '_data' component. */ + if (comp == NULL_TREE) + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); tmp = CLASS_DATA (c)->backend_decl; comp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), comp, tmp, NULL_TREE); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index f17eaca..53a0669 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -948,6 +948,102 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, } +bool +gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp, + bool fini_coarray) +{ + gfc_se se; + stmtblock_t block2; + tree final_fndecl, size, array, tmp, cond; + symbol_attribute attr; + gfc_expr *final_expr = NULL; + + if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS) + return false; + + gfc_init_block (&block2); + + if (comp->ts.type == BT_DERIVED) + { + if (comp->attr.pointer) + return false; + + gfc_is_finalizable (comp->ts.u.derived, &final_expr); + if (!final_expr) + return false; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, final_expr); + final_fndecl = se.expr; + size = gfc_typenode_for_spec (&comp->ts); + size = TYPE_SIZE_UNIT (size); + size = fold_convert (gfc_array_index_type, size); + + array = decl; + } + else /* comp->ts.type == BT_CLASS. */ + { + if (CLASS_DATA (comp)->attr.class_pointer) + return false; + + gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr); + final_fndecl = gfc_vtable_final_get (decl); + size = gfc_vtable_size_get (decl); + array = gfc_class_data_get (decl); + } + + if (comp->attr.allocatable + || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable)) + { + tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)) + ? gfc_conv_descriptor_data_get (array) : array; + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp, fold_convert (TREE_TYPE (tmp), + null_pointer_node)); + } + else + cond = boolean_true_node; + + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))) + { + gfc_clear_attr (&attr); + gfc_init_se (&se, NULL); + array = gfc_conv_scalar_to_descriptor (&se, array, attr); + gfc_add_block_to_block (&block2, &se.pre); + gcc_assert (se.post.head == NULL_TREE); + } + + if (!POINTER_TYPE_P (TREE_TYPE (array))) + array = gfc_build_addr_expr (NULL, array); + + if (!final_expr) + { + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + final_fndecl, + fold_convert (TREE_TYPE (final_fndecl), + null_pointer_node)); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond, tmp); + } + + if (POINTER_TYPE_P (TREE_TYPE (final_fndecl))) + final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl); + + tmp = build_call_expr_loc (input_location, + final_fndecl, 3, array, + size, fini_coarray ? boolean_true_node + : boolean_false_node); + gfc_add_expr_to_block (&block2, tmp); + tmp = gfc_finish_block (&block2); + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (block, tmp); + + return true; +} + + /* Add a call to the finalizer, using the passed *expr. Returns true when a finalizer call has been inserted. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 06cb63d..424ce7a 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -353,6 +353,8 @@ tree gfc_get_vptr_from_expr (tree); tree gfc_get_class_array_ref (tree, tree); tree gfc_copy_class_to_class (tree, tree, tree); bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *); +bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool); + void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool, bool); void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool, --- /dev/null 2013-06-25 10:38:04.922062377 +0200 +++ gcc/gcc/testsuite/gfortran.dg/finalize_18.f90 2013-06-25 23:27:56.833170540 +0200 @@ -0,0 +1,47 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/37336 +! +module m + type t + contains + final :: fini + end type t + type t2 + integer :: ii + type(t), allocatable :: aa + type(t), allocatable :: bb(:) + class(t), allocatable :: cc + class(t), allocatable :: dd(:) + end type t2 + integer, save :: cnt = -1 +contains + subroutine fini(x) + type(t) :: x + if (cnt == -1) call abort () + cnt = cnt + 1 + end subroutine fini +end module m + +use m +block + type(t2) :: y + y%ii = 123 +end block +end + +! { dg-final { scan-tree-dump-times "if \\(y.aa != 0B\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "if \\(y.cc._data != 0B\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.data != 0B\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.data != 0B\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.aa;" 1 "original" } } +! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.cc._data;" 1 "original" } } + +! { dg-final { scan-tree-dump-times "__final_m_T \\(&desc.4, 0, 1\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__final_m_T \\(&y.bb, 0, 1\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "y.cc._vptr->_final \\(&desc.5, \\(integer\\(kind=8\\)\\) y.cc._vptr->_size, 1\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "y.dd._vptr->_final \\(&y.dd._data, \\(integer\\(kind=8\\)\\) y.dd._vptr->_size, 1\\);" 1 "original" } } + +! { dg-final { cleanup-tree-dump "original" } }