From patchwork Fri Jun 21 15:39:47 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 253255 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 9DD592C007E for ; Sat, 22 Jun 2013 01:39:59 +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=kDGzgewVW2Y010/sTntpkBcIpuvuOxbgclCEEMa9K2c9F+ PFrVS115co2woTalRLVaA1oxDGJaTGJAsctBnJIOknbBMRahjxILWoMe2TJzwZZ0 bv0GHa9lRhlxGVXlDzpeeFW/TqOGdQiRIHMuFMV6YYVtGwEw/Jpdp7oUmzprM= 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=cQUap9Lw0shY0yc5YgyUYhK3u94=; b=tPH+l8yj5ny9fqNc4zfc YUqZ7nuoyJAF4+LAQua2ws+CQOh1bU23YzrGt80mI/W1Gnrba73pHQMgA1Ke0Khw Ifc33GDlPh2qnBYe185tlwCUlShfvz98cByu2CkLr9YEX0Af3qkrz46e2mYIMsUp AC3PMIiEqkruz55eLNtHvX4= Received: (qmail 10549 invoked by alias); 21 Jun 2013 15:39:53 -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 10530 invoked by uid 89); 21 Jun 2013 15:39:53 -0000 X-Spam-SWARE-Status: No, score=-2.2 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE autolearn=ham version=3.3.1 X-Spam-User: qpsmtpd, 2 recipients Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.84/v0.84-167-ge50287c) with ESMTP; Fri, 21 Jun 2013 15:39:52 +0000 Received: from archimedes.net-b.de (port-92-195-115-81.dynamic.qsc.de [92.195.115.81]) by mx01.qsc.de (Postfix) with ESMTP id E2AFE3C714; Fri, 21 Jun 2013 17:39:48 +0200 (CEST) Message-ID: <51C473C3.6060108@net-b.de> Date: Fri, 21 Jun 2013 17:39:47 +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 1 of 2) X-Virus-Found: No This patch extends the already existing end-of-scope finalization to nonallocatables. Note: The patch only handles finalization of unsaved local variables whose type has a finalizer (including finalizable nonallocatable components or finalizers in the ancestor). In that case, the finalizer is invoked and also calls - where applicable - the finalizer of the allocatable components. Part 2 will deal with derived-types with allocatable components which have finalizers (for the case that derived type itself has none). This requires a change to gfc_deallocate_alloc_comp, which will be done in part 2. Build and regtested on x86-64-gnu-linux. OK for the trunk? Best regards - and enjoy midsummer (the longest day - or the shortest if you are in the southern hemisphere), Tobias PS: Finalization overview: Working (except part 2 of this patch set): Finalization for intent(out), end of scope, deallocate/allocate/move_alloc Not working: Finalization of the LHS with intrinsic assignment and function results + structure/array constructors 2013-06-21 Tobias Burnus * trans-array.c (gfc_trans_deferred_array): Call the finalizer for nonallocatable local variables. * trans-decl.c (gfc_get_symbol_decl): Add local finalizable vars to the deferred list. (gfc_trans_deferred_vars): Call gfc_trans_deferred_array for those. 2013-06-21 Tobias Burnus * gfortran.dg/finalize_17.f90: New. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index a4321cc..96162e5 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -8307,12 +8309,12 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) sym_has_alloc_comp = (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) && sym->ts.u.derived->attr.alloc_comp; + has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED + ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false; /* Make sure the frontend gets these right. */ - if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp)) - fatal_error ("Possible front-end bug: Deferred array size without pointer, " - "allocatable attribute or derived type without allocatable " - "components."); + gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp + || has_finalizer); gfc_save_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); @@ -8341,7 +8343,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) /* Although static, derived types with default initializers and allocatable components must not be nulled wholesale; instead they are treated component by component. */ - if (TREE_STATIC (descriptor) && !sym_has_alloc_comp) + if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer) { /* SAVEd variables are not freed on exit. */ gfc_trans_static_array_pointer (sym); @@ -8354,7 +8356,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) /* Get the descriptor type. */ type = TREE_TYPE (sym->backend_decl); - if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable)) + if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS)) + && !(sym->attr.pointer || sym->attr.allocatable)) { if (!sym->attr.save && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program)) @@ -8389,9 +8392,17 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) /* Allocatable arrays need to be freed when they go out of scope. The allocatable components of pointers must not be touched. */ - has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED - ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false; - if ((!sym->attr.allocatable || !has_finalizer) + if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS + && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save + && !sym->ns->proc_name->attr.is_main_program) + { + gfc_expr *e; + sym->attr.referenced = 1; + e = gfc_lval_expr_from_sym (sym); + gfc_add_finalizer_call (&cleanup, e); + gfc_free_expr (e); + } + else if ((!sym->attr.allocatable || !has_finalizer) && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result) && !sym->attr.pointer && !sym->attr.save && !sym->ns->proc_name->attr.is_main_program) diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 4e3bf48..fc3a725 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1420,7 +1420,11 @@ gfc_get_symbol_decl (gfc_symbol * sym) || (sym->ts.type == BT_CLASS && (CLASS_DATA (sym)->attr.dimension || CLASS_DATA (sym)->attr.allocatable)) - || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp) + || (sym->ts.type == BT_DERIVED + && (sym->ts.u.derived->attr.alloc_comp + || (!sym->attr.pointer && !sym->attr.artificial && !sym->attr.save + && !sym->ns->proc_name->attr.is_main_program + && gfc_is_finalizable (sym->ts.u.derived, NULL)))) /* This applies a derived type default initializer. */ || (sym->ts.type == BT_DERIVED && sym->attr.save == SAVE_NONE @@ -3668,8 +3672,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink) { - bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED) - && sym->ts.u.derived->attr.alloc_comp; + bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED) + && (sym->ts.u.derived->attr.alloc_comp + || gfc_is_finalizable (sym->ts.u.derived, + NULL)); if (sym->assoc) continue; @@ -3754,7 +3760,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_save_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); - if (sym_has_alloc_comp) + if (alloc_comp_or_fini) { seen_trans_deferred_array = true; gfc_trans_deferred_array (sym, block); @@ -3802,7 +3808,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) default: gcc_unreachable (); } - if (sym_has_alloc_comp && !seen_trans_deferred_array) + if (alloc_comp_or_fini && !seen_trans_deferred_array) gfc_trans_deferred_array (sym, block); } else if ((!sym->attr.dummy || sym->ts.deferred) @@ -3998,7 +4004,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) } else if (sym->ts.deferred) gfc_fatal_error ("Deferred type parameter not yet supported"); - else if (sym_has_alloc_comp) + else if (alloc_comp_or_fini) gfc_trans_deferred_array (sym, block); else if (sym->ts.type == BT_CHARACTER) { diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index bd8886c..56dc766 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -7574,6 +7574,9 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, size_in_bytes = size; } + size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node, + size_in_bytes, size_one_node); + if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp) { tmp = build_call_expr_loc (input_location, --- /dev/null 2013-06-21 09:21:05.672079164 +0200 +++ gcc/gcc/testsuite/gfortran.dg/finalize_17.f90 2013-06-21 14:22:34.772034565 +0200 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! PR fortran/37336 +! +! Test for finalization of nonallocatable variables +! +module m + implicit none + type t + integer :: i + contains + final :: finit + end type t + integer, save :: called_final = -1 +contains + impure elemental subroutine finit(x) + type(t), intent(in) :: x + if (called_final == -1) call abort () + called_final = called_final + 1 + if (called_final /= x%i) call abort () + end subroutine finit +end module m + + use m + implicit none + type(t) :: x2, y2(2) + block + type(t) :: xx, yy(2) + type(t), save :: x3, y3(2) + yy%i = [1, 2] + xx%i = 3 + y3%i = [-4, -5] + x3%i = -6 + called_final = 0 + end block + if (called_final /= 3) call abort + called_final = -1 + y2%i = [-7, -8] + x2%i = -9 +end