The attached patch fixes PR 49755, allowing GFortran to behave correctly
when faced with multiple allocations:
allocate(A(20,20))
A = 42
! Allocate of already allocated variable
allocate (A(5,5), stat=stat)
The patch fixes an error in the test suite (multiple_allocation_1.f90)
and introduces a new test for the suite (attached). The ChangeLog is
also attached. The ChangeLog has two parts, which are set to go to
gcc/fortran and gcc/testsuite respectively.
Ok for trunk?
Cheers,
Daniel.
--
I'm not overweight, I'm undertall.
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (revision 176622)
+++ gcc/fortran/trans-array.c (working copy)
@@ -4146,3 +4146,3 @@ gfc_conv_descriptor_cosize (tree desc, i
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);
@@ -4164,4 +4164,4 @@ 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)
{
@@ -4191,3 +4191,3 @@ gfc_array_init_size (tree descriptor, in
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)));
@@ -4224,4 +4224,4 @@ gfc_array_init_size (tree descriptor, in
}
- 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;
@@ -4240,3 +4240,3 @@ gfc_array_init_size (tree descriptor, in
- gfc_conv_descriptor_ubound_set (pblock, descriptor,
+ gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
gfc_rank_cst[n], se.expr);
@@ -4245,3 +4245,3 @@ gfc_array_init_size (tree descriptor, in
/* Store the stride. */
- gfc_conv_descriptor_stride_set (pblock, descriptor,
+ gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
gfc_rank_cst[n], stride);
@@ -4305,4 +4305,4 @@ gfc_array_init_size (tree descriptor, in
}
- 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);
@@ -4314,3 +4314,3 @@ gfc_array_init_size (tree descriptor, in
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);
@@ -4397,2 +4397,4 @@ gfc_array_allocate (gfc_se * se, gfc_exp
tree cond;
+ tree set_descriptor;
+ stmtblock_t set_descriptor_block;
stmtblock_t elseblock;
@@ -4463,5 +4465,8 @@ gfc_array_allocate (gfc_se * se, gfc_exp
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)
@@ -4493,3 +4498,3 @@ gfc_array_allocate (gfc_se * se, gfc_exp
gfc_start_block (&elseblock);
-
+
/* Allocate memory to store the data. */
@@ -4500,11 +4505,6 @@ gfc_array_allocate (gfc_se * se, gfc_exp
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);
@@ -4522,4 +4522,19 @@ gfc_array_allocate (gfc_se * se, gfc_exp
+ /* 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);
Index: gcc/fortran/trans-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c (revision 176622)
+++ gcc/fortran/trans-openmp.c (working copy)
@@ -190,6 +190,7 @@ gfc_omp_clause_default_ctor (tree clause
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);
@@ -243,6 +244,7 @@ gfc_omp_clause_copy_ctor (tree clause, t
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,
@@ -665,6 +667,7 @@ gfc_trans_omp_array_reduction (tree c, g
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,
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 176622)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -4869,11 +4869,6 @@ gfc_trans_allocate (gfc_code * code)
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);
@@ -4903,3 +4898,3 @@ gfc_trans_allocate (gfc_code * code)
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- parm, tmp,
+ gfc_unlikely(parm), tmp,
build_empty_stmt (input_location));
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (revision 176622)
+++ gcc/fortran/trans.c (working copy)
@@ -584,7 +584,7 @@ gfc_call_malloc (stmtblock_t * block, tr
} */
-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;
@@ -596,6 +596,3 @@ gfc_allocate_using_malloc (stmtblock_t *
- /* 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)
@@ -606,5 +603,4 @@ gfc_allocate_using_malloc (stmtblock_t *
/* 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,
@@ -625,12 +621,10 @@ gfc_allocate_using_malloc (stmtblock_t *
+ 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_unlikely(error_cond), 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));
-
- return res;
+ gfc_add_expr_to_block (block, tmp);
}
@@ -650,7 +644,7 @@ gfc_allocate_using_malloc (stmtblock_t *
} */
-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;
@@ -661,5 +655,2 @@ gfc_allocate_using_lib (stmtblock_t * bl
- /* Create a variable to hold the result. */
- res = gfc_create_var (prvoid_type_node, NULL);
-
/* The allocation itself. */
@@ -677,15 +668,16 @@ gfc_allocate_using_lib (stmtblock_t * bl
- 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);
}
@@ -707,8 +699,3 @@ gfc_allocate_using_lib (stmtblock_t * bl
if (stat)
- {
- free (mem);
- mem = allocate (size, stat);
stat = LIBERROR_ALLOCATION;
- return mem;
- }
else
@@ -720,3 +707,3 @@ gfc_allocate_using_lib (stmtblock_t * bl
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,
@@ -725,3 +712,3 @@ gfc_allocate_allocatable (stmtblock_t *
stmtblock_t alloc_block;
- tree res, tmp, null_mem, alloc, error;
+ tree tmp, null_mem, alloc, error;
tree type = TREE_TYPE (mem);
@@ -731,4 +718,2 @@ gfc_allocate_allocatable (stmtblock_t *
- /* Create a variable to hold the result. */
- res = gfc_create_var (type, NULL);
null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
@@ -743,8 +728,7 @@ gfc_allocate_allocatable (stmtblock_t *
&& 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);
@@ -774,16 +758,5 @@ gfc_allocate_allocatable (stmtblock_t *
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));
}
@@ -793,4 +766,2 @@ gfc_allocate_allocatable (stmtblock_t *
gfc_add_expr_to_block (block, tmp);
-
- return res;
}
@@ -1621,1 +1592,17 @@ gfc_unlikely (tree 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;
+}
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 176622)
+++ gcc/fortran/trans.h (working copy)
@@ -543,3 +543,3 @@ tree gfc_build_memcpy_call (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*);
@@ -547,4 +547,4 @@ tree gfc_allocate_allocatable (stmtblock
/* 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);
Index: gcc/testsuite/gfortran.dg/multiple_allocation_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/multiple_allocation_1.f90 (revision 176622)
+++ gcc/testsuite/gfortran.dg/multiple_allocation_1.f90 (working copy)
@@ -10,3 +10,3 @@ program alloc_test
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)
@@ -14,3 +14,4 @@ program alloc_test
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
! { 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
2011-07-26 Daniel Carrera <dcarr...@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 "desciptor_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): Replace a call to
gfc_allocate_allocatable with gfc_allocate_using_malloc.
(gfc_omp_clause_copy_ctor): Ditto.
(gfc_trans_omp_array_reduction): Ditto.
* trans-stmt.c (gfc_trans_allocate): Update function calls for
gfc_allocate_allocatable and gfc_allocate_using_malloc.
2011-07-26 Daniel Carrera <dcarr...@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. Tests PR 49755.
