+2011-07-27 Daniel Carrera <dcarrera@gmail.com>
+
+ PR fortran/49755
+ * trans.c (gfc_allocate_using_malloc): Change function signature.
+ Return nothing. New parameter "pointer". Eliminate temorary variables.
+ (gfc_allocate_using_lib): Ditto.
+ (gfc_allocate_allocatable): Ditto. Update call to gfc_allocate_using_lib
+ and gfc_allocate_using_malloc. Do not free and then reallocate a
+ variable that is already allocated.
+ (gfc_likely): New function. Basedon gfc_unlikely.
+ * trans-array.c (gfc_array_init_size): New parameter "descriptor_block".
+ Instructions to modify the array descriptor are stored in this block
+ while other instructions continue to be stored in "pblock".
+ (gfc_array_allocate): Update call to gfc_array_init_size. Move the
+ descriptor_block so that the array descriptor is only updated if
+ the array was allocated successfully.
+ Update calls to gfc_allocate_allocatable and gfc_allocate_using_malloc.
+ * trans.h (gfc_allocate_allocatable): Change function signature.
+ Function now returns void.
+ (gfc_allocate_using_lib): Ditto, and new function parameter.
+ (gfc_allocate_using_malloc): Ditto.
+ * trans-openmp.c (gfc_omp_clause_default_ctor,
+ gfc_omp_clause_copy_ctor,gfc_trans_omp_array_reduction): Replace a call
+ to gfc_allocate_allocatable with gfc_allocate_using_malloc.
+ * trans-stmt.c (gfc_trans_allocate): Update function calls for
+ gfc_allocate_allocatable and gfc_allocate_using_malloc.
+
2011-07-26 Tobias Burnus <burnus@net-b.de>
* trans-array.c (CAF_TOKEN_FIELD): New macro constant.
size = 1 - lbound;
a.ubound[n] = specified_upper_bound;
a.stride[n] = stride;
- size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
+ size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
stride = stride * size;
}
static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
- gfc_expr ** lower, gfc_expr ** upper,
- stmtblock_t * pblock, tree * overflow)
+ gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
+ stmtblock_t * descriptor_block, tree * overflow)
{
tree type;
tree tmp;
/* Set the dtype. */
tmp = gfc_conv_descriptor_dtype (descriptor);
- gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
+ gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
or_expr = boolean_false_node;
ubound = lower[n];
}
}
- gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
- se.expr);
+ gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
+ gfc_rank_cst[n], se.expr);
conv_lbound = se.expr;
/* Work out the offset for this component. */
gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
- gfc_conv_descriptor_ubound_set (pblock, descriptor,
+ gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
gfc_rank_cst[n], se.expr);
conv_ubound = se.expr;
/* Store the stride. */
- gfc_conv_descriptor_stride_set (pblock, descriptor,
+ gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
gfc_rank_cst[n], stride);
/* Calculate size and check whether extent is negative. */
ubound = lower[n];
}
}
- gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
- se.expr);
+ gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
+ gfc_rank_cst[n], se.expr);
if (n < rank + corank - 1)
{
gcc_assert (ubound);
gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
- gfc_conv_descriptor_ubound_set (pblock, descriptor,
+ gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
gfc_rank_cst[n], se.expr);
}
}
tree overflow; /* Boolean storing whether size calculation overflows. */
tree var_overflow = NULL_TREE;
tree cond;
+ tree set_descriptor;
+ stmtblock_t set_descriptor_block;
stmtblock_t elseblock;
gfc_expr **lower;
gfc_expr **upper;
}
overflow = integer_zero_node;
+
+ gfc_init_block (&set_descriptor_block);
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
- &se->pre, &overflow);
+ &se->pre, &set_descriptor_block, &overflow);
+
if (dimension)
{
}
gfc_start_block (&elseblock);
-
+
/* Allocate memory to store the data. */
pointer = gfc_conv_descriptor_data_get (se->expr);
STRIP_NOPS (pointer);
/* The allocatable variant takes the old pointer as first argument. */
if (allocatable)
- tmp = gfc_allocate_allocatable (&elseblock, pointer, size,
- status, errmsg, errlen, expr);
+ gfc_allocate_allocatable (&elseblock, pointer, size,
+ status, errmsg, errlen, expr);
else
- tmp = gfc_allocate_using_malloc (&elseblock, size, status);
-
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- pointer, tmp);
-
- gfc_add_expr_to_block (&elseblock, tmp);
+ gfc_allocate_using_malloc (&elseblock, pointer, size, status);
if (dimension)
{
gfc_add_expr_to_block (&se->pre, tmp);
+ /* Update the array descriptors. */
if (dimension)
- gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
+ gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
+
+ set_descriptor = gfc_finish_block (&set_descriptor_block);
+ if (status != NULL_TREE)
+ {
+ cond = fold_build2_loc (input_location, EQ_EXPR,
+ boolean_type_node, status,
+ build_int_cst (TREE_TYPE (status), 0));
+ gfc_add_expr_to_block (&se->pre,
+ fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_likely (cond), set_descriptor,
+ build_empty_stmt (input_location)));
+ }
+ else
+ gfc_add_expr_to_block (&se->pre, set_descriptor);
if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
&& expr->ts.u.derived->attr.alloc_comp)
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, esize);
size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
- ptr = gfc_allocate_allocatable (&cond_block,
- build_int_cst (pvoid_type_node, 0),
- size, NULL_TREE, NULL_TREE, NULL_TREE, NULL);
+
+ ptr = gfc_create_var (pvoid_type_node, NULL);
+ gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
+
then_b = gfc_finish_block (&cond_block);
gfc_init_block (&cond_block);
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, esize);
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
- ptr = gfc_allocate_allocatable (&block,
- build_int_cst (pvoid_type_node, 0),
- size, NULL_TREE, NULL_TREE, NULL_TREE, NULL);
+
+ ptr = gfc_create_var (pvoid_type_node, NULL);
+ gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE);
gfc_conv_descriptor_data_set (&block, dest, ptr);
+
call = build_call_expr_loc (input_location,
built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
fold_convert (pvoid_type_node,
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, esize);
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
- ptr = gfc_allocate_allocatable (&block,
- build_int_cst (pvoid_type_node, 0),
- size, NULL_TREE, NULL_TREE, NULL_TREE, NULL);
+
+ ptr = gfc_create_var (pvoid_type_node, NULL);
+ gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE);
gfc_conv_descriptor_data_set (&block, decl, ptr);
+
gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false,
false));
stmt = gfc_finish_block (&block);
/* Allocate - for non-pointers with re-alloc checking. */
if (gfc_expr_attr (expr).allocatable)
- tmp = gfc_allocate_allocatable (&se.pre, se.expr, memsz,
- stat, errmsg, errlen, expr);
+ gfc_allocate_allocatable (&se.pre, se.expr, memsz,
+ stat, errmsg, errlen, expr);
else
- tmp = gfc_allocate_using_malloc (&se.pre, memsz, stat);
-
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- se.expr,
- fold_convert (TREE_TYPE (se.expr), tmp));
- gfc_add_expr_to_block (&se.pre, tmp);
+ gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
{
boolean_type_node, stat,
build_int_cst (TREE_TYPE (stat), 0));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- parm, tmp,
+ gfc_unlikely(parm), tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
}
}
return newmem;
} */
-tree
-gfc_allocate_using_malloc (stmtblock_t * block, tree size, tree status)
+void
+gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
+ tree size, tree status)
{
- stmtblock_t alloc_block;
- tree res, tmp, on_error;
+ tree tmp, on_error, error_cond;
tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
/* Evaluate size only once, and make sure it has the right type. */
if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
size = fold_convert (size_type_node, size);
- /* Create a variable to hold the result. */
- res = gfc_create_var (prvoid_type_node, NULL);
-
- /* Set the optional status variable to zero. */
+ /* If successful and stat= is given, set status to 0. */
if (status != NULL_TREE)
gfc_add_expr_to_block (block,
fold_build2_loc (input_location, MODIFY_EXPR, status_type,
status, build_int_cst (status_type, 0)));
/* The allocation itself. */
- gfc_start_block (&alloc_block);
- gfc_add_modify (&alloc_block, res,
- fold_convert (prvoid_type_node,
+ gfc_add_modify (block, pointer,
+ fold_convert (TREE_TYPE (pointer),
build_call_expr_loc (input_location,
built_in_decls[BUILT_IN_MALLOC], 1,
fold_build2_loc (input_location,
gfc_build_localized_cstring_const
("Allocation would exceed memory limit")));
+ error_cond = fold_build2_loc (input_location, EQ_EXPR,
+ boolean_type_node, pointer,
+ build_int_cst (prvoid_type_node, 0));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- fold_build2_loc (input_location, EQ_EXPR,
- boolean_type_node, res,
- build_int_cst (prvoid_type_node, 0)),
- on_error, build_empty_stmt (input_location));
-
- gfc_add_expr_to_block (&alloc_block, tmp);
- gfc_add_expr_to_block (block, gfc_finish_block (&alloc_block));
+ gfc_unlikely(error_cond), on_error,
+ build_empty_stmt (input_location));
- return res;
+ gfc_add_expr_to_block (block, tmp);
}
newmem = _caf_register ( size, regtype, NULL, &stat, NULL, NULL);
return newmem;
} */
-tree
-gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status,
- tree errmsg, tree errlen)
+void
+gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
+ tree status, tree errmsg, tree errlen)
{
- tree res, pstat;
+ tree tmp, pstat;
/* Evaluate size only once, and make sure it has the right type. */
size = gfc_evaluate_now (size, block);
if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
size = fold_convert (size_type_node, size);
- /* Create a variable to hold the result. */
- res = gfc_create_var (prvoid_type_node, NULL);
-
/* The allocation itself. */
if (status == NULL_TREE)
pstat = null_pointer_node;
errlen = build_int_cst (integer_type_node, 0);
}
- gfc_add_modify (block, res,
- fold_convert (prvoid_type_node,
- build_call_expr_loc (input_location,
- gfor_fndecl_caf_register, 6,
- fold_build2_loc (input_location,
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_caf_register, 6,
+ fold_build2_loc (input_location,
MAX_EXPR, size_type_node, size,
build_int_cst (size_type_node, 1)),
- build_int_cst (integer_type_node,
+ build_int_cst (integer_type_node,
GFC_CAF_COARRAY_ALLOC),
- null_pointer_node, /* token */
- pstat, errmsg, errlen)));
+ null_pointer_node, /* token */
+ pstat, errmsg, errlen);
- return res;
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (pointer), pointer,
+ fold_convert ( TREE_TYPE (pointer), tmp));
+ gfc_add_expr_to_block (block, tmp);
}
else
{
if (stat)
- {
- free (mem);
- mem = allocate (size, stat);
stat = LIBERROR_ALLOCATION;
- return mem;
- }
else
runtime_error ("Attempting to allocate already allocated variable");
}
expr must be set to the original expression being allocated for its locus
and variable name in case a runtime error has to be printed. */
-tree
+void
gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree status,
tree errmsg, tree errlen, gfc_expr* expr)
{
stmtblock_t alloc_block;
- tree res, tmp, null_mem, alloc, error;
+ tree tmp, null_mem, alloc, error;
tree type = TREE_TYPE (mem);
if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
size = fold_convert (size_type_node, size);
- /* Create a variable to hold the result. */
- res = gfc_create_var (type, NULL);
null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, mem,
build_int_cst (type, 0)));
if (gfc_option.coarray == GFC_FCOARRAY_LIB
&& gfc_expr_attr (expr).codimension)
- tmp = gfc_allocate_using_lib (&alloc_block, size, status,
- errmsg, errlen);
+ gfc_allocate_using_lib (&alloc_block, mem, size, status,
+ errmsg, errlen);
else
- tmp = gfc_allocate_using_malloc (&alloc_block, size, status);
+ gfc_allocate_using_malloc (&alloc_block, mem, size, status);
- gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
alloc = gfc_finish_block (&alloc_block);
/* If mem is not NULL, we issue a runtime error or set the
if (status != NULL_TREE)
{
tree status_type = TREE_TYPE (status);
- stmtblock_t set_status_block;
-
- gfc_start_block (&set_status_block);
- tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_FREE], 1,
- fold_convert (pvoid_type_node, mem));
- gfc_add_expr_to_block (&set_status_block, tmp);
-
- tmp = gfc_allocate_using_malloc (&set_status_block, size, status);
- gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
- gfc_add_modify (&set_status_block, status,
- build_int_cst (status_type, LIBERROR_ALLOCATION));
- error = gfc_finish_block (&set_status_block);
+ error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ status, build_int_cst (status_type, LIBERROR_ALLOCATION));
}
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
error, alloc);
gfc_add_expr_to_block (block, tmp);
-
- return res;
}
cond = fold_convert (boolean_type_node, cond);
return cond;
}
+
+
+/* Helper function for marking a boolean expression tree as likely. */
+
+tree
+gfc_likely (tree cond)
+{
+ tree tmp;
+
+ cond = fold_convert (long_integer_type_node, cond);
+ tmp = build_one_cst (long_integer_type_node);
+ cond = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
+ cond = fold_convert (boolean_type_node, cond);
+ return cond;
+}
/* Get the string length of an array constructor. */
bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor_base, tree *);
-/* Mark a condition as unlikely. */
+/* Mark a condition as likely or unlikely. */
+tree gfc_likely (tree);
tree gfc_unlikely (tree);
/* Generate a runtime error call. */
tree gfc_build_memcpy_call (tree, tree, tree);
/* Allocate memory for allocatable variables, with optional status variable. */
-tree gfc_allocate_allocatable (stmtblock_t*, tree, tree,
+void gfc_allocate_allocatable (stmtblock_t*, tree, tree,
tree, tree, tree, gfc_expr*);
/* Allocate memory, with optional status variable. */
-tree gfc_allocate_using_malloc (stmtblock_t *, tree, tree);
-tree gfc_allocate_using_lib (stmtblock_t *, tree, tree, tree, tree);
+void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree);
+void gfc_allocate_using_lib (stmtblock_t *, tree, tree, tree, tree, tree);
/* Generate code to deallocate an array. */
tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*);
+2011-07-27 Daniel Carrera <dcarrera@gmail.com>
+
+ PR fortran/49755
+ * gfortran.dg/multiple_allocation_1.f90: Fix test. Allocating an
+ allocated array should *not* change its size.
+ * gfortran.dg/multiple_allocation_3.f90: New test.
+
2011-07-26 Paolo Carlini <paolo.carlini@oracle.com>
PR c++/49776
! { dg-do run }
! PR 25031 - We didn't cause an error when allocating an already
! allocated array.
+!
+! This testcase has been modified to fix PR 49755.
program alloc_test
implicit none
integer :: i
integer, pointer :: b(:)
allocate(a(4))
- ! This should set the stat code and change the size.
+ ! This should set the stat code but not change the size.
allocate(a(3),stat=i)
if (i == 0) call abort
if (.not. allocated(a)) call abort
- if (size(a) /= 3) call abort
+ if (size(a) /= 4) call abort
+
! It's OK to allocate pointers twice (even though this causes
! a memory leak)
allocate(b(4))
--- /dev/null
+! { dg-do run }
+! PR 49755 - If allocating an already allocated array, and stat=
+! is given, set stat to non zero and do not touch the array.
+program test
+ integer, allocatable :: A(:, :)
+ integer :: stat
+
+ allocate(A(20,20))
+ A = 42
+
+ ! Allocate of already allocated variable
+ allocate (A(5,5), stat=stat)
+
+ ! Expected: Error stat and previous allocation status
+ if (stat == 0) call abort ()
+ if (any (shape (A) /= [20, 20])) call abort ()
+ if (any (A /= 42)) call abort ()
+end program
+
OSDN Git Service
