2011-12-30 Tobias Burnus <burnus@net-b.de>
* 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 <burnus@net-b.de>
* 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 <burnus@net-b.de>
* 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.
===================================================================
@@ -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
===================================================================
@@ -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,
===================================================================
@@ -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;
===================================================================
@@ -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);
}
}
===================================================================
@@ -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);
}
===================================================================
@@ -20,11 +20,12 @@ along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
/* 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);
===================================================================
@@ -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);
}
===================================================================
@@ -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:
===================================================================
@@ -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;
===================================================================
@@ -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. */
===================================================================
@@ -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. */
===================================================================
@@ -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;
===================================================================
@@ -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);
}
===================================================================
@@ -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);
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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" } }
===================================================================
@@ -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" } }
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