OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

2012-01-06 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.

2012-01-06  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.

2012-01-06  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.

From-SVN: r182951
This commit is contained in:
Tobias Burnus 2012-01-06 14:38:49 +01:00 committed by Tobias Burnus
parent af0aec67b8
commit 5d81ddd07f
23 changed files with 501 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
gcc/fortran/ChangeLog
View File

@ -1,3 +1,34 @@
2012-01-06 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.
2012-01-05 Paul Thomas <pault@gcc.gnu.org>
PR fortran/PR48946

16
gcc/fortran/expr.c
View File

@ -1,6 +1,6 @@
/* Routines for manipulation of expression nodes.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
2009, 2010, 2011
2009, 2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Andy Vaught
@ -4264,13 +4264,17 @@ 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;

4
gcc/fortran/libgfortran.h
View File

@ -1,5 +1,5 @@
/* Header file to the Fortran front-end and runtime library
Copyright (C) 2007, 2008, 2009, 2010, 2011
Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012
Free Software Foundation, Inc.
This file is part of GCC.
@ -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;

40
gcc/fortran/trans-array.c
View File

@ -4938,7 +4938,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
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;
@ -5064,7 +5064,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
/* 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);
@ -5127,24 +5127,40 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
/*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);
@ -7055,7 +7071,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
/* 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;
@ -7069,7 +7085,9 @@ gfc_trans_dealloc_allocated (tree descriptor)
/* 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. */
@ -7358,7 +7376,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
{
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)
@ -7388,7 +7406,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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,
@ -8094,7 +8113,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
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);
}

9
gcc/fortran/trans-array.h
View File

@ -1,5 +1,5 @@
/* Header for array handling functions
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2012
Free Software Foundation, Inc.
Contributed by Paul Brook
@ -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 *, tree, gfc_wrapped_block *);
/* Generate entry and exit code for g77 calling convention arrays. */
void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
/* Generate code to deallocate an array, if it is allocated. */
tree gfc_trans_dealloc_allocated (tree);
tree gfc_trans_dealloc_allocated (tree, bool);
tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank);

27
gcc/fortran/trans-decl.c
View File

@ -1,6 +1,6 @@
/* Backend function setup
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
2011
2011, 2012
Free Software Foundation, Inc.
Contributed by Paul Brook
@ -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,7 +3164,11 @@ 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, gfc_wrapped_block * block)
{
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, gfc_wrapped_block * block)
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, gfc_wrapped_block * block)
/* 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. */

10
gcc/fortran/trans-expr.c
View File

@ -3525,7 +3525,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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,
@ -3665,7 +3667,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
tmp = build_fold_indirect_ref_loc (input_location,
parmse.expr);
tmp = gfc_trans_dealloc_allocated (tmp);
tmp = gfc_trans_dealloc_allocated (tmp, false);
if (fsym->attr.optional
&& e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional)
@ -4335,7 +4337,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* 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);
}
}

6
gcc/fortran/trans-intrinsic.c
View File

@ -1,5 +1,6 @@
/* Intrinsic translation
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
2011, 2012
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
@ -7355,7 +7356,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. */

6
gcc/fortran/trans-openmp.c
View File

@ -1,5 +1,5 @@
/* OpenMP directive translation -- generate GCC trees from gfc_code.
Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011
Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Jakub Jelinek <jakub@redhat.com>
@ -326,7 +326,7 @@ gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
/* 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 *sym, locus where)
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

190
gcc/fortran/trans-stmt.c
View File

@ -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 <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
@ -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);
}
if (code->expr1)
{
tmp = build1_v (LABEL_EXPR, label_errmsg);
gfc_add_expr_to_block (&block, tmp);
}
/* Set ERRMSG - only needed if STAT is available. */
if (code->expr1 && code->expr2)
{
const char *msg = "Attempt to deallocate an unallocated object";
stmtblock_t errmsg_block;
tree errmsg_str, slen, dlen, cond;
gfc_init_block (&errmsg_block);
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);
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);
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));
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), astat);
tmp = convert (TREE_TYPE (se.expr), stat);
gfc_add_modify (&block, se.expr, tmp);
}
/* Set ERRMSG. */
if (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;
gfc_init_se (&se, NULL);
gfc_conv_expr_lhs (&se, code->expr2);
errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
gfc_add_modify (&block, errmsg,
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);
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, astat,
build_int_cst (TREE_TYPE (astat), 0));
tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
}

148
gcc/fortran/trans.c
View File

@ -1,5 +1,5 @@
/* Code translation -- generate GCC trees from gfc_code.
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2012
Free Software Foundation, Inc.
Contributed by Paul Brook
@ -653,7 +653,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
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 pointer, tree size,
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, tree mem, tree size, tree token,
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,13 +868,27 @@ 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 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
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 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
/* 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 (status != NULL_TREE && !integer_zerop (status))
if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB)
{
/* 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));
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))
{
/* 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
{
tree caf_type, token, cond2;
tree pstat = null_pointer_node;
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,

9
gcc/fortran/trans.h
View File

@ -1,5 +1,6 @@
/* Header for code translation functions
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
2011, 2012
Free Software Foundation, Inc.
Contributed by Paul Brook
@ -587,14 +588,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(). */
@ -676,6 +678,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;

10
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,13 @@
2012-01-06 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.
2012-01-06 Andrew Stubbs <ams@codesourcery.com>
* gcc.target/arm/headmerge-2.c: Adjust scan pattern.

36
gcc/testsuite/gfortran.dg/coarray/allocate_errgmsg.f90 Normal file
View File

@ -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

12
gcc/testsuite/gfortran.dg/coarray/subobject_1.f90
View File

@ -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

21
gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 Normal file
View File

@ -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" } }

23
gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 Normal file
View File

@ -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" } }

4
gcc/testsuite/gfortran.dg/deallocate_stat.f90
View File

@ -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

30
gcc/testsuite/gfortran.dg/deallocate_stat_2.f90 Normal file
View File

@ -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

8
libgfortran/ChangeLog
View File

@ -1,3 +1,11 @@
2012-01-06 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-22 Janne Blomqvist <jb@gcc.gnu.org>
Tobias Burnus <burnus@net-b.de>

8
libgfortran/caf/libcaf.h
View File

@ -1,5 +1,5 @@
/* Common declarations for all of GNU Fortran libcaf implementations.
Copyright (C) 2011
Copyright (C) 2011, 2012
Free Software Foundation, Inc.
Contributed by Tobias Burnus <burnus@net-b.de>
@ -44,7 +44,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#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);

21
libgfortran/caf/mpi.c
View File

@ -1,5 +1,5 @@
/* MPI implementation of GNU Fortran Coarray Library
Copyright (C) 2011
Copyright (C) 2011, 2012
Free Software Foundation, Inc.
Contributed by Tobias Burnus <burnus@net-b.de>
@ -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 @@ _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
/* 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 @@ _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
{
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 @@ _gfortran_caf_deregister (void **token, int *stat, char *errmsg, int errmsg_len)
if (stat)
*stat = 0;
free (token[caf_this_image-1]);
free (token);
free ((*token)[caf_this_image-1]);
free (*token);
}

14
libgfortran/caf/single.c
View File

@ -1,5 +1,5 @@
/* Single-image implementation of GNU Fortran Coarray Library
Copyright (C) 2011
Copyright (C) 2011, 2012
Free Software Foundation, Inc.
Contributed by Tobias Burnus <burnus@net-b.de>
@ -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 @@ _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
{
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 @@ _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
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;