This patch fixes: * Added padding for ERRMSG= to ALLOCATE/DEALLOCATE * Run caf_deregister with -fcoarray=lib for allocatable coarrays (scalar, array; nonpolymorphic, polymorphic) * Fixed "token" handling with the libcaf library * Ensure that caf_registering's ERRMSG is not overridden. * Deallocate fixes: Nullify only if successfully deallocated * Directly abort (makes live easier than counting with coarrays) Cf. also http://j3-fortran.org/pipermail/j3/2011-December/004949.html TODO: * goto label_finish is unconditional (-fcoarray=lib). WHY? * Add more test cases, including "token" passing (allocate/deallocate in procedures) with -fcoarray=lib - and with class Index: gcc/fortran/trans-openmp.c =================================================================== --- gcc/fortran/trans-openmp.c (revision 182620) +++ gcc/fortran/trans-openmp.c (working copy) @@ -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 182620) +++ gcc/fortran/trans.c (working copy) @@ -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,20 @@ 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); + 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_int_cst (TREE_TYPE (status), 0)); + 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 +865,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 +911,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 +928,88 @@ 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, + 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_int_cst (integer_type_node, 0); + } + 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_USED (label_finish) = 1; + tmp = build1_v (GOTO_EXPR, label_finish); + cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + status, + build_int_cst (TREE_TYPE (status), 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); + } } return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, Index: gcc/fortran/trans.h =================================================================== --- gcc/fortran/trans.h (revision 182620) +++ gcc/fortran/trans.h (working copy) @@ -391,6 +391,7 @@ void gfc_conv_expr_type (gfc_se * se, gfc_expr *, /* trans-expr.c */ void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr); tree gfc_string_to_single_character (tree len, tree str, int kind); +tree gfc_get_tree_for_caf_expr (gfc_expr *expr); /* Find the decl containing the auxiliary variables for assigned variables. */ void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr); @@ -583,14 +584,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 +674,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 182620) +++ gcc/fortran/trans-expr.c (working copy) @@ -537,8 +537,8 @@ gfc_get_expr_charlen (gfc_expr *e) /* Return for an expression the backend decl of the coarray. */ -static tree -get_tree_for_caf_expr (gfc_expr *expr) +tree +gfc_get_tree_for_caf_expr (gfc_expr *expr) { tree caf_decl = NULL_TREE; gfc_ref *ref; @@ -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) @@ -3694,7 +3696,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * tree caf_decl, caf_type; tree offset, tmp2; - caf_decl = get_tree_for_caf_expr (e); + caf_decl = gfc_get_tree_for_caf_expr (e); caf_type = TREE_TYPE (caf_decl); if (GFC_DESCRIPTOR_TYPE_P (caf_type) @@ -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 182620) +++ gcc/fortran/trans-array.c (working copy) @@ -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 182620) +++ gcc/fortran/trans-array.h (working copy) @@ -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 182620) +++ gcc/fortran/trans-stmt.c (working copy) @@ -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,16 @@ 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; + + tmp = build1_v (GOTO_EXPR, label_errmsg); + 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, + gfc_likely (cond), tmp, + build1_v (GOTO_EXPR, label_errmsg)); } tmp = gfc_finish_block (&se.pre); @@ -5274,48 +5280,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 182620) +++ gcc/fortran/expr.c (working copy) @@ -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 182620) +++ gcc/fortran/libgfortran.h (working copy) @@ -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 182620) +++ gcc/fortran/trans-decl.c (working copy) @@ -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; @@ -600,7 +601,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) || sym->as->type != AS_EXPLICIT || sym->attr.pointer || sym->attr.allocatable) - && !DECL_ARTIFICIAL (decl)) + && !DECL_ARTIFICIAL (decl) + && !sym->attr.recursive) TREE_STATIC (decl) = 1; /* Handle threadprivate variables. */ @@ -1121,7 +1123,8 @@ gfc_add_assign_aux_vars (gfc_symbol * sym) gcc_assert (sym->backend_decl); decl = sym->backend_decl; - gfc_allocate_lang_decl (decl); + if (DECL_LANG_SPECIFIC (decl) == NULL) + gfc_allocate_lang_decl (decl); GFC_DECL_ASSIGN (decl) = 1; length = build_decl (input_location, VAR_DECL, create_tmp_var_name (sym->name), @@ -1283,9 +1286,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) TREE_USED (sym->backend_decl) = 1; if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0) - { - gfc_add_assign_aux_vars (sym); - } + gfc_add_assign_aux_vars (sym); if (sym->attr.dimension && DECL_LANG_SPECIFIC (sym->backend_decl) @@ -2541,6 +2542,10 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int pa if (!sym) return NULL_TREE; + if (sym->attr.assign + && GFC_DECL_ASSIGN (sym->backend_decl) == 0) + gfc_add_assign_aux_vars (sym); + if (sym->ts.type == BT_CHARACTER) { if (sym->ts.u.cl->backend_decl == NULL_TREE) @@ -2597,6 +2602,9 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int pa else current_fake_result_decl = build_tree_list (NULL, decl); + if (sym->attr.assign) + DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl); + return decl; } @@ -3163,8 +3171,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 +3700,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 +3726,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 +3776,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 182620) +++ gcc/fortran/trans-intrinsic.c (working copy) @@ -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 182620) +++ libgfortran/caf/single.c (working copy) @@ -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 182620) +++ libgfortran/caf/mpi.c (working copy) @@ -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 182620) +++ libgfortran/caf/libcaf.h (working copy) @@ -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 (working copy) @@ -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/coarray/allocate_errgmsg.f90 =================================================================== --- gcc/testsuite/gfortran.dg/coarray/allocate_errgmsg.f90 (revision 0) +++ gcc/testsuite/gfortran.dg/coarray/allocate_errgmsg.f90 (working copy) @@ -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 182620) +++ gcc/testsuite/gfortran.dg/coarray/subobject_1.f90 (working copy) @@ -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