From patchwork Mon Dec 5 13:31:34 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 86566 Delivered-To: patch@linaro.org Received: by 10.140.20.101 with SMTP id 92csp1477219qgi; Mon, 5 Dec 2016 05:32:21 -0800 (PST) X-Received: by 10.84.143.233 with SMTP id 96mr126470609plz.27.1480944741395; Mon, 05 Dec 2016 05:32:21 -0800 (PST) Return-Path: Received: from sourceware.org (server1.sourceware.org. [209.132.180.131]) by mx.google.com with ESMTPS id 59si14710927pld.76.2016.12.05.05.32.21 for (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Mon, 05 Dec 2016 05:32:21 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-return-443472-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) client-ip=209.132.180.131; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org; spf=pass (google.com: domain of gcc-patches-return-443472-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) smtp.mailfrom=gcc-patches-return-443472-patch=linaro.org@gcc.gnu.org DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:in-reply-to:references :mime-version:content-type; q=dns; s=default; b=Fu7hIesvzHLjoZ8c 1+W6LEh3847tTJ7BoWxEm8EJ79RUaVFsNDdFWhkxyuAQodznMsjT5eNw44MydRdv I23NNCFqhC8JT56Cvu8mjrtMZDZDrIgsyOL7RhZ2CNpgY0TK7U75OmCrV+ibE3S1 sTNMPrpOh030NwpxJ0xsAs7lytc= 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:date :from:to:cc:subject:message-id:in-reply-to:references :mime-version:content-type; s=default; bh=JllVBtckA/IfEBwPoOOrYo cRypA=; b=l1n7pWH03KHvoShsIKkdzRmjP5DAO5TkRJPYhYKFXc8fIWdY27UuJf tlSymkOuL+Ex+SRnVZNbB0LQXbRDMIjNBjf3Hz12nzVeyfNVisQpw52ZFPzMIcuB +qYLIGP/9CNuZ+kZPR5x7pG0fS6oT+k3wMZwkJ/VPI8d8hxpB9oFw= Received: (qmail 113037 invoked by alias); 5 Dec 2016 13:32:02 -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 112950 invoked by uid 89); 5 Dec 2016 13:31:59 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-2.5 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.2 spammy=vehregccgnuorg, vehre@gcc.gnu.org, Therefore, almighty X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.17.20) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Mon, 05 Dec 2016 13:31:48 +0000 Received: from vepi2 ([92.76.205.227]) by mail.gmx.com (mrgmx103 [212.227.17.168]) with ESMTPSA (Nemesis) id 0MWkZL-1cBsMu3cGR-00Xvzj; Mon, 05 Dec 2016 14:31:36 +0100 Date: Mon, 5 Dec 2016 14:31:34 +0100 From: Andre Vehreschild To: Dominique =?UTF-8?B?ZCdIdW1pw6hyZXM=?= Cc: Fortran List , GCC-Patches-ML Subject: Re: [PATCH, Fortran, v3] Fix deallocation of nested derived typed components Message-ID: <20161205143134.0fb5b657@vepi2> In-Reply-To: <7CB940C9-7157-42E7-B511-B6E6F6A2ED89@lps.ens.fr> References: <5B28CFDC-65D8-4FD1-8588-1100E1997FD9@lps.ens.fr> <20161203125132.3a0e6995@vepi2> <7A541266-DB7C-4A4D-BF06-B47DEB96CCF4@lps.ens.fr> <20161203195128.03b5a90a@vepi2> <7CB940C9-7157-42E7-B511-B6E6F6A2ED89@lps.ens.fr> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; V01:K0:8H7wh37DGq4=:csD8fI860Ff4LDmBbwEzIs a/M6WVbdcG35+unB07cibqLE7gOSQujzHyzpImNnCE12fnqLFZ6pLbOHzddmb02z9YUFvsY0k AtjT4zjvQ89MVlDUWs24zohbe3EzcK+0fk8IPuT0yk1crBTNjHnwdtaqqSNwCFi6vTWxBhhI8 mQG+NbJAVIEQEy5x9JT4Xehh0NwgQy3J4JIdN+DTaPTQO+tBEnFhD2F+rJsFX1FLdGRgfKO78 au+0bgUzCFJzKriN2Tbmq8gj44TlS7mO5/drSXaHcRcKUEee8OaooTSQJDIClEPvNv17pji8S 4gPcShryD8ncP2z89MTluTdwEnWIn/+R6Y2KRmOFZaDN6QG9XrlyRgE6iy2j49Fsp5pqGyt5M 3ca5FHb1k2Cz5CfDPYhVCH8c4yN7SkOCLJ9huVLDPJLwit+Y6SRRTycP55urPQtEAuLM7KgJ6 te0zW5qENbpj9Q4rf2+aFMkYB/KC1XFNU3y82or49w4HC7+9BnlslEa0tkCPlcUj7POKiF5va Hvqwe8cDaZAyt4Q0ghTj4qE1BQukgUFWx2VxaFiv6hAvglZABUsg/9gzkHXzfpqbByCctTTdY o3vLzvQf+B9q4fWq61U1cfP2o3rNSsXdgt0/1ez2fV7iRIcK6WVHH0QQankt2McSA6u/OwAKV engVvybc9EpfRtawmCzQiZObKr/xpLcAMvMs3vNH6liPCBuVe8jdkiCYcYdG0EesmRH4D0yIr ajZozxK6tTZ1msgk+FYsyte1W938sehB4MJo8UB3+z4t+M9CqCKlbiMV5GI= Hi Dominique, hi all, @Dominique: Thanks for testing. I have extended my usual testcycle to add the libgomp.fortran tests. I could fix the errors below by calling deallocate_with_status directly from the trans_omp_*-routines instead of using the gfc_array_deallocate wrapper. While being at it, I made deallocate_with_status almighty when freeing memory. gfc_deallocate_with_status now frees memory of scalars or arrays, coarrayed scalars or coarrayed arrays without having to massage the inputs of the routine. The benefit of this is, that instead of having four routines that are able to deallocate a special kind of allocated object, there now are only two (gfc_deallocate_scalar_with_status can be removed, too, but means changes in many places which would enlarge this patch even more. Therefore I have not yet done it.). I.e. no longer guessing which routine to call for freeing an allocatable object -> hand it to deallocate_with_status and be done. Bootstraps and regtests ok on x86_64-linux/F23. Ok for trunk? Regards, Andre On Sun, 4 Dec 2016 00:59:00 +0100 Dominique d'Humières wrote: > Hi Andre, > > I fear the patch is causing another set of failures with -fopenmp: > > FAIL: libgomp.fortran/allocatable11.f90 -O0 (internal compiler error) > … > FAIL: libgomp.fortran/allocatable8.f90 -g -flto (test for excess errors) > > of the kind > > collect2: error: ld returned 1 exit status > [Book15] f90/bug% > gfc /opt/gcc/work/libgomp/testsuite/libgomp.fortran/allocatable2.f90 > -fopenmp /opt/gcc/work/libgomp/testsuite/libgomp.fortran/allocatable2.f90:46:0: > > if (l.or.allocated (a)) call abort > > Error: incorrect sharing of tree nodes > a.data > a.data = 0B; > /opt/gcc/work/libgomp/testsuite/libgomp.fortran/allocatable2.f90:46:0: > internal compiler error: verify_gimple failed > > Dominique > > > Le 3 déc. 2016 à 19:51, Andre Vehreschild a écrit : > > > > Hi all, > > > > @Dominique: Thanks for checking. And also for pointing out that the initial > > version of the patch ICEd on some already closed PRs. The objective of those > > PRs does not seem to be covered by the current testsuite. I therefore > > additionally propose to add attached testcase. Ok for trunk? > > > > Of course with appropriate Changelog-entry. > > > > Regards, > > Andre > -- Andre Vehreschild * Email: vehre ad gmx dot de gcc/fortran/ChangeLog: 2016-12-05 Andre Vehreschild * trans-array.c (gfc_array_deallocate): Remove wrapper. (gfc_trans_dealloc_allocated): Same. (structure_alloc_comps): Restructure deallocation of (nested) allocatable components. Insert dealloc of sub-component into the block guarded by the if != NULL for the component. (gfc_trans_deferred_array): Use the almightly deallocate_with_status. * trans-array.h: Remove prototypes. * trans-expr.c (gfc_conv_procedure_call): Use the almighty deallocate_ with_status. * trans-openmp.c (gfc_walk_alloc_comps): Likewise. (gfc_omp_clause_assign_op): Likewise. (gfc_omp_clause_dtor): Likewise. * trans-stmt.c (gfc_trans_deallocate): Likewise. * trans.c (gfc_deallocate_with_status): Allow deallocation of scalar and arrays as well as coarrays. (gfc_deallocate_scalar_with_status): Get the data member for coarrays only when freeing an array with descriptor. And set correct caf_mode when freeing components of coarrays. * trans.h: Change prototype of gfc_deallocate_with_status to allow adding statements into the block guarded by the if (pointer != 0) and supply a coarray handle. gcc/testsuite/ChangeLog: 2016-12-05 Andre Vehreschild * gfortran.dg/coarray_alloc_comp_3.f08: New test. * gfortran.dg/coarray_alloc_comp_4.f08: New test. * gfortran.dg/finalize_18.f90: Add count for additional guard against accessing null-pointer. * gfortran.dg/proc_ptr_comp_47.f90: New test. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index ac90a4b..8753cbf 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5652,53 +5652,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, } -/* Deallocate an array variable. Also used when an allocated variable goes - out of scope. */ -/*GCC ARRAYS*/ - -tree -gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen, - tree label_finish, gfc_expr* expr, - int coarray_dealloc_mode) -{ - tree var; - tree tmp; - stmtblock_t block; - bool coarray = coarray_dealloc_mode != GFC_CAF_COARRAY_NOCOARRAY; - - gfc_start_block (&block); - - /* Get a pointer to the data. */ - var = gfc_conv_descriptor_data_get (descriptor); - STRIP_NOPS (var); - - /* Parameter is the address of the data component. */ - tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg, - errlen, label_finish, false, expr, - coarray_dealloc_mode); - gfc_add_expr_to_block (&block, tmp); - - /* Zero the data pointer; only for coarrays an error can occur and then - the allocation status may not be changed. */ - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - var, build_int_cst (TREE_TYPE (var), 0)); - if (pstat != NULL_TREE && coarray && flag_coarray == GFC_FCOARRAY_LIB) - { - tree cond; - tree stat = build_fold_indirect_ref_loc (input_location, pstat); - - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - stat, build_int_cst (TREE_TYPE (stat), 0)); - 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 gfc_finish_block (&block); -} - - /* Create an array constructor from an initialization expression. We assume the frontend already did any expansions and conversions. */ @@ -7806,39 +7759,6 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, } -/* Generate code to deallocate an array, if it is allocated. */ - -tree -gfc_trans_dealloc_allocated (tree descriptor, gfc_expr *expr, - int coarray_dealloc_mode) -{ - tree tmp; - tree var; - stmtblock_t block; - bool coarray = coarray_dealloc_mode != GFC_CAF_COARRAY_NOCOARRAY; - - gfc_start_block (&block); - - var = gfc_conv_descriptor_data_get (descriptor); - STRIP_NOPS (var); - - /* Call array_deallocate with an int * present in the second argument. - Although it is ignored here, it's presence ensures that arrays that - are already deallocated are ignored. */ - tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE, - NULL_TREE, NULL_TREE, NULL_TREE, true, expr, - coarray_dealloc_mode); - gfc_add_expr_to_block (&block, tmp); - - /* Zero the data pointer. */ - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - var, build_int_cst (TREE_TYPE (var), 0)); - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); -} - - /* This helper function calculates the size in words of a full array. */ tree @@ -8157,8 +8077,11 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree null_cond = NULL_TREE; tree add_when_allocated; tree dealloc_fndecl; - bool called_dealloc_with_status; + tree caf_token; gfc_symbol *vtab; + int caf_dereg_mode; + symbol_attribute *attr; + bool deallocate_called; gfc_init_block (&fnblock); @@ -8265,7 +8188,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) && c->ts.u.derived->attr.alloc_comp; - bool same_type = c->ts.type == BT_DERIVED && der_type == c->ts.u.derived; + bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived) + || (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived); cdecl = c->backend_decl; ctype = TREE_TYPE (cdecl); @@ -8274,112 +8198,118 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, { case DEALLOCATE_ALLOC_COMP: - /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp - (i.e. this function) so generate all the calls and suppress the - recursion from here, if necessary. */ - called_dealloc_with_status = false; gfc_init_block (&tmpblock); + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + + /* Shortcut to get the attributes of the component. */ + if (c->ts.type == BT_CLASS) + attr = &CLASS_DATA (c)->attr; + else + attr = &c->attr; + 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); + || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)) + /* Call the finalizer, which will free the memory and nullify the + pointer of an array. */ + deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c, + caf_enabled (caf_mode)) + && attr->dimension; + else + deallocate_called = false; + + /* Add the _class ref for classes. */ + if (c->ts.type == BT_CLASS && attr->allocatable) + comp = gfc_class_data_get (comp); - /* The finalizer frees allocatable components. */ - called_dealloc_with_status - = gfc_add_comp_finalizer_call (&tmpblock, comp, c, - purpose == DEALLOCATE_ALLOC_COMP - && caf_enabled (caf_mode)); + add_when_allocated = NULL_TREE; + if (cmp_has_alloc_comps + && !c->attr.pointer && !c->attr.proc_pointer + && !same_type + && !deallocate_called) + { + /* Add checked deallocation of the components. This code is + obviously added because the finalizer is not trusted to free + all memory. */ + if (c->ts.type == BT_CLASS) + { + rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0; + add_when_allocated + = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived, + comp, NULL_TREE, rank, purpose, + caf_mode); + } + else + { + rank = c->as ? c->as->rank : 0; + add_when_allocated = structure_alloc_comps (c->ts.u.derived, + comp, NULL_TREE, + rank, purpose, + caf_mode); + } } - else - comp = NULL_TREE; - if (c->attr.allocatable && !c->attr.proc_pointer && !same_type - && (c->attr.dimension - || (caf_enabled (caf_mode) - && (caf_in_coarray (caf_mode) || c->attr.codimension)))) + if (attr->allocatable && !same_type + && (!attr->codimension || caf_enabled (caf_mode))) { - /* Allocatable arrays or coarray'ed components (scalar or - array). */ - int caf_dereg_mode - = (caf_in_coarray (caf_mode) || c->attr.codimension) + /* Handle all types of components besides components of the + same_type as the current one, because those would create an + endless loop. */ + caf_dereg_mode + = (caf_in_coarray (caf_mode) || attr->codimension) ? (gfc_caf_is_dealloc_only (caf_mode) ? GFC_CAF_COARRAY_DEALLOCATE_ONLY : GFC_CAF_COARRAY_DEREGISTER) : GFC_CAF_COARRAY_NOCOARRAY; - if (comp == NULL_TREE) - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - if (c->attr.dimension || c->attr.codimension) - /* Deallocate array. */ - tmp = gfc_trans_dealloc_allocated (comp, NULL, caf_dereg_mode); - else + caf_token = NULL_TREE; + /* Coarray components are handled directly by + deallocate_with_status. */ + if (!attr->codimension + && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY) { - /* Deallocate scalar. */ - tree cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, comp, - build_int_cst (TREE_TYPE (comp), - 0)); - - tmp = fold_build3_loc (input_location, COMPONENT_REF, - pvoid_type_node, decl, c->caf_token, - NULL_TREE); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_deregister, 5, - gfc_build_addr_expr (NULL_TREE, - tmp), - build_int_cst (integer_type_node, - caf_dereg_mode), - null_pointer_node, - null_pointer_node, - integer_zero_node); - tmp = fold_build3_loc (input_location, COND_EXPR, - void_type_node, cond, tmp, - build_empty_stmt (input_location)); + if (c->caf_token) + caf_token = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (c->caf_token), + decl, c->caf_token, NULL_TREE); + else if (attr->dimension && !attr->proc_pointer) + caf_token = gfc_conv_descriptor_token (comp); } + if (attr->dimension && !attr->codimension && !attr->proc_pointer) + /* When this is an array but not in conjunction with a coarray + then add the data-ref. For coarray'ed arrays the data-ref + is added by deallocate_with_status. */ + comp = gfc_conv_descriptor_data_get (comp); - gfc_add_expr_to_block (&tmpblock, tmp); - } - else if (c->attr.allocatable && !c->attr.codimension && !same_type) - { - /* Allocatable scalar components. */ - 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_TREE, - NULL_TREE, true, NULL, - c->ts); - gfc_add_expr_to_block (&tmpblock, tmp); - called_dealloc_with_status = true; + tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, + NULL, caf_dereg_mode, + add_when_allocated, caf_token); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); gfc_add_expr_to_block (&tmpblock, tmp); } - else if (c->attr.allocatable && !c->attr.codimension) + else if (attr->allocatable && !attr->codimension + && !deallocate_called) { /* Case of recursive allocatable derived types. */ tree is_allocated; tree ubound; tree cdesc; - tree data; stmtblock_t dealloc_block; gfc_init_block (&dealloc_block); + if (add_when_allocated) + gfc_add_expr_to_block (&dealloc_block, add_when_allocated); /* Convert the component into a rank 1 descriptor type. */ - if (comp == NULL_TREE) - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - - if (c->attr.dimension) + if (attr->dimension) { tmp = gfc_get_element_type (TREE_TYPE (comp)); - ubound = gfc_full_array_size (&dealloc_block, comp, c->as->rank); + ubound = gfc_full_array_size (&dealloc_block, comp, + c->ts.type == BT_CLASS + ? CLASS_DATA (c)->as->rank + : c->as->rank); } else { @@ -8405,12 +8335,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc, gfc_index_zero_node, ubound); - if (c->attr.dimension) - data = gfc_conv_descriptor_data_get (comp); - else - data = comp; + if (attr->dimension) + comp = gfc_conv_descriptor_data_get (comp); - gfc_conv_descriptor_data_set (&dealloc_block, cdesc, data); + gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp); /* Now call the deallocator. */ vtab = gfc_find_vtab (&c->ts); @@ -8420,10 +8348,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, dealloc_fndecl = gfc_vptr_deallocate_get (tmp); dealloc_fndecl = build_fold_indirect_ref_loc (input_location, dealloc_fndecl); - tmp = build_int_cst (TREE_TYPE (data), 0); + tmp = build_int_cst (TREE_TYPE (comp), 0); is_allocated = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, - data); + comp); cdesc = gfc_build_addr_expr (NULL_TREE, cdesc); tmp = build_call_expr_loc (input_location, @@ -8438,49 +8366,20 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, build_empty_stmt (input_location)); gfc_add_expr_to_block (&tmpblock, tmp); - - gfc_add_modify (&tmpblock, data, - build_int_cst (TREE_TYPE (data), 0)); } + else if (add_when_allocated) + gfc_add_expr_to_block (&tmpblock, add_when_allocated); - else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable - && (!CLASS_DATA (c)->attr.codimension - || !caf_enabled (caf_mode))) + if (c->ts.type == BT_CLASS && attr->allocatable + && (!attr->codimension || !caf_enabled (caf_mode))) { - /* Allocatable CLASS components. */ - - /* Add reference to '_data' component. */ - tmp = CLASS_DATA (c)->backend_decl; - comp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (tmp), comp, tmp, NULL_TREE); - - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) - tmp = gfc_trans_dealloc_allocated (comp, NULL, - CLASS_DATA (c)->attr.codimension - ? GFC_CAF_COARRAY_DEREGISTER - : GFC_CAF_COARRAY_NOCOARRAY); - else - { - tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, - NULL_TREE, true, - NULL, - CLASS_DATA (c)->ts); - gfc_add_expr_to_block (&tmpblock, tmp); - called_dealloc_with_status = true; - - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); - } - gfc_add_expr_to_block (&tmpblock, tmp); - /* Finally, reset the vptr to the declared type vtable and, if necessary reset the _len field. First recover the reference to the component and obtain the vptr. */ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); + decl, cdecl, NULL_TREE); tmp = gfc_class_vptr_get (comp); if (UNLIMITED_POLY (c)) @@ -8507,22 +8406,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, } } - if (cmp_has_alloc_comps - && !c->attr.pointer && !c->attr.proc_pointer - && !same_type - && !called_dealloc_with_status) - { - /* Do not deallocate the components of ultimate pointer - components or iteratively call self if call has been made - to gfc_trans_dealloc_allocated */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - rank = c->as ? c->as->rank : 0; - tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, - rank, purpose, caf_mode); - gfc_add_expr_to_block (&fnblock, tmp); - } - /* Now add the deallocation of this component. */ gfc_add_block_to_block (&fnblock, &tmpblock); break; @@ -9723,10 +9606,11 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) { gfc_expr *e; e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL; - tmp = gfc_trans_dealloc_allocated (sym->backend_decl, e, - sym->attr.codimension - ? GFC_CAF_COARRAY_DEREGISTER - : GFC_CAF_COARRAY_NOCOARRAY); + tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, e, + sym->attr.codimension + ? GFC_CAF_COARRAY_DEREGISTER + : GFC_CAF_COARRAY_NOCOARRAY); if (e) gfc_free_expr (e); gfc_add_expr_to_block (&cleanup, tmp); diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 0a6621b..ab0a6de 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -18,9 +18,6 @@ You should have received a copy of the GNU General Public License along with GCC; see the file COPYING3. If not see . */ -/* Generate code to free an array. */ -tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*, int c = -2); - /* Generate code to initialize and allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, @@ -41,8 +38,6 @@ void gfc_trans_auto_array_allocation (tree, gfc_symbol *, gfc_wrapped_block *); void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *); /* Generate entry and exit code for g77 calling convention arrays. */ void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *); -/* Generate code to deallocate an array, if it is allocated. */ -tree gfc_trans_dealloc_allocated (tree, gfc_expr *, int); tree gfc_full_array_size (stmtblock_t *, tree, int); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 78bff87..8d7e881 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5441,8 +5441,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); - tmp = gfc_trans_dealloc_allocated (tmp, e, - GFC_CAF_COARRAY_NOCOARRAY); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_conv_descriptor_data_get (tmp); + tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, + e, + GFC_CAF_COARRAY_NOCOARRAY); if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index d460048..6bc2dcd 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -420,8 +420,11 @@ gfc_walk_alloc_comps (tree decl, tree dest, tree var, if (GFC_DESCRIPTOR_TYPE_P (ftype) && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) { - tem = gfc_trans_dealloc_allocated (unshare_expr (declf), NULL, - GFC_CAF_COARRAY_NOCOARRAY); + tem = gfc_conv_descriptor_data_get (unshare_expr (declf)); + tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, + NULL, + GFC_CAF_COARRAY_NOCOARRAY); gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); } else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) @@ -810,10 +813,13 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src) { gfc_init_block (&cond_block); if (GFC_DESCRIPTOR_TYPE_P (type)) - gfc_add_expr_to_block (&cond_block, - gfc_trans_dealloc_allocated (unshare_expr (dest), - NULL, - GFC_CAF_COARRAY_NOCOARRAY)); + { + tree tmp = gfc_conv_descriptor_data_get (unshare_expr (dest)); + tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, NULL, + GFC_CAF_COARRAY_NOCOARRAY); + gfc_add_expr_to_block (&cond_block, tmp); + } else { destptr = gfc_evaluate_now (destptr, &cond_block); @@ -987,9 +993,14 @@ gfc_omp_clause_dtor (tree clause, tree decl) } if (GFC_DESCRIPTOR_TYPE_P (type)) - /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need - to be deallocated if they were allocated. */ - tem = gfc_trans_dealloc_allocated (decl, NULL, GFC_CAF_COARRAY_NOCOARRAY); + { + /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need + to be deallocated if they were allocated. */ + tem = gfc_conv_descriptor_data_get (decl); + tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, NULL_TREE, + NULL_TREE, true, NULL, + GFC_CAF_COARRAY_NOCOARRAY); + } else tem = gfc_call_free (decl); tem = gfc_omp_unshare_expr (tem); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 514db28..5ca716b 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -6489,8 +6489,9 @@ gfc_trans_deallocate (gfc_code *code) : GFC_CAF_COARRAY_DEREGISTER; else caf_dtype = GFC_CAF_COARRAY_NOCOARRAY; - tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen, - label_finish, expr, caf_dtype); + tmp = gfc_deallocate_with_status (se.expr, pstat, errmsg, errlen, + label_finish, false, expr, + caf_dtype); gfc_add_expr_to_block (&se.pre, tmp); } else if (TREE_CODE (se.expr) == COMPONENT_REF diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 6a1d481..e5dd986 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1281,31 +1281,58 @@ tree gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree errlen, tree label_finish, bool can_fail, gfc_expr* expr, - int coarray_dealloc_mode) + int coarray_dealloc_mode, tree add_when_allocated, + tree caf_token) { stmtblock_t null, non_null; tree cond, tmp, error; tree status_type = NULL_TREE; - tree caf_decl = NULL_TREE; + tree token = NULL_TREE; gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER; if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE) { - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))); - caf_decl = pointer; - pointer = gfc_conv_descriptor_data_get (caf_decl); - STRIP_NOPS (pointer); - if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE) + if (flag_coarray == GFC_FCOARRAY_LIB) { - bool comp_ref; - if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp - && comp_ref) - caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY; - // else do a deregister as set by default. + if (caf_token) + token = caf_token; + else + { + tree caf_type, caf_decl = pointer; + pointer = gfc_conv_descriptor_data_get (caf_decl); + caf_type = TREE_TYPE (caf_decl); + STRIP_NOPS (pointer); + if (GFC_DESCRIPTOR_TYPE_P (caf_type) + && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE) + token = gfc_conv_descriptor_token (caf_decl); + else if (DECL_LANG_SPECIFIC (caf_decl) + && GFC_DECL_TOKEN (caf_decl) != NULL_TREE) + token = GFC_DECL_TOKEN (caf_decl); + else + { + gcc_assert (GFC_ARRAY_TYPE_P (caf_type) + && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) + != NULL_TREE); + token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); + } + } + + if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE) + { + bool comp_ref; + if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp + && comp_ref) + caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY; + // else do a deregister as set by default. + } + else + caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode; } - else - caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode; + else if (flag_coarray == GFC_FCOARRAY_SINGLE) + pointer = gfc_conv_descriptor_data_get (pointer); } + else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) + pointer = gfc_conv_descriptor_data_get (pointer); cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, build_int_cst (TREE_TYPE (pointer), 0)); @@ -1348,6 +1375,8 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, /* When POINTER is not NULL, we free it. */ gfc_start_block (&non_null); + if (add_when_allocated) + gfc_add_expr_to_block (&non_null, add_when_allocated); gfc_add_finalizer_call (&non_null, expr); if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY || flag_coarray != GFC_FCOARRAY_LIB) @@ -1356,6 +1385,8 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, builtin_decl_explicit (BUILT_IN_FREE), 1, fold_convert (pvoid_type_node, pointer)); gfc_add_expr_to_block (&non_null, tmp); + gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer), + 0)); if (status != NULL_TREE && !integer_zerop (status)) { @@ -1378,8 +1409,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, } else { - tree caf_type, token, cond2; - tree pstat = null_pointer_node; + tree cond2, pstat = null_pointer_node; if (errmsg == NULL_TREE) { @@ -1394,27 +1424,12 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, errmsg = gfc_build_addr_expr (NULL_TREE, errmsg); } - caf_type = TREE_TYPE (caf_decl); - if (status != NULL_TREE && !integer_zerop (status)) { gcc_assert (status_type == integer_type_node); pstat = status; } - if (GFC_DESCRIPTOR_TYPE_P (caf_type) - && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE) - token = gfc_conv_descriptor_token (caf_decl); - else if (DECL_LANG_SPECIFIC (caf_decl) - && GFC_DECL_TOKEN (caf_decl) != NULL_TREE) - token = GFC_DECL_TOKEN (caf_decl); - else - { - gcc_assert (GFC_ARRAY_TYPE_P (caf_type) - && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE); - token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); - } - token = gfc_build_addr_expr (NULL_TREE, token); gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE); tmp = build_call_expr_loc (input_location, @@ -1435,6 +1450,10 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, if (status != NULL_TREE) { tree stat = build_fold_indirect_ref_loc (input_location, status); + tree nullify = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, pointer, + build_int_cst (TREE_TYPE (pointer), + 0)); TREE_USED (label_finish) = 1; tmp = build1_v (GOTO_EXPR, label_finish); @@ -1442,9 +1461,12 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, stat, build_zero_cst (TREE_TYPE (stat))); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (cond2, PRED_FORTRAN_REALLOC), - tmp, build_empty_stmt (input_location)); + tmp, nullify); gfc_add_expr_to_block (&non_null, tmp); } + else + gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer), + 0)); } return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, @@ -1516,11 +1538,17 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, finalizable = gfc_add_finalizer_call (&non_null, expr); if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) { - if (coarray) + int caf_mode = coarray + ? ((caf_dereg_type == GFC_CAF_COARRAY_DEALLOCATE_ONLY + ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0) + | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY + | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) + : 0; + if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) tmp = gfc_conv_descriptor_data_get (pointer); else tmp = build_fold_indirect_ref_loc (input_location, pointer); - tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); + tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0, caf_mode); gfc_add_expr_to_block (&non_null, tmp); } @@ -1573,7 +1601,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, gfc_add_expr_to_block (&non_null, tmp); /* It guarantees memory consistency within the same segment. */ - tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), + tmp = gfc_build_string_const (strlen ("memory")+1, "memory"); tmp = build5_loc (input_location, ASM_EXPR, void_type_node, gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index ae1f156..bfc2a24 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -719,7 +719,8 @@ void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree); /* Generate code to deallocate an array. */ tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool, - gfc_expr *, int); + gfc_expr *, int, tree a = NULL_TREE, + tree c = NULL_TREE); tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr*, gfc_typespec, bool c = false); diff --git a/gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08 b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08 new file mode 100644 index 0000000..8d2e793 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08 @@ -0,0 +1,51 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! +! Contributed by Andre Vehreschild +! Check that manually freeing components does not lead to a runtime crash, +! when the auto-deallocation is taking care. + +program coarray_alloc_comp_3 + implicit none + + type dt + integer, allocatable :: i + end type dt + + type linktype + type(dt), allocatable :: link + end type linktype + + type(linktype), allocatable :: obj[:] + + allocate(obj[*]) + allocate(obj%link) + + if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated." + if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated." + if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' already allocated." + + allocate(obj%link%i, source = 42) + + if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated." + if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated." + if (.not. allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' not allocated." + if (obj%link%i /= 42) error stop "Test failed. obj%link%i /= 42." + + deallocate(obj%link%i) + + if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' still allocated." + if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' no longer allocated." + if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated." + + ! Freeing this object, lead to crash with older gfortran... + deallocate(obj%link) + + if (allocated(obj%link)) error stop "Test failed. 'obj%link' still allocated." + if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated." + + ! ... when auto-deallocating the allocated components. + deallocate(obj) + + if (allocated(obj)) error stop "Test failed. 'obj' still allocated." +end program diff --git a/gcc/testsuite/gfortran.dg/coarray_alloc_comp_4.f08 b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_4.f08 new file mode 100644 index 0000000..517bb18 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_4.f08 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! +! Contributed by Andre Vehreschild +! Check that sub-components are caf_deregistered and not freed. + +program coarray_alloc_comp_3 + implicit none + + type dt + integer, allocatable :: i + end type dt + + type linktype + type(dt), allocatable :: link + end type linktype + + type(linktype) :: obj[*] + + allocate(obj%link) + + if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated." + if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' already allocated." + + allocate(obj%link%i, source = 42) + + if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated." + if (.not. allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' not allocated." + if (obj%link%i /= 42) error stop "Test failed. obj%link%i /= 42." + + deallocate(obj%link%i) + + if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' still allocated." + if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' no longer allocated." + + ! Freeing this object, lead to crash with older gfortran... + deallocate(obj%link) + + if (allocated(obj%link)) error stop "Test failed. 'obj%link' still allocated." +end program +! Ensure, that three calls to deregister are present. +! { dg-final { scan-tree-dump-times "_caf_deregister" 3 "original" } } +! And ensure that no calls to builtin_free are made. +! { dg-final { scan-tree-dump-not "_builtin_free" "original" } } diff --git a/gcc/testsuite/gfortran.dg/finalize_18.f90 b/gcc/testsuite/gfortran.dg/finalize_18.f90 index c8b4afc..3e64332 100644 --- a/gcc/testsuite/gfortran.dg/finalize_18.f90 +++ b/gcc/testsuite/gfortran.dg/finalize_18.f90 @@ -33,8 +33,8 @@ 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 "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.data != 0B\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.data != 0B\\)" 2 "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" } } diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_47.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_47.f90 new file mode 100644 index 0000000..1d52100 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_47.f90 @@ -0,0 +1,40 @@ +! { dg-do run } + +MODULE distribution_types + ABSTRACT INTERFACE + FUNCTION dist_map_blk_to_proc_func ( row, col, nrow_tot, ncol_tot, proc_grid ) RESULT( reslt ) + INTEGER, INTENT( IN ) :: row, col, nrow_tot, ncol_tot + INTEGER, DIMENSION( : ), INTENT( IN ) :: proc_grid + INTEGER, DIMENSION( : ), ALLOCATABLE :: reslt + END FUNCTION dist_map_blk_to_proc_func + END INTERFACE + TYPE, PUBLIC :: dist_type + INTEGER, DIMENSION( : ), ALLOCATABLE :: task_coords + PROCEDURE( dist_map_blk_to_proc_func ), NOPASS, POINTER :: map_blk_to_proc => NULL( ) + END TYPE dist_type +END MODULE distribution_types + +MODULE sparse_matrix_types + USE distribution_types, ONLY : dist_type + TYPE, PUBLIC :: sm_type + TYPE( dist_type ) :: dist + END TYPE sm_type +END MODULE sparse_matrix_types + +PROGRAM comp_proc_ptr_test + USE sparse_matrix_types, ONLY : sm_type + + call sm_multiply_a () +CONTAINS + SUBROUTINE sm_multiply_a ( ) + INTEGER :: n_push_tot, istat + TYPE( sm_type ), DIMENSION( : ), ALLOCATABLE :: matrices_a, matrices_b + n_push_tot =2 + ALLOCATE( matrices_a( n_push_tot + 1 ), matrices_b( n_push_tot + 1), STAT=istat ) + if (istat /= 0) call abort() + if (.not. allocated(matrices_a)) call abort() + if (.not. allocated(matrices_b)) call abort() + if (associated(matrices_a(1)%dist%map_blk_to_proc)) call abort() + END SUBROUTINE sm_multiply_a +END PROGRAM comp_proc_ptr_test +