From patchwork Sat Jun 2 12:58:01 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Alessandro Fanfarillo X-Patchwork-Id: 162409 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 D6B6DB700C for ; Sat, 2 Jun 2012 22:58:25 +1000 (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=1339246706; h=Comment: DomainKey-Signature:Received:Received:Received:Received: MIME-Version:Received:Received:Date:Message-ID:Subject:From:To: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=NmZEQNn UzMcsISG19zCjIW/i98o=; b=Z0Z6Aa/x1d5tT5NNuTpV0gDAgvr5g2kbaq4HuuX IqQPJJfebmFprvXdK3xz/z0bzMliqmQiRRT5HEoPOu6Ll35grBaHyCDtFm+ItGcu FzNjf8mkwWLZinNMKMKf9VGEF20bvsHx/+lxYXke1rSJSZbchZInFDBza/tgF57u zRbw= 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:MIME-Version:Received:Received:Date:Message-ID:Subject:From:To:Content-Type:X-IsSubscribed:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=wg/60Su0A0bPPZzQyEPPbpEaoij1NoouzeVpyMcSVeDgmi82XHnZeOiLE0oCuQ /GZpIImro93GLm9BHsaiOZWEVWZLSiPUiab3FUHeIRHnhQg5F2ZhL5ArhxCPOPHd mkluzmve+KmaP1V04XlUS25Iatgb28aBdeUd+4gl3AOd4=; Received: (qmail 7677 invoked by alias); 2 Jun 2012 12:58:18 -0000 Received: (qmail 7664 invoked by uid 22791); 2 Jun 2012 12:58:16 -0000 X-SWARE-Spam-Status: No, hits=-3.0 required=5.0 tests=AWL, BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, FREEMAIL_FROM, KHOP_RCVD_TRUST, RCVD_IN_DNSWL_LOW, RCVD_IN_HOSTKARMA_YE X-Spam-Check-By: sourceware.org Received: from mail-lb0-f175.google.com (HELO mail-lb0-f175.google.com) (209.85.217.175) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sat, 02 Jun 2012 12:58:03 +0000 Received: by lbol5 with SMTP id l5so2419554lbo.20 for ; Sat, 02 Jun 2012 05:58:01 -0700 (PDT) MIME-Version: 1.0 Received: by 10.152.108.38 with SMTP id hh6mr6454901lab.28.1338641881266; Sat, 02 Jun 2012 05:58:01 -0700 (PDT) Received: by 10.114.21.129 with HTTP; Sat, 2 Jun 2012 05:58:01 -0700 (PDT) Date: Sat, 2 Jun 2012 14:58:01 +0200 Message-ID: Subject: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation From: Alessandro Fanfarillo To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org X-IsSubscribed: yes 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, I have realized a draft patch for the PR 46321, currently it works only with the explicit DEALLOCATE. Running the regression tests it doesn't pass the following: - gfortran.dg/class_19.f03 (too much "__builtin_free") - gfortran.dg/auto_dealloc_2.f90 (too much "__builtin_free") - gfortran.dg/dynamic_dispatch_4.f03 (free on invalid pointer) - gfortran.dg/typebound_operator_9.f03 (fails during the execution test) The first two tests fail due to the introduction of "__builtin_free" in the freeing functions, so it is not a problem. The gfortran.dg/dynamic_dispatch_4.f03 had this problem in the past (http://gcc.gnu.org/bugzilla/show_bug.cgi?id=43986); currently it calls the __free_s_bar_mod_S_bar function instead of the proper doit(). Regarding typebound_operator_9.f03, I don't know how to fix the patch... The patch is written in a "raw" way due to my newbieness, so any suggestion is well accepted. Regards. Alessandro Index: gcc/fortran/class.c =================================================================== --- gcc/fortran/class.c (revisione 188002) +++ gcc/fortran/class.c (copia locale) @@ -717,6 +717,7 @@ gfc_namespace *ns; gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; + gfc_symbol *free = NULL, *tofree = NULL; /* Find the top-level namespace (MODULE or PROGRAM). */ for (ns = gfc_current_ns; ns; ns = ns->parent) @@ -907,6 +908,119 @@ c->ts.interface = copy; } + /* Add component _free. */ + gfc_component *temp = NULL; + bool der_comp_alloc = false, comp_alloc = false; + bool class_comp_alloc = false; + for (temp = derived->components; temp; temp = temp->next) + { + if (temp == derived->components && derived->attr.extension) + continue; + + if (temp->ts.type == BT_DERIVED + && !temp->attr.pointer + && (temp->attr.alloc_comp || temp->attr.allocatable)) + der_comp_alloc = true; + else if (temp->ts.type != BT_DERIVED + && !temp->attr.pointer + && (temp->attr.alloc_comp + || temp->attr.allocatable)) + comp_alloc = true; + else if (temp->ts.u.derived + && temp->ts.type == BT_CLASS + && CLASS_DATA (temp) + //&& (CLASS_DATA (temp)->attr.class_pointer + // || CLASS_DATA (temp)->attr.allocatable)) + && CLASS_DATA (temp)->attr.allocatable) + class_comp_alloc = true; + } + if (derived->attr.extension + && (!der_comp_alloc && !comp_alloc && !class_comp_alloc)) + { + gfc_component *parent = derived->components; + gfc_component *free_proc = NULL; + gfc_symbol *vtab2 = NULL; + gfc_expr *tmp1 = NULL, *tmp2 = NULL; + vtab2 = gfc_find_derived_vtab (parent->ts.u.derived); + + for (free_proc = vtab2->ts.u.derived->components; + free_proc; free_proc = free_proc->next) + if (free_proc->name[0] == '_' + && free_proc->name[1] == 'f') + break; + + if (!free_proc) + goto end_vtab; + + if (gfc_add_component (vtype, "_free", &c) == FAILURE) + goto cleanup; + c->attr.proc_pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->tb = XCNEW (gfc_typebound_proc); + c->tb->ppc = 1; + /* Not sure about this part */ + tmp1 = gfc_lval_expr_from_sym (free_proc->ts.interface); + tmp2 = gfc_copy_expr (tmp1); + c->initializer = tmp2; + c->ts.interface = tmp2->symtree->n.sym; + goto end_vtab; + + } + + if (derived->attr.alloc_comp || der_comp_alloc + || class_comp_alloc) + { + gfc_alloc *head = NULL; + if (gfc_add_component (vtype, "_free", &c) == FAILURE) + goto cleanup; + c->attr.proc_pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->tb = XCNEW (gfc_typebound_proc); + c->tb->ppc = 1; + if (derived->attr.abstract) + c->initializer = gfc_get_null_expr (NULL); + else + { + /* Set up namespace. */ + gfc_namespace *sub_ns2 = gfc_get_namespace (ns, 0); + sub_ns2->sibling = ns->contained; + ns->contained = sub_ns2; + sub_ns2->resolved = 1; + /* Set up procedure symbol. */ + sprintf (name, "__free_%s", tname); + gfc_get_symbol (name, sub_ns2, &free); + sub_ns2->proc_name = free; + free->attr.flavor = FL_PROCEDURE; + free->attr.subroutine = 1; + free->attr.if_source = IFSRC_DECL; + /* This is elemental so that arrays are automatically + treated correctly by the scalarizer. */ + free->attr.elemental = 1; + if (ns->proc_name->attr.flavor == FL_MODULE) + free->module = ns->proc_name->name; + gfc_set_sym_referenced (free); + /* Set up formal arguments. */ + gfc_get_symbol ("tofree", sub_ns2, &tofree); + tofree->ts.type = BT_DERIVED; + tofree->ts.u.derived = derived; + tofree->attr.flavor = FL_VARIABLE; + tofree->attr.dummy = 1; + tofree->attr.intent = INTENT_OUT; + gfc_set_sym_referenced (tofree); + free->formal = gfc_get_formal_arglist (); + free->formal->sym = tofree; + /* Set up code. */ + sub_ns2->code = gfc_get_code (); + sub_ns2->code->op = EXEC_NOP; + head = gfc_get_alloc (); + head->expr = gfc_lval_expr_from_sym (tofree); + sub_ns2->code->ext.alloc.list = head; + /* Set initializer. */ + c->initializer = gfc_lval_expr_from_sym (free); + c->ts.interface = free; + } + } +end_vtab: /* Add procedure pointers for type-bound procedures. */ add_procs_to_declared_vtab (derived, vtype); } @@ -935,6 +1049,10 @@ gfc_commit_symbol (src); if (dst) gfc_commit_symbol (dst); + if (free) + gfc_commit_symbol (free); + if (tofree) + gfc_commit_symbol (tofree); } else gfc_undo_symbols (); Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (revisione 188002) +++ gcc/fortran/trans-stmt.c (copia locale) @@ -5343,6 +5343,11 @@ { gfc_expr *expr = gfc_copy_expr (al->expr); gcc_assert (expr->expr_type == EXPR_VARIABLE); + gfc_expr *ppc; + gfc_code *ppc_code; + gfc_actual_arglist *actual; + gfc_component *free_proc = NULL; + gfc_symbol *vtab2 = NULL, *tmp_sym = NULL; if (expr->ts.type == BT_CLASS) gfc_add_data_component (expr); @@ -5354,6 +5359,43 @@ se.descriptor_only = 1; gfc_conv_expr (&se, expr); + actual = gfc_get_actual_arglist (); + actual->expr = gfc_copy_expr (expr); + if (expr->symtree->n.sym->ts.type == BT_CLASS + && expr->symtree->n.sym->tlink + && expr->symtree->n.sym->tlink->ts.u.derived) + { + if (expr->ref && expr->ref->u.c.component->ts.type == BT_CLASS) + { + tmp_sym = expr->ref->u.c.component->ts.u.derived; + tmp_sym = tmp_sym->components->ts.u.derived; + } + else + { + tmp_sym = expr->symtree->n.sym->tlink->ts.u.derived; + } + vtab2 = gfc_find_derived_vtab (tmp_sym); + vtab2 = vtab2->ts.u.derived; + for (free_proc = vtab2->components; + free_proc; free_proc = free_proc->next) + if (free_proc->name[0] == '_' + && free_proc->name[1] == 'f') + break; + if (free_proc) + { + ppc = gfc_copy_expr(free_proc->initializer); + ppc_code = gfc_get_code (); + ppc_code->resolved_sym = ppc->symtree->n.sym; + ppc_code->resolved_sym->attr.elemental = 1; + ppc_code->ext.actual = actual; + ppc_code->expr1 = ppc; + ppc_code->op = EXEC_CALL; + tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false); + gfc_free_statements (ppc_code); + gfc_add_expr_to_block (&block, tmp); + } + } + if (expr->rank || gfc_is_coarray (expr)) { if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)