From patchwork Fri Dec 30 14:07:41 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 133645 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 1A32FB6FA8 for ; Sat, 31 Dec 2011 01:08:42 +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=1325858924; h=Comment: DomainKey-Signature:Received: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=HuoTiXd h+7JmmkW2rYmVshoa/nY=; b=Elnd7H80aZI47U8f+r86+8FrgQTsSY0PBeSqZge xHyLS/AifvvOhvZLmwxCKnCEUBGdG2h0QHDKXIAaSTRsokQ9VUudlJbwZk9VPAwj gqiXE8qpOLYFIG+Qj1i+7MhzaItB3iICctGJn/w2StFkIjhgq13Cn3RiNUL304vg olJY= 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: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=nfGAanx/Zn9IKJiC2hDeu4u1nD0BfJopdOlTaviTRObGPbESPpD9MVL6IFKX1B tTTh0nLv879WJSEsoN61Vhjo8RQ8HZ+J0DwbRyYsKtGMXwQrJn9NGX76YjYTtM+0 28w19WgE0Hrbz04Oeo6R1wk/pZTokUSvmuzkSGEn2hb5A=; Received: (qmail 3368 invoked by alias); 30 Dec 2011 14:08:32 -0000 Received: (qmail 3354 invoked by uid 22791); 30 Dec 2011 14:08:24 -0000 X-SWARE-Spam-Status: No, hits=-1.6 required=5.0 tests=AWL, BAYES_00, TW_TM, TW_VP X-Spam-Check-By: sourceware.org Received: from outpost1.zedat.fu-berlin.de (HELO outpost1.zedat.fu-berlin.de) (130.133.4.66) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 30 Dec 2011 14:08:05 +0000 Received: from relay1.zedat.fu-berlin.de ([130.133.4.67]) by outpost1.zedat.fu-berlin.de (Exim 4.69) with esmtp (envelope-from ) id <1Rgd7r-0000dK-4a>; Fri, 30 Dec 2011 15:08:03 +0100 Received: from lenny32.physik.fu-berlin.de ([160.45.66.36] helo=[127.0.0.1]) by relay1.zedat.fu-berlin.de (Exim 4.69) with esmtp (envelope-from ) id <1Rgd7W-0005D9-PM>; Fri, 30 Dec 2011 15:08:03 +0100 Message-ID: <4EFDC5AD.6060405@net-b.de> Date: Fri, 30 Dec 2011 15:07:41 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:9.0) Gecko/20111220 Thunderbird/9.0 MIME-Version: 1.0 To: gcc-patches , "'fortran@gcc.gnu.org'" Subject: [Patch, Fortran] Deregister allocatable COARRAYS, fixes to (de)allocate 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, first, I want to wish all of you a happy New Year. Attached you find a patch which calls _gfortran_caf_deregister for allocatable coarrays - for -fcoarray=lib. In the caf libraray version, coarrays are allocated/deallocated in the library. The allocation/deallocation was working before for coarrays in static memory ("SAVE") and the ALLOCATE ("register") of allocatable coarrays. This patch adds the deallocation support ("deregister") both for explicit (DEALLOCATE) as well as for the implicit deallocation (when leaving the scope). While implementing this, I fixed and changes some other items: * The "token" which identifies the coarray in the library was not properly implemented in the library. * ERRMSG= of ALLOCATE/DEALLOCATE did not pad the string * ALLOCATE of coarrays with -fcoarray=lib: The status and errmsg of _gfortran_caf_register were overridden. Instead of counting the deallocate failures, we now directly abort, which makes life a bit easier which coarrays. (Without coarrays, the only failure can be that the variable is already deallocated as "free()" does not give an error and we currently do not check whether pointer targets may be deallocated. With coarrays, additional issues can occur.) Build and regtested on x86-64-linux. OK for the trunk? Tobias PS: Regarding the stat= value, I got confused and ask at http://j3-fortran.org/pipermail/j3/2011-December/004948.html 2011-12-30 Tobias Burnus * trans-openmp.c (gfc_omp_clause_dtor, gfc_trans_omp_array_reduction): Update call to gfc_trans_dealloc_allocated. * trans.c (gfc_allocate_using_malloc): Fix spacing. (gfc_allocate_allocatable): For gfc_allocate_using_lib, jump to label_finish when an error occurs. (gfc_deallocate_with_status): Call caf_deregister for -fcoarray=lib. * trans.h (gfc_allocate_allocatable, gfc_deallocate_with_status): Update prototype. (gfor_fndecl_caf_deregister): New tree symbol. * trans-expr.c (gfc_conv_procedure_call): Update gfc_deallocate_with_status and gfc_trans_dealloc_allocated calls. * trans-array.c (gfc_array_allocate, gfc_trans_dealloc_allocated, structure_alloc_comps, gfc_trans_deferred_array): Ditto. (gfc_array_deallocate): Handle coarrays with -fcoarray=lib. * trans-array.h (gfc_array_deallocate, gfc_array_allocate, gfc_trans_dealloc_allocated): Update prototypes. * trans-stmt.c (gfc_trans_sync): Fix indentation. (gfc_trans_allocate): Fix errmsg padding and label handling. (gfc_trans_deallocate): Ditto and handle -fcoarray=lib. * expr.c (gfc_is_coarray): Fix algorithm for BT_CLASS. * libgfortran.h (GFC_STAT_STOPPED_IMAGE): Use large value to avoid other stats accidentally matching this one. * trans-decl.c (gfor_fndecl_caf_deregister): New global var. (gfc_build_builtin_function_decls): Fix prototype decl of caf_register and add decl for caf_deregister. (gfc_trans_deferred_vars): Handle CAF vars with -fcoarrays=lib. * trans-intrinsic.c (conv_intrinsic_move_alloc): Update call to gfc_deallocate_with_status. 2011-12-30 Tobias Burnus * caf/single.c (_gfortran_caf_register, _gfortran_caf_deregister): Fix token handling. * caf/mpi.c (_gfortran_caf_register, _gfortran_caf_deregister): Ditto. * caf/libcaf.h (STAT_STOPPED_IMAGE): Sync with libgfortran.h. (_gfortran_caf_register, _gfortran_caf_deregister): Update prototype. 2011-12-30 Tobias Burnus * gfortran.dg/deallocate_stat_2.f90: New. * coarray/allocate_errgmsg.f90: New. * gfortran.dg/coarray_lib_alloc_1.f90: New. * gfortran.dg/coarray_lib_alloc_2.f90: New. * coarray/subobject_1.f90: Fix for num_images > 1. * gfortran.dg/deallocate_stat.f90: Update due to changed stat= handling. Index: gcc/fortran/trans-openmp.c =================================================================== --- gcc/fortran/trans-openmp.c (Revision 182728) +++ gcc/fortran/trans-openmp.c (Arbeitskopie) @@ -326,7 +326,7 @@ gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need to be deallocated if they were allocated. */ - return gfc_trans_dealloc_allocated (decl); + return gfc_trans_dealloc_allocated (decl, false); } @@ -708,7 +708,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol gfc_start_block (&block); gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false, true)); - gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl)); + gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false)); stmt = gfc_finish_block (&block); } else Index: gcc/fortran/trans.c =================================================================== --- gcc/fortran/trans.c (Revision 182728) +++ gcc/fortran/trans.c (Arbeitskopie) @@ -653,7 +653,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tr boolean_type_node, pointer, build_int_cst (prvoid_type_node, 0)); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - gfc_unlikely(error_cond), on_error, + gfc_unlikely (error_cond), on_error, build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); @@ -738,7 +738,8 @@ gfc_allocate_using_lib (stmtblock_t * block, tree and variable name in case a runtime error has to be printed. */ void gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token, - tree status, tree errmsg, tree errlen, gfc_expr* expr) + tree status, tree errmsg, tree errlen, tree label_finish, + gfc_expr* expr) { stmtblock_t alloc_block; tree tmp, null_mem, alloc, error; @@ -757,8 +758,23 @@ gfc_allocate_allocatable (stmtblock_t * block, tre if (gfc_option.coarray == GFC_FCOARRAY_LIB && gfc_expr_attr (expr).codimension) - gfc_allocate_using_lib (&alloc_block, mem, size, token, status, - errmsg, errlen); + { + tree cond; + + gfc_allocate_using_lib (&alloc_block, mem, size, token, status, + errmsg, errlen); + if (status != NULL_TREE) + { + TREE_USED (label_finish) = 1; + tmp = build1_v (GOTO_EXPR, label_finish); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + status, build_zero_cst (TREE_TYPE (status))); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond), tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&alloc_block, tmp); + } + } else gfc_allocate_using_malloc (&alloc_block, mem, size, status); @@ -852,14 +868,28 @@ gfc_call_free (tree var) each procedure). If a runtime-message is possible, `expr' must point to the original - expression being deallocated for its locus and variable name. */ + expression being deallocated for its locus and variable name. + + For coarrays, "pointer" must be the array descriptor and not its + "data" component. */ tree -gfc_deallocate_with_status (tree pointer, tree status, bool can_fail, - gfc_expr* expr) +gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, + tree errlen, tree label_finish, + bool can_fail, gfc_expr* expr, bool coarray) { stmtblock_t null, non_null; tree cond, tmp, error; + tree status_type = NULL_TREE; + tree caf_decl = NULL_TREE; + if (coarray) + { + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))); + caf_decl = pointer; + pointer = gfc_conv_descriptor_data_get (caf_decl); + STRIP_NOPS (pointer); + } + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, build_int_cst (TREE_TYPE (pointer), 0)); @@ -884,9 +914,9 @@ tree if (status != NULL_TREE && !integer_zerop (status)) { - tree status_type = TREE_TYPE (TREE_TYPE (status)); tree cond2; + status_type = TREE_TYPE (TREE_TYPE (status)); cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, status, build_int_cst (TREE_TYPE (status), 0)); tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, @@ -901,26 +931,90 @@ tree /* When POINTER is not NULL, we free it. */ gfc_start_block (&non_null); - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_FREE), 1, - fold_convert (pvoid_type_node, pointer)); - gfc_add_expr_to_block (&non_null, tmp); + if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB) + { + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_FREE), 1, + fold_convert (pvoid_type_node, pointer)); + gfc_add_expr_to_block (&non_null, tmp); - if (status != NULL_TREE && !integer_zerop (status)) + if (status != NULL_TREE && !integer_zerop (status)) + { + /* We set STATUS to zero if it is present. */ + tree status_type = TREE_TYPE (TREE_TYPE (status)); + tree cond2; + + cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + status, + build_int_cst (TREE_TYPE (status), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), + build_int_cst (status_type, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond2), tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&non_null, tmp); + } + } + else { - /* We set STATUS to zero if it is present. */ - tree status_type = TREE_TYPE (TREE_TYPE (status)); - tree cond2; + tree caf_type, token, cond2; + tree pstat = null_pointer_node; - cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - status, build_int_cst (TREE_TYPE (status), 0)); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, - fold_build1_loc (input_location, INDIRECT_REF, - status_type, status), - build_int_cst (status_type, 0)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, - tmp, build_empty_stmt (input_location)); + if (errmsg == NULL_TREE) + { + gcc_assert (errlen == NULL_TREE); + errmsg = null_pointer_node; + errlen = build_zero_cst (integer_type_node); + } + else + { + gcc_assert (errlen != NULL_TREE); + if (!POINTER_TYPE_P (TREE_TYPE (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); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_deregister, 4, + token, pstat, errmsg, errlen); gfc_add_expr_to_block (&non_null, tmp); + + if (status != NULL_TREE) + { + tree stat = build_fold_indirect_ref_loc (input_location, status); + + TREE_USED (label_finish) = 1; + tmp = build1_v (GOTO_EXPR, label_finish); + cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + stat, build_zero_cst (TREE_TYPE (stat))); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond2), tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&non_null, tmp); + } } return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, Index: gcc/fortran/trans.h =================================================================== --- gcc/fortran/trans.h (Revision 182728) +++ gcc/fortran/trans.h (Arbeitskopie) @@ -583,14 +583,15 @@ tree gfc_call_malloc (stmtblock_t *, tree, tree); tree gfc_build_memcpy_call (tree, tree, tree); /* Allocate memory for allocatable variables, with optional status variable. */ -void gfc_allocate_allocatable (stmtblock_t*, tree, tree, tree, +void gfc_allocate_allocatable (stmtblock_t*, tree, tree, tree, tree, tree, tree, tree, gfc_expr*); /* Allocate memory, with optional status variable. */ void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree); /* Generate code to deallocate an array. */ -tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*); +tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool, + gfc_expr *, bool); tree gfc_deallocate_scalar_with_status (tree, tree, bool, gfc_expr*, gfc_typespec); /* Generate code to call realloc(). */ @@ -672,6 +673,7 @@ extern GTY(()) tree gfor_fndecl_associated; extern GTY(()) tree gfor_fndecl_caf_init; extern GTY(()) tree gfor_fndecl_caf_finalize; extern GTY(()) tree gfor_fndecl_caf_register; +extern GTY(()) tree gfor_fndecl_caf_deregister; extern GTY(()) tree gfor_fndecl_caf_critical; extern GTY(()) tree gfor_fndecl_caf_end_critical; extern GTY(()) tree gfor_fndecl_caf_sync_all; Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (Revision 182728) +++ gcc/fortran/trans-expr.c (Arbeitskopie) @@ -3317,7 +3317,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * gfc_init_block (&block); tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE, - true, NULL); + NULL_TREE, NULL_TREE, + NULL_TREE, true, NULL, + false); gfc_add_expr_to_block (&block, tmp); tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, parmse.expr, @@ -3457,7 +3459,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * { tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); - tmp = gfc_trans_dealloc_allocated (tmp); + tmp = gfc_trans_dealloc_allocated (tmp, false); if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) @@ -4124,7 +4126,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * /* Finally free the temporary's data field. */ tmp = gfc_conv_descriptor_data_get (tmp2); - tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL); + tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, + NULL, false); gfc_add_expr_to_block (&se->pre, tmp); } } Index: gcc/fortran/trans-array.c =================================================================== --- gcc/fortran/trans-array.c (Revision 182728) +++ gcc/fortran/trans-array.c (Arbeitskopie) @@ -4927,7 +4927,7 @@ gfc_array_init_size (tree descriptor, int rank, in bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, - tree errlen, gfc_expr *expr3) + tree errlen, tree label_finish, gfc_expr *expr3) { tree tmp; tree pointer; @@ -5053,7 +5053,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, /* The allocatable variant takes the old pointer as first argument. */ if (allocatable) gfc_allocate_allocatable (&elseblock, pointer, size, token, - status, errmsg, errlen, expr); + status, errmsg, errlen, label_finish, expr); else gfc_allocate_using_malloc (&elseblock, pointer, size, status); @@ -5104,24 +5104,40 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, /*GCC ARRAYS*/ tree -gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr) +gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen, + tree label_finish, gfc_expr* expr) { tree var; tree tmp; stmtblock_t block; + bool coarray = gfc_is_coarray (expr); 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 (var, pstat, false, expr); + tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg, + errlen, label_finish, false, expr, coarray); gfc_add_expr_to_block (&block, tmp); - /* Zero the data pointer. */ + /* 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 && gfc_option.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); @@ -7032,7 +7048,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * /* Generate code to deallocate an array, if it is allocated. */ tree -gfc_trans_dealloc_allocated (tree descriptor) +gfc_trans_dealloc_allocated (tree descriptor, bool coarray) { tree tmp; tree var; @@ -7046,7 +7062,9 @@ tree /* 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 (var, NULL_TREE, true, NULL); + tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE, + NULL_TREE, NULL_TREE, NULL_TREE, true, + NULL, coarray); gfc_add_expr_to_block (&block, tmp); /* Zero the data pointer. */ @@ -7335,7 +7353,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree { comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); - tmp = gfc_trans_dealloc_allocated (comp); + tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension); gfc_add_expr_to_block (&fnblock, tmp); } else if (c->attr.allocatable) @@ -7365,7 +7383,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree TREE_TYPE (tmp), comp, tmp, NULL_TREE); if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp))) - tmp = gfc_trans_dealloc_allocated (comp); + tmp = gfc_trans_dealloc_allocated (comp, + CLASS_DATA (c)->attr.codimension); else { tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL, @@ -8071,7 +8090,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wr if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension) && !sym->attr.save && !sym->attr.result) { - tmp = gfc_trans_dealloc_allocated (sym->backend_decl); + tmp = gfc_trans_dealloc_allocated (sym->backend_decl, + sym->attr.codimension); gfc_add_expr_to_block (&cleanup, tmp); } Index: gcc/fortran/trans-array.h =================================================================== --- gcc/fortran/trans-array.h (Revision 182728) +++ gcc/fortran/trans-array.h (Arbeitskopie) @@ -20,11 +20,12 @@ along with GCC; see the file COPYING3. If not see . */ /* Generate code to free an array. */ -tree gfc_array_deallocate (tree, tree, gfc_expr*); +tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*); /* 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, gfc_expr *); +bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, + gfc_expr *); /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, @@ -42,7 +43,7 @@ void gfc_trans_dummy_array_bias (gfc_symbol *, tre /* 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); +tree gfc_trans_dealloc_allocated (tree, bool); tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank); Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (Revision 182728) +++ gcc/fortran/trans-stmt.c (Arbeitskopie) @@ -754,8 +754,8 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) if (gfc_option.coarray == GFC_FCOARRAY_LIB) { tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE); - tmp = build_call_expr_loc (input_location, tmp, 0); - gfc_add_expr_to_block (&se.pre, tmp); + tmp = build_call_expr_loc (input_location, tmp, 0); + gfc_add_expr_to_block (&se.pre, tmp); } if (gfc_option.coarray != GFC_FCOARRAY_LIB || type == EXEC_SYNC_MEMORY) @@ -4737,10 +4737,10 @@ gfc_trans_allocate (gfc_code * code) if (code->expr2) { gfc_init_se (&se, NULL); + se.want_pointer = 1; gfc_conv_expr_lhs (&se, code->expr2); - - errlen = gfc_get_expr_charlen (code->expr2); - errmsg = gfc_build_addr_expr (pchar_type_node, se.expr); + errmsg = se.expr; + errlen = se.string_length; } else { @@ -4751,8 +4751,7 @@ gfc_trans_allocate (gfc_code * code) /* GOTO destinations. */ label_errmsg = gfc_build_label_decl (NULL_TREE); label_finish = gfc_build_label_decl (NULL_TREE); - TREE_USED (label_errmsg) = 1; - TREE_USED (label_finish) = 1; + TREE_USED (label_finish) = 0; } expr3 = NULL_TREE; @@ -4771,7 +4770,8 @@ gfc_trans_allocate (gfc_code * code) se.descriptor_only = 1; gfc_conv_expr (&se, expr); - if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, code->expr3)) + if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish, + code->expr3)) { /* A scalar or derived type. */ @@ -4891,7 +4891,7 @@ gfc_trans_allocate (gfc_code * code) /* Allocate - for non-pointers with re-alloc checking. */ if (gfc_expr_attr (expr).allocatable) gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE, - stat, errmsg, errlen, expr); + stat, errmsg, errlen, label_finish, expr); else gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat); @@ -4918,18 +4918,12 @@ gfc_trans_allocate (gfc_code * code) /* Error checking -- Note: ERRMSG only makes sense with STAT. */ if (code->expr1) { - /* The coarray library already sets the errmsg. */ - if (gfc_option.coarray == GFC_FCOARRAY_LIB - && gfc_expr_attr (expr).codimension) - tmp = build1_v (GOTO_EXPR, label_finish); - else - tmp = build1_v (GOTO_EXPR, label_errmsg); - + tmp = build1_v (GOTO_EXPR, label_errmsg); parm = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, build_int_cst (TREE_TYPE (stat), 0)); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - gfc_unlikely(parm), tmp, + gfc_unlikely (parm), tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); } @@ -5101,26 +5095,25 @@ gfc_trans_allocate (gfc_code * code) gfc_free_expr (expr); } - /* STAT (ERRMSG only makes sense with STAT). */ + /* STAT. */ if (code->expr1) { tmp = build1_v (LABEL_EXPR, label_errmsg); gfc_add_expr_to_block (&block, tmp); } - /* ERRMSG block. */ - if (code->expr2) + /* ERRMSG - only useful if STAT is present. */ + if (code->expr1 && code->expr2) { /* A better error message may be possible, but not required. */ const char *msg = "Attempt to allocate an allocated object"; - tree slen, dlen; + tree slen, dlen, errmsg_str; + stmtblock_t errmsg_block; - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, code->expr2); + gfc_init_block (&errmsg_block); - errmsg = gfc_create_var (pchar_type_node, "ERRMSG"); - - gfc_add_modify (&block, errmsg, + errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG"); + gfc_add_modify (&errmsg_block, errmsg_str, gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const (msg))); @@ -5129,9 +5122,9 @@ gfc_trans_allocate (gfc_code * code) slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen, slen); - dlen = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), 3, - gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen); + gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind, + slen, errmsg_str, gfc_default_character_kind); + dlen = gfc_finish_block (&errmsg_block); tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, build_int_cst (TREE_TYPE (stat), 0)); @@ -5141,16 +5134,15 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); } - /* STAT (ERRMSG only makes sense with STAT). */ + /* STAT block. */ if (code->expr1) { - tmp = build1_v (LABEL_EXPR, label_finish); - gfc_add_expr_to_block (&block, tmp); - } + if (TREE_USED (label_finish)) + { + tmp = build1_v (LABEL_EXPR, label_finish); + gfc_add_expr_to_block (&block, tmp); + } - /* STAT block. */ - if (code->expr1) - { gfc_init_se (&se, NULL); gfc_conv_expr_lhs (&se, code->expr1); tmp = convert (TREE_TYPE (se.expr), stat); @@ -5171,29 +5163,39 @@ gfc_trans_deallocate (gfc_code *code) { gfc_se se; gfc_alloc *al; - tree apstat, astat, pstat, stat, tmp; + tree apstat, pstat, stat, errmsg, errlen, tmp; + tree label_finish, label_errmsg; stmtblock_t block; - pstat = apstat = stat = astat = tmp = NULL_TREE; + pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE; + label_finish = label_errmsg = NULL_TREE; gfc_start_block (&block); /* Count the number of failed deallocations. If deallocate() was called with STAT= , then set STAT to the count. If deallocate was called with ERRMSG, then set ERRMG to a string. */ - if (code->expr1 || code->expr2) + if (code->expr1) { tree gfc_int4_type_node = gfc_get_int_type (4); stat = gfc_create_var (gfc_int4_type_node, "stat"); pstat = gfc_build_addr_expr (NULL_TREE, stat); - /* Running total of possible deallocation failures. */ - astat = gfc_create_var (gfc_int4_type_node, "astat"); - apstat = gfc_build_addr_expr (NULL_TREE, astat); + /* GOTO destinations. */ + label_errmsg = gfc_build_label_decl (NULL_TREE); + label_finish = gfc_build_label_decl (NULL_TREE); + TREE_USED (label_finish) = 0; + } - /* Initialize astat to 0. */ - gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0)); + /* Set ERRMSG - only needed if STAT is available. */ + if (code->expr1 && code->expr2) + { + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr_lhs (&se, code->expr2); + errmsg = se.expr; + errlen = se.string_length; } for (al = code->ext.alloc.list; al != NULL; al = al->next) @@ -5211,7 +5213,7 @@ gfc_trans_deallocate (gfc_code *code) se.descriptor_only = 1; gfc_conv_expr (&se, expr); - if (expr->rank || gfc_expr_attr (expr).codimension) + if (expr->rank || gfc_is_coarray (expr)) { if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) { @@ -5231,7 +5233,8 @@ gfc_trans_deallocate (gfc_code *code) gfc_add_expr_to_block (&se.pre, tmp); } } - tmp = gfc_array_deallocate (se.expr, pstat, expr); + tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen, + label_finish, expr); gfc_add_expr_to_block (&se.pre, tmp); } else @@ -5260,13 +5263,17 @@ gfc_trans_deallocate (gfc_code *code) } } - /* Keep track of the number of failed deallocations by adding stat - of the last deallocation to the running total. */ - if (code->expr1 || code->expr2) + if (code->expr1) { - apstat = fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (stat), astat, stat); - gfc_add_modify (&se.pre, astat, apstat); + tree cond; + + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, + build_int_cst (TREE_TYPE (stat), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond), + build1_v (GOTO_EXPR, label_errmsg), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se.pre, tmp); } tmp = gfc_finish_block (&se.pre); @@ -5274,48 +5281,57 @@ gfc_trans_deallocate (gfc_code *code) gfc_free_expr (expr); } - /* Set STAT. */ if (code->expr1) { - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, code->expr1); - tmp = convert (TREE_TYPE (se.expr), astat); - gfc_add_modify (&block, se.expr, tmp); + tmp = build1_v (LABEL_EXPR, label_errmsg); + gfc_add_expr_to_block (&block, tmp); } - /* Set ERRMSG. */ - if (code->expr2) + /* Set ERRMSG - only needed if STAT is available. */ + if (code->expr1 && code->expr2) { /* A better error message may be possible, but not required. */ const char *msg = "Attempt to deallocate an unallocated object"; - tree errmsg, slen, dlen; + stmtblock_t errmsg_block; + tree errmsg_str, slen, dlen, cond; - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, code->expr2); + gfc_init_block (&errmsg_block); - errmsg = gfc_create_var (pchar_type_node, "ERRMSG"); - - gfc_add_modify (&block, errmsg, + errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG"); + gfc_add_modify (&errmsg_block, errmsg_str, gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const (msg))); - slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg))); dlen = gfc_get_expr_charlen (code->expr2); - slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen, - slen); - dlen = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), 3, - gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen); + gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind, + slen, errmsg_str, gfc_default_character_kind); + tmp = gfc_finish_block (&errmsg_block); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, astat, - build_int_cst (TREE_TYPE (astat), 0)); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, + build_int_cst (TREE_TYPE (stat), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond), tmp, + build_empty_stmt (input_location)); - tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + if (code->expr1 && TREE_USED (label_finish)) + { + tmp = build1_v (LABEL_EXPR, label_finish); gfc_add_expr_to_block (&block, tmp); } + /* Set STAT. */ + if (code->expr1) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, code->expr1); + tmp = convert (TREE_TYPE (se.expr), stat); + gfc_add_modify (&block, se.expr, tmp); + } + return gfc_finish_block (&block); } Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (Revision 182728) +++ gcc/fortran/expr.c (Arbeitskopie) @@ -4264,14 +4264,18 @@ gfc_is_coarray (gfc_expr *e) { case REF_COMPONENT: comp = ref->u.c.component; - if (comp->attr.pointer || comp->attr.allocatable) + if (comp->ts.type == BT_CLASS && comp->attr.class_ok + && (CLASS_DATA (comp)->attr.class_pointer + || CLASS_DATA (comp)->attr.allocatable)) { coindexed = false; - if (comp->ts.type == BT_CLASS && comp->attr.class_ok) - coarray = CLASS_DATA (comp)->attr.codimension; - else - coarray = comp->attr.codimension; + coarray = CLASS_DATA (comp)->attr.codimension; } + else if (comp->attr.pointer || comp->attr.allocatable) + { + coindexed = false; + coarray = comp->attr.codimension; + } break; case REF_ARRAY: Index: gcc/fortran/libgfortran.h =================================================================== --- gcc/fortran/libgfortran.h (Revision 182728) +++ gcc/fortran/libgfortran.h (Arbeitskopie) @@ -105,7 +105,7 @@ typedef enum GFC_STAT_UNLOCKED = 0, GFC_STAT_LOCKED, GFC_STAT_LOCKED_OTHER_IMAGE, - GFC_STAT_STOPPED_IMAGE /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */ + GFC_STAT_STOPPED_IMAGE = 6000 /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */ } libgfortran_stat_codes; Index: gcc/fortran/trans-decl.c =================================================================== --- gcc/fortran/trans-decl.c (Revision 182728) +++ gcc/fortran/trans-decl.c (Arbeitskopie) @@ -121,6 +121,7 @@ tree gfor_fndecl_associated; tree gfor_fndecl_caf_init; tree gfor_fndecl_caf_finalize; tree gfor_fndecl_caf_register; +tree gfor_fndecl_caf_deregister; tree gfor_fndecl_caf_critical; tree gfor_fndecl_caf_end_critical; tree gfor_fndecl_caf_sync_all; @@ -3163,8 +3164,12 @@ gfc_build_builtin_function_decls (void) gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node, 6, size_type_node, integer_type_node, ppvoid_type_node, pint_type, - build_pointer_type (pchar_type_node), integer_type_node); + pchar_type_node, integer_type_node); + gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node, 4, + ppvoid_type_node, pint_type, pchar_type_node, integer_type_node); + gfor_fndecl_caf_critical = gfc_build_library_function_decl ( get_identifier (PREFIX("caf_critical")), void_type_node, 0); @@ -3688,6 +3693,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gf { if (!sym->attr.save) { + tree descriptor = NULL_TREE; + /* Nullify and automatic deallocation of allocatable scalars. */ e = gfc_lval_expr_from_sym (sym); @@ -3712,6 +3719,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gf else { gfc_conv_expr (&se, e); + descriptor = se.expr; se.expr = gfc_conv_descriptor_data_addr (se.expr); se.expr = build_fold_indirect_ref_loc (input_location, se.expr); } @@ -3761,9 +3769,18 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gf /* Deallocate when leaving the scope. Nullifying is not needed. */ if (!sym->attr.result && !sym->attr.dummy) - tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true, - NULL, sym->ts); - + { + if (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.codimension) + tmp = gfc_deallocate_with_status (descriptor, NULL_TREE, + NULL_TREE, NULL_TREE, + NULL_TREE, true, NULL, + true); + else + tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, + true, NULL, + sym->ts); + } if (sym->ts.type == BT_CLASS) { /* Initialize _vptr to declared type. */ Index: gcc/fortran/trans-intrinsic.c =================================================================== --- gcc/fortran/trans-intrinsic.c (Revision 182728) +++ gcc/fortran/trans-intrinsic.c (Arbeitskopie) @@ -7351,7 +7351,8 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_conv_expr_descriptor (&from_se, from_expr, from_ss); tmp = gfc_conv_descriptor_data_get (to_se.expr); - tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, to_expr); + tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE, + NULL_TREE, true, to_expr, false); gfc_add_expr_to_block (&block, tmp); /* Move the pointer and update the array descriptor data. */ Index: libgfortran/caf/single.c =================================================================== --- libgfortran/caf/single.c (Revision 182728) +++ libgfortran/caf/single.c (Arbeitskopie) @@ -81,14 +81,14 @@ _gfortran_caf_finalize (void) void * -_gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token, +_gfortran_caf_register (ptrdiff_t size, caf_register_t type, void ***token, int *stat, char *errmsg, int errmsg_len) { void *local; local = malloc (size); - token = malloc (sizeof (void*) * 1); - token[0] = local; + *token = malloc (sizeof (void*) * 1); + (*token)[0] = local; if (unlikely (local == NULL || token == NULL)) { @@ -117,7 +117,7 @@ void * { caf_static_t *tmp = malloc (sizeof (caf_static_t)); tmp->prev = caf_static_list; - tmp->token = token; + tmp->token = *token; caf_static_list = tmp; } return local; @@ -125,12 +125,12 @@ void * void -_gfortran_caf_deregister (void **token, int *stat, +_gfortran_caf_deregister (void ***token, int *stat, char *errmsg __attribute__ ((unused)), int errmsg_len __attribute__ ((unused))) { + free ((*token)[0]); free (*token); - free (token); if (stat) *stat = 0; Index: libgfortran/caf/mpi.c =================================================================== --- libgfortran/caf/mpi.c (Revision 182728) +++ libgfortran/caf/mpi.c (Arbeitskopie) @@ -119,7 +119,7 @@ _gfortran_caf_finalize (void) void * -_gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token, +_gfortran_caf_register (ptrdiff_t size, caf_register_t type, void ***token, int *stat, char *errmsg, int errmsg_len) { void *local; @@ -134,18 +134,19 @@ void * /* Token contains only a list of pointers. */ local = malloc (size); - token = malloc (sizeof (void*) * caf_num_images); + *token = malloc (sizeof (void*) * caf_num_images); - if (unlikely (local == NULL || token == NULL)) + if (unlikely (local == NULL || *token == NULL)) goto error; /* token[img-1] is the address of the token in image "img". */ - err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, token, + err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, *token, sizeof (void*), MPI_BYTE, MPI_COMM_WORLD); + if (unlikely (err)) { free (local); - free (token); + free (*token); goto error; } @@ -153,7 +154,7 @@ void * { caf_static_t *tmp = malloc (sizeof (caf_static_t)); tmp->prev = caf_static_list; - tmp->token = token; + tmp->token = *token; caf_static_list = tmp; } @@ -192,7 +193,7 @@ error: void -_gfortran_caf_deregister (void **token, int *stat, char *errmsg, int errmsg_len) +_gfortran_caf_deregister (void ***token, int *stat, char *errmsg, int errmsg_len) { if (unlikely (caf_is_finalized)) { @@ -220,8 +221,8 @@ void if (stat) *stat = 0; - free (token[caf_this_image-1]); - free (token); + free ((*token)[caf_this_image-1]); + free (*token); } Index: libgfortran/caf/libcaf.h =================================================================== --- libgfortran/caf/libcaf.h (Revision 182728) +++ libgfortran/caf/libcaf.h (Arbeitskopie) @@ -44,7 +44,7 @@ see the files COPYING3 and COPYING.RUNTIME respect #define STAT_UNLOCKED 0 #define STAT_LOCKED 1 #define STAT_LOCKED_OTHER_IMAGE 2 -#define STAT_STOPPED_IMAGE 3 +#define STAT_STOPPED_IMAGE 6000 /* Describes what type of array we are registerring. Keep in sync with gcc/fortran/trans.h. */ @@ -67,9 +67,9 @@ caf_static_t; void _gfortran_caf_init (int *, char ***, int *, int *); void _gfortran_caf_finalize (void); -void * _gfortran_caf_register (ptrdiff_t, caf_register_t, void **, int *, +void * _gfortran_caf_register (ptrdiff_t, caf_register_t, void ***, int *, char *, int); -void _gfortran_caf_deregister (void **, int *, char *, int); +void _gfortran_caf_deregister (void ***, int *, char *, int); void _gfortran_caf_sync_all (int *, char *, int); Index: gcc/testsuite/gfortran.dg/deallocate_stat_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/deallocate_stat_2.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/deallocate_stat_2.f90 (Arbeitskopie) @@ -0,0 +1,30 @@ +! { dg-do run } +! +! Check that the error is properly diagnosed and the strings are correctly padded. +! +integer, allocatable :: A, B(:) +integer :: stat +character(len=5) :: sstr +character(len=200) :: str + +str = repeat('X', len(str)) +deallocate(a, stat=stat, errmsg=str) +!print *, stat, trim(str) +if (stat == 0 .or. str /= "Attempt to deallocate an unallocated object") call abort() + +str = repeat('Y', len(str)) +deallocate(b, stat=stat, errmsg=str) +!print *, stat, trim(str) +if (stat == 0 .or. str /= "Attempt to deallocate an unallocated object") call abort() + +sstr = repeat('Q', len(sstr)) +deallocate(a, stat=stat, errmsg=sstr) +!print *, stat, trim(sstr) +if (stat == 0 .or. sstr /= "Attem") call abort() + +sstr = repeat('P', len(sstr)) +deallocate(b, stat=stat, errmsg=sstr) +!print *, stat, trim(sstr) +if (stat == 0 .or. sstr /= "Attem") call abort() + +end Index: gcc/testsuite/gfortran.dg/deallocate_stat.f90 =================================================================== --- gcc/testsuite/gfortran.dg/deallocate_stat.f90 (Revision 182728) +++ gcc/testsuite/gfortran.dg/deallocate_stat.f90 (Arbeitskopie) @@ -69,9 +69,9 @@ program deallocate_stat i = 13 deallocate(a1, stat=i) ; if (i /= 0) call abort deallocate(a2, a1, stat=i) ; if (i /= 1) call abort - deallocate(a1, a3, a2, stat=i) ; if (i /= 2) call abort + deallocate(a1, a3, a2, stat=i) ; if (i /= 1) call abort deallocate(b4, stat=i) ; if (i /= 0) call abort deallocate(b4, b5, stat=i) ; if (i /= 1) call abort - deallocate(b4, b5, b6, stat=i) ; if (i /= 2) call abort + deallocate(b4, b5, b6, stat=i) ; if (i /= 1) call abort end program deallocate_stat Index: gcc/testsuite/gfortran.dg/coarray/allocate_errgmsg.f90 =================================================================== --- gcc/testsuite/gfortran.dg/coarray/allocate_errgmsg.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/coarray/allocate_errgmsg.f90 (Arbeitskopie) @@ -0,0 +1,36 @@ +! { dg-do run } +! +! Check handling of errmsg. +! +implicit none +integer, allocatable :: a[:], b(:)[:], c, d(:) +integer :: stat +character(len=300) :: str + +allocate(a[*], b(1)[*], c, d(2), stat=stat) + +str = repeat('X', len(str)) +allocate(a[*], stat=stat, errmsg=str) +!print *, stat, trim(str) +if (stat == 0 .or. str /= "Attempt to allocate an allocated object") & + call abort () + +str = repeat('Y', len(str)) +allocate(b(2)[*], stat=stat, errmsg=str) +!print *, stat, trim(str) +if (stat == 0 .or. str /= "Attempt to allocate an allocated object") & + call abort () + +str = repeat('Q', len(str)) +allocate(c, stat=stat, errmsg=str) +!print *, stat, trim(str) +if (stat == 0 .or. str /= "Attempt to allocate an allocated object") & + call abort () + +str = repeat('P', len(str)) +allocate(d(3), stat=stat, errmsg=str) +!print *, stat, trim(str) +if (stat == 0 .or. str /= "Attempt to allocate an allocated object") & + call abort () + +end Index: gcc/testsuite/gfortran.dg/coarray/subobject_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/coarray/subobject_1.f90 (Revision 182728) +++ gcc/testsuite/gfortran.dg/coarray/subobject_1.f90 (Arbeitskopie) @@ -24,20 +24,20 @@ b%a%i = 7 if (b%a%i /= 7) call abort if (any (lcobound(b%a) /= (/ lb /))) call abort - if (ucobound(b%a, dim=1) /= this_image() + lb - 1) call abort + if (ucobound(b%a, dim=1) /= num_images() + lb - 1) call abort if (any (lcobound(b%a%i) /= (/ lb /))) call abort - if (ucobound(b%a%i, dim=1) /= this_image() + lb - 1) call abort + if (ucobound(b%a%i, dim=1) /= num_images() + lb - 1) call abort allocate(c%a(la)[lc:*]) c%a%i = init if (any(c%a%i /= init)) call abort if (any (lcobound(c%a) /= (/ lc /))) call abort - if (ucobound(c%a, dim=1) /= this_image() + lc - 1) call abort + if (ucobound(c%a, dim=1) /= num_images() + lc - 1) call abort if (any (lcobound(c%a%i) /= (/ lc /))) call abort - if (ucobound(c%a%i, dim=1) /= this_image() + lc - 1) call abort + if (ucobound(c%a%i, dim=1) /= num_images() + lc - 1) call abort if (c%a(2)%i /= init(2)) call abort if (any (lcobound(c%a(2)) /= (/ lc /))) call abort - if (ucobound(c%a(2), dim=1) /= this_image() + lc - 1) call abort + if (ucobound(c%a(2), dim=1) /= num_images() + lc - 1) call abort if (any (lcobound(c%a(2)%i) /= (/ lc /))) call abort - if (ucobound(c%a(2)%i, dim=1) /= this_image() + lc - 1) call abort + if (ucobound(c%a(2)%i, dim=1) /= num_images() + lc - 1) call abort deallocate(b%a, c%a) end Index: gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 (Arbeitskopie) @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! +! Allocate/deallocate with libcaf. +! + + integer(4), allocatable :: xx[:], yy(:)[:] + integer :: stat + character(len=200) :: errmsg + allocate(xx[*], stat=stat, errmsg=errmsg) + allocate(yy(2)[*], stat=stat, errmsg=errmsg) + deallocate(xx,yy,stat=stat, errmsg=errmsg) + end + +! { dg-final { scan-tree-dump-times "_gfortran_caf_register .4, 1, &xx.token, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register .8, 1, &yy.token, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, 0B, 0B, 0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, 0B, 0B, 0.;" 1 "original" } } +! { dg-final { cleanup-tree-dump "original" } } Index: gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 (Arbeitskopie) @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! +! Allocate/deallocate with libcaf. +! + + type t + end type t + class(t), allocatable :: xx[:], yy(:)[:] + integer :: stat + character(len=200) :: errmsg + allocate(xx[*], stat=stat, errmsg=errmsg) + allocate(yy(2)[*], stat=stat, errmsg=errmsg) + deallocate(xx,yy,stat=stat, errmsg=errmsg) + end + +! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0B, 0B, 0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0B, 0B, 0.;" 1 "original" } } +! { dg-final { cleanup-tree-dump "original" } }