From d0d776fb3221737c425028a15362787b9ce4f372 Mon Sep 17 00:00:00 2001 From: burnus Date: Fri, 6 Jan 2012 13:38:49 +0000 Subject: 2012-01-06 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. 2012-01-06 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. 2012-01-06 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@182951 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-stmt.c | 168 +++++++++++++++++++++++++---------------------- 1 file changed, 91 insertions(+), 77 deletions(-) (limited to 'gcc/fortran/trans-stmt.c') diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 92f7f43729b..9456e2d3b05 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1,6 +1,6 @@ /* Statement translation -- generate GCC trees from gfc_code. Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, - 2011 + 2011, 2012 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -755,8 +755,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) @@ -4738,10 +4738,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 { @@ -4752,8 +4752,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; @@ -4772,7 +4771,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. */ @@ -4892,7 +4892,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); @@ -4919,18 +4919,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); } @@ -5102,26 +5096,24 @@ 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))); @@ -5130,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)); @@ -5142,16 +5134,15 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); } - /* STAT (ERRMSG only makes sense with STAT). */ - if (code->expr1) - { - tmp = build1_v (LABEL_EXPR, label_finish); - gfc_add_expr_to_block (&block, tmp); - } - /* STAT block. */ if (code->expr1) { + if (TREE_USED (label_finish)) + { + tmp = build1_v (LABEL_EXPR, label_finish); + gfc_add_expr_to_block (&block, tmp); + } + gfc_init_se (&se, NULL); gfc_conv_expr_lhs (&se, code->expr1); tmp = convert (TREE_TYPE (se.expr), stat); @@ -5172,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) @@ -5212,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) { @@ -5232,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 @@ -5261,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); @@ -5275,48 +5281,56 @@ 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); } -- cgit v1.2.1