From patchwork Mon Dec 3 15:54:55 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 203387 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 67E192C007B for ; Tue, 4 Dec 2012 02:55:21 +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=1355154922; 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=RTy4vHD KXBqkF7akaY8rF8Ab3pw=; b=QcQdNsTqgjZpztUk8Zj5quqZlI7IAP9os15ykXY fqTpFfIsw3Yq9Esf5IYCzyuwQFtVjFND2yqYlbIf44wtYOdX3C4pZ+Lxgsvt9LwI /8kndSGjLaE2Ldvf6SXQ/8byYCDgXA7D9Ui9k3pW9mZHhwJUeinRVX9PTdcpRPJT u8M8= 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=j+8ngGfEY9CEPUU4j3/YF+VvTpIe1baXhoksUbPSaNMuaQUMvRs2kLg/NdQQZG Xa8HEWwgalN+8kKo0itu8oi9lMj9NTD/gwT/+yRVPAVf2UqjRbltv4EqVHZ05NfH F3JXXzYxkxZ3iXJuB0rzG+Wb23y/D4t25YIqbMoDfNjV0=; Received: (qmail 24696 invoked by alias); 3 Dec 2012 15:55:06 -0000 Received: (qmail 24580 invoked by uid 22791); 3 Dec 2012 15:55:05 -0000 X-SWARE-Spam-Status: No, hits=-2.1 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, RCVD_IN_HOSTKARMA_NO, TW_TB, TW_VP X-Spam-Check-By: sourceware.org Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 03 Dec 2012 15:54:57 +0000 Received: from archimedes.net-b.de (port-92-195-66-45.dynamic.qsc.de [92.195.66.45]) by mx01.qsc.de (Postfix) with ESMTP id 3FEA43CD64; Mon, 3 Dec 2012 16:54:55 +0100 (CET) Message-ID: <50BCCB4F.7000100@net-b.de> Date: Mon, 03 Dec 2012 16:54:55 +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: gcc patches , gfortran Subject: [Patch, Fortran] Auxiliary functions/fixes for FINAL 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 Dear all, this patch adds some auxiliary functions for FINAL - and it fixes some issues which mainly occur with FINAL. Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias 2012-12-03 Tobias Burnus Janus Weil PR fortran/37336 * class.c (gfc_is_finalizable): New function. * gfortran.h (gfc_is_finalizable): Its prototype. * module.c (mio_component): Read initializer for vtype's _final. * resolve.c (resolve_fl_derived0): Call gfc_is_finalizable. * trans-expr.c (gfc_vtable_final_get): New function. (conv_parent_component_references): Fix comment. (gfc_conv_variable): Fix for scalar coarray components. * trans-intrinsic.c (conv_intrinsic_move_alloc): For BT_CLASS, pass the BT_CLASS type and not the declared type to gfc_deallocate_scalar_with_status. * trans.h (gfc_vtable_final_get): New prototype. diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 1271300..8a8a54a 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -2013,6 +2013,48 @@ cleanup: } +/* Check if a derived type is finalizable. That is the case if it + (1) has a FINAL subroutine or + (2) has a nonpointer nonallocatable component of finalizable type. + If it is finalizable, return an expression containing the + finalization wrapper. */ + +bool +gfc_is_finalizable (gfc_symbol *derived, gfc_expr **final_expr) +{ + gfc_symbol *vtab; + gfc_component *c; + + /* (1) Check for FINAL subroutines. */ + if (derived->f2k_derived && derived->f2k_derived->finalizers) + goto yes; + + /* (2) Check for components of finalizable type. */ + for (c = derived->components; c; c = c->next) + if (c->ts.type == BT_DERIVED + && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable + && gfc_is_finalizable (c->ts.u.derived, NULL)) + goto yes; + + return false; + +yes: + /* Make sure vtab is generated. */ + vtab = gfc_find_derived_vtab (derived); + if (final_expr) + { + /* Return finalizer expression. */ + gfc_component *final; + final = vtab->ts.u.derived->components->next->next->next->next->next; + gcc_assert (strcmp (final->name, "_final") == 0); + gcc_assert (final->initializer + && final->initializer->expr_type != EXPR_NULL); + *final_expr = final->initializer; + } + return true; +} + + /* General worker function to find either a type-bound procedure or a type-bound user operator. */ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 4942c1c..bf767b2 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2951,6 +2951,7 @@ void gfc_add_class_array_ref (gfc_expr *); #define gfc_add_hash_component(e) gfc_add_component_ref(e,"_hash") #define gfc_add_size_component(e) gfc_add_component_ref(e,"_size") #define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init") +#define gfc_add_final_component(e) gfc_add_component_ref(e,"_final") bool gfc_is_class_array_ref (gfc_expr *, bool *); bool gfc_is_class_scalar_expr (gfc_expr *); bool gfc_is_class_container_ref (gfc_expr *e); @@ -2967,6 +2968,7 @@ gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*, gfc_intrinsic_op, bool, locus*); gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*); +bool gfc_is_finalizable (gfc_symbol *, gfc_expr **); #define CLASS_DATA(sym) sym->ts.u.derived->components diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 89c45b7..16ea97b 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -2597,7 +2597,7 @@ mio_component (gfc_component *c, int vtype) c->attr.class_ok = 1; c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types); - if (!vtype) + if (!vtype || strcmp (c->name, "_final") == 0) mio_expr (&c->initializer); if (c->attr.proc_pointer) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 7d434dd..69646de 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -12814,6 +12814,10 @@ resolve_fl_derived0 (gfc_symbol *sym) /* Add derived type to the derived type list. */ add_dt_to_dt_list (sym); + /* Check if the type is finalizable. This is done in order to ensure that the + finalization wrapper is generated early enough. */ + gfc_is_finalizable (sym, NULL); + return SUCCESS; } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index d6410d3..42f6e0c 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -95,6 +95,7 @@ conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) #define VTABLE_EXTENDS_FIELD 2 #define VTABLE_DEF_INIT_FIELD 3 #define VTABLE_COPY_FIELD 4 +#define VTABLE_FINAL_FIELD 5 tree @@ -180,6 +181,13 @@ gfc_vtable_copy_get (tree decl) } +tree +gfc_vtable_final_get (tree decl) +{ + return gfc_vtable_field_get (decl, VTABLE_FINAL_FIELD); +} + + #undef CLASS_DATA_FIELD #undef CLASS_VPTR_FIELD #undef VTABLE_HASH_FIELD @@ -187,6 +195,7 @@ gfc_vtable_copy_get (tree decl) #undef VTABLE_EXTENDS_FIELD #undef VTABLE_DEF_INIT_FIELD #undef VTABLE_COPY_FIELD +#undef VTABLE_FINAL_FIELD /* Obtain the vptr of the last class reference in an expression. */ @@ -1510,7 +1519,7 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref) dt = ref->u.c.sym; c = ref->u.c.component; - /* Return if the component is not in the parent type. */ + /* Return if the component is in the parent type. */ for (cmp = dt->components; cmp; cmp = cmp->next) if (strcmp (c->name, cmp->name) == 0) return; @@ -1714,6 +1723,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) conv_parent_component_references (se, ref); gfc_conv_component_ref (se, ref); + if (!ref->next && ref->u.c.sym->attr.codimension + && se->want_pointer && se->descriptor_only) + return; break; diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index e9eb307..504a9f3 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -7321,7 +7321,7 @@ conv_intrinsic_move_alloc (gfc_code *code) /* Deallocate "to". */ tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true, - to_expr2, to_expr->ts); + to_expr, to_expr->ts); gfc_add_expr_to_block (&block, tmp); /* Assign (_data) pointers. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 954dcd3..1779575 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -348,6 +348,7 @@ tree gfc_vtable_size_get (tree); tree gfc_vtable_extends_get (tree); tree gfc_vtable_def_init_get (tree); tree gfc_vtable_copy_get (tree); +tree gfc_vtable_final_get (tree); tree gfc_get_vptr_from_expr (tree); tree gfc_get_class_array_ref (tree, tree); tree gfc_copy_class_to_class (tree, tree, tree);