On 07/21/2011 04:19 PM, Tobias Burnus wrote:
On 07/21/2011 01:09 PM, Daniel Carrera wrote:
This patch now fixes an existing bug in GFortran whereby the ALLOCATE
statement only gets error checking if you are allocating a scalar.
Somehow that does not seem to work. I just tried a vanilla trunk with
just your patch applied. For the following, I do not get a single
"goto". That's different to your dumps, where you get two (though, in
your case, you had a scalar and a scalar coarray).
integer, allocatable :: A(:), B[:]
integer :: stat
character(len=33) :: str
allocate(A(1), B[*], stat=stat)!, errmsg=str)
end
Thus, I wonder whether you have send the correct patch, if not, the
question is really why we see those large differences.
From what you posted, it looks like I sent the wrong patch. I generated
the patch again with a different name just to make sure I'm not mixing
it up (attached).
I tried you code sample and for me it works perfectly:
daniel ~/GCC % cat test2.f90
program test
integer, allocatable :: A(:), B[:]
integer :: stat
character(len=33) :: str
allocate(A(1), B[*], stat=stat)
end program
daniel ~/GCC % mpif90 -fcoarray=lib
-fdump-tree-original test2.f90 mpi.o
The result is attached. You'll find that the gotos are there, just as
they should be:
a.data = 0B;
b.data = 0B;
{
....
if ((logical(kind=4)) __builtin_expect (overflow.1 != 0, 0))
{
stat.0 = 5014;
}
else
{
{
...
a.data = D.1539;
}
}
a.offset = -1;
if (stat.0 != 0) goto L.1;
...
}
b.data = D.1542;
}
if (stat.0 != 0) goto L.2;
L.1:;
L.2:;
stat = stat.0;
That also fits with the code:
- if (!gfc_array_allocate (&se, expr, pstat))
+ if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
{
...
if (code->expr1 || code->expr2)
{
- tmp = build1_v (GOTO_EXPR, error_label);
+ /* 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);
...
}
Where the code is still in the scalar-allocation loop.
That's clearly I wrong... I guess I did send the wrong patch.
Can you change the "if ()" into "if(code->expr1)", i.e. only checking
whether STAT= is present? There is no point of generating code for
ERRMSG= if STAT= is not present.
Ok. The attached patch includes that change (technically I haven't
tested it, but I'll test before committing).
+ /* ERRMSG= */
+ errmsg = null_pointer_node;
+ errlen = build_int_cst (gfc_charlen_type_node, 0);
+ if (code->expr2)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_lhs (&se, code->expr2);
+
+ errlen = gfc_get_expr_charlen (code->expr2);
+ errmsg = gfc_build_addr_expr (pchar_type_node, se.expr);
+ }
As said in previous review: Use:
else
{
errmsg = null_pointer_node;
errlen = build_int_cst (gfc_charlen_type_node, 0);
}
That avoids evaluating uselessly build_int_cst, which is cheap but
changing the code comes for free.
Fixed. Included in the attached patch. Will test before committing.
- /* STAT block. */
- if (code->expr1)
+ /* STAT or ERRMSG. */
+ if (code->expr1 || code->expr2)
I believe here applies the same: The code will be unreachable if there
is no STAT=.
+ /* STAT or ERRMSG. */
+ if (code->expr1 || code->expr2)
Ditto.
Fixed. I also changed the comments to remind ourselves later why we
don't check for ERRMSG.
Cheers,
Daniel.
--
I'm not overweight, I'm undertall.
test ()
{
struct array1_integer(kind=4) a;
struct array1_integer(kind=4) b;
integer(kind=4) stat;
try
{
a.data = 0B;
b.data = 0B;
{
integer(kind=4) overflow.1;
integer(kind=4) D.1537;
integer(kind=4) D.1536;
integer(kind=4) stat.0;
a.dtype = 265;
a.dim[0].lbound = 1;
a.dim[0].ubound = 1;
a.dim[0].stride = 1;
D.1536 = (logical(kind=4)) 0 ? 0 : (logical(kind=4)) 0 ? 1 : 0;
D.1537 = ((logical(kind=4)) 0 ? 0 : (logical(kind=4)) 0 ? 1 : 0) +
D.1536;
overflow.1 = D.1537;
if ((logical(kind=4)) __builtin_expect (overflow.1 != 0, 0))
{
stat.0 = 5014;
}
else
{
{
void * restrict D.1539;
if ((logical(kind=4)) __builtin_expect (a.data != 0B, 0))
{
{
void * restrict D.1541;
__builtin_free ((void *) a.data);
stat.0 = 0;
D.1541 = (void * restrict) __builtin_malloc (4);
if (D.1541 == 0B)
{
stat.0 = 5014;
}
D.1539 = D.1541;
stat.0 = 5014;
}
}
else
{
{
void * restrict D.1540;
stat.0 = 0;
D.1540 = (void * restrict) __builtin_malloc (4);
if (D.1540 == 0B)
{
stat.0 = 5014;
}
D.1539 = D.1540;
}
}
a.data = D.1539;
}
}
a.offset = -1;
if (stat.0 != 0) goto L.1;
b.dtype = 264;
b.dim[0].lbound = 1;
{
void * restrict D.1542;
if ((logical(kind=4)) __builtin_expect (b.data != 0B, 0))
{
{
void * restrict D.1544;
__builtin_free ((void *) b.data);
stat.0 = 0;
D.1544 = (void * restrict) __builtin_malloc (4);
if (D.1544 == 0B)
{
stat.0 = 5014;
}
D.1542 = D.1544;
stat.0 = 5014;
}
}
else
{
{
void * restrict D.1543;
stat.0 = 0;
D.1543 = (void * restrict) _gfortran_caf_register (4, 1, 0B,
&stat.0, 0B, 0);
D.1542 = D.1543;
}
}
b.data = D.1542;
}
if (stat.0 != 0) goto L.2;
L.1:;
L.2:;
stat = stat.0;
}
}
finally
{
if (b.data != 0B)
{
__builtin_free ((void *) b.data);
}
b.data = 0B;
if (a.data != 0B)
{
__builtin_free ((void *) a.data);
}
a.data = 0B;
}
}
main (integer(kind=4) argc, character(kind=1) * * argv)
{
static integer(kind=4) options.2[8] = {68, 1023, 0, 0, 1, 1, 0, 1};
_gfortran_caf_init (&argc, &argv, &_gfortran_caf_this_image,
&_gfortran_caf_num_images);
_gfortran_set_args (argc, argv);
_gfortran_set_options (8, &options.2[0]);
test ();
__sync_synchronize ();
_gfortran_caf_finalize ();
return 0;
}
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (revision 176528)
+++ gcc/fortran/trans-array.c (working copy)
@@ -4384,3 +4384,4 @@ gfc_array_init_size (tree descriptor, in
bool
-gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
+gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
+ tree errlen)
{
@@ -4479,18 +4480,11 @@ gfc_array_allocate (gfc_se * se, gfc_exp
- if (pstat != NULL_TREE && !integer_zerop (pstat))
- {
- /* Set the status variable if it's present. */
+ if (status != NULL_TREE)
+ {
+ tree status_type = TREE_TYPE (status);
stmtblock_t set_status_block;
- tree status_type = pstat ? TREE_TYPE (TREE_TYPE (pstat)) : NULL_TREE;
gfc_start_block (&set_status_block);
- gfc_add_modify (&set_status_block,
- fold_build1_loc (input_location, INDIRECT_REF,
- status_type, pstat),
- build_int_cst (status_type, LIBERROR_ALLOCATION));
-
- tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- pstat, build_int_cst (TREE_TYPE (pstat), 0));
- error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
- error, gfc_finish_block (&set_status_block));
+ gfc_add_modify (&set_status_block, status,
+ build_int_cst (status_type, LIBERROR_ALLOCATION));
+ error = gfc_finish_block (&set_status_block);
}
@@ -4503,10 +4497,11 @@ gfc_array_allocate (gfc_se * se, gfc_exp
- /* The allocate_array variants take the old pointer as first argument. */
+ /* The allocatable variant takes the old pointer as first argument. */
if (allocatable)
- tmp = gfc_allocate_allocatable_with_status (&elseblock,
- pointer, size, pstat, expr);
+ tmp = gfc_allocate_allocatable (&elseblock, pointer, size,
+ status, errmsg, errlen, expr);
else
- tmp = gfc_allocate_with_status (&elseblock, size, pstat, false);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer,
- tmp);
+ tmp = gfc_allocate_using_malloc (&elseblock, size, status);
+
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ pointer, tmp);
Index: gcc/fortran/trans-array.h
===================================================================
--- gcc/fortran/trans-array.h (revision 176528)
+++ gcc/fortran/trans-array.h (working copy)
@@ -26,3 +26,3 @@ tree gfc_array_deallocate (tree, tree, g
se, which should contain an expression for the array descriptor. */
-bool gfc_array_allocate (gfc_se *, gfc_expr *, tree);
+bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree);
Index: gcc/fortran/trans-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c (revision 176528)
+++ gcc/fortran/trans-openmp.c (working copy)
@@ -190,5 +190,5 @@ gfc_omp_clause_default_ctor (tree clause
size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
- ptr = gfc_allocate_allocatable_with_status (&cond_block,
- build_int_cst (pvoid_type_node, 0),
- size, NULL, NULL);
+ ptr = gfc_allocate_allocatable (&cond_block,
+ build_int_cst (pvoid_type_node, 0),
+ size, NULL_TREE, NULL_TREE, NULL_TREE, NULL);
gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
@@ -243,5 +243,5 @@ gfc_omp_clause_copy_ctor (tree clause, t
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
- ptr = gfc_allocate_allocatable_with_status (&block,
- build_int_cst (pvoid_type_node, 0),
- size, NULL, NULL);
+ ptr = gfc_allocate_allocatable (&block,
+ build_int_cst (pvoid_type_node, 0),
+ size, NULL_TREE, NULL_TREE, NULL_TREE, NULL);
gfc_conv_descriptor_data_set (&block, dest, ptr);
@@ -665,5 +665,5 @@ gfc_trans_omp_array_reduction (tree c, g
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
- ptr = gfc_allocate_allocatable_with_status (&block,
- build_int_cst (pvoid_type_node, 0),
- size, NULL, NULL);
+ ptr = gfc_allocate_allocatable (&block,
+ build_int_cst (pvoid_type_node, 0),
+ size, NULL_TREE, NULL_TREE, NULL_TREE, NULL);
gfc_conv_descriptor_data_set (&block, decl, ptr);
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 176528)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -4688,4 +4688,6 @@ gfc_trans_allocate (gfc_code * code)
tree stat;
- tree pstat;
- tree error_label;
+ tree errmsg;
+ tree errlen;
+ tree label_errmsg;
+ tree label_finish;
tree memsz;
@@ -4701,3 +4703,4 @@ gfc_trans_allocate (gfc_code * code)
- pstat = stat = error_label = tmp = memsz = NULL_TREE;
+ stat = tmp = memsz = NULL_TREE;
+ label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
@@ -4709,9 +4712,23 @@ gfc_trans_allocate (gfc_code * code)
{
+ /* STAT= */
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);
-
- error_label = gfc_build_label_decl (NULL_TREE);
- TREE_USED (error_label) = 1;
+
+ /* ERRMSG= */
+ errmsg = null_pointer_node;
+ errlen = build_int_cst (gfc_charlen_type_node, 0);
+ if (code->expr2)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_lhs (&se, code->expr2);
+
+ errlen = gfc_get_expr_charlen (code->expr2);
+ errmsg = gfc_build_addr_expr (pchar_type_node, se.expr);
+ }
+
+ /* 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;
}
@@ -4734,3 +4751,3 @@ gfc_trans_allocate (gfc_code * code)
- if (!gfc_array_allocate (&se, expr, pstat))
+ if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
{
@@ -4849,6 +4866,6 @@ gfc_trans_allocate (gfc_code * code)
if (gfc_expr_attr (expr).allocatable)
- tmp = gfc_allocate_allocatable_with_status (&se.pre, se.expr, memsz,
- pstat, expr);
+ tmp = gfc_allocate_allocatable (&se.pre, se.expr, memsz,
+ stat, errmsg, errlen, expr);
else
- tmp = gfc_allocate_with_status (&se.pre, memsz, pstat, false);
+ tmp = gfc_allocate_using_malloc (&se.pre, memsz, stat);
@@ -4861,3 +4878,9 @@ gfc_trans_allocate (gfc_code * code)
{
- tmp = build1_v (GOTO_EXPR, error_label);
+ /* 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);
+
parm = fold_build2_loc (input_location, NE_EXPR,
@@ -5007,12 +5030,7 @@ gfc_trans_allocate (gfc_code * code)
- /* STAT block. */
- if (code->expr1)
+ /* STAT or ERRMSG. */
+ if (code->expr1 || code->expr2)
{
- tmp = build1_v (LABEL_EXPR, error_label);
+ tmp = build1_v (LABEL_EXPR, label_errmsg);
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);
- gfc_add_modify (&block, se.expr, tmp);
}
@@ -5024,3 +5042,3 @@ gfc_trans_allocate (gfc_code * code)
const char *msg = "Attempt to allocate an allocated object";
- tree errmsg, slen, dlen;
+ tree slen, dlen;
@@ -5052,2 +5070,18 @@ gfc_trans_allocate (gfc_code * code)
+ /* STAT or ERRMSG. */
+ if (code->expr1 || code->expr2)
+ {
+ 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);
+ gfc_add_modify (&block, se.expr, tmp);
+ }
+
gfc_add_block_to_block (&block, &se.post);
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (revision 176528)
+++ gcc/fortran/trans.c (working copy)
@@ -567,3 +567,3 @@ gfc_call_malloc (stmtblock_t * block, tr
void *
- allocate (size_t size, integer_type* stat)
+ allocate (size_t size, integer_type stat)
{
@@ -571,4 +571,4 @@ gfc_call_malloc (stmtblock_t * block, tr
- if (stat)
- *stat = 0;
+ if (stat requested)
+ stat = 0;
@@ -585,8 +585,7 @@ gfc_call_malloc (stmtblock_t * block, tr
tree
-gfc_allocate_with_status (stmtblock_t * block, tree size, tree status,
- bool coarray_lib)
+gfc_allocate_using_malloc (stmtblock_t * block, tree size, tree status)
{
stmtblock_t alloc_block;
- tree res, tmp, msg, cond;
- tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
+ tree res, tmp, on_error;
+ tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
@@ -601,15 +600,6 @@ gfc_allocate_with_status (stmtblock_t *
/* Set the optional status variable to zero. */
- if (status != NULL_TREE && !integer_zerop (status))
- {
- 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,
- fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node, status,
- build_int_cst (TREE_TYPE (status), 0)),
- tmp, build_empty_stmt (input_location));
- gfc_add_expr_to_block (block, tmp);
- }
+ 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)));
@@ -617,48 +607,19 @@ gfc_allocate_with_status (stmtblock_t *
gfc_start_block (&alloc_block);
- if (coarray_lib)
- {
- gfc_add_modify (&alloc_block, res,
- fold_convert (prvoid_type_node,
- 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,
- GFC_CAF_COARRAY_ALLOC),
- null_pointer_node, /* token */
- null_pointer_node, /* stat */
- null_pointer_node, /* errmsg, errmsg_len */
- build_int_cst (integer_type_node, 0))));
- }
+ gfc_add_modify (&alloc_block, res,
+ fold_convert (prvoid_type_node,
+ build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MALLOC], 1,
+ fold_build2_loc (input_location,
+ MAX_EXPR, size_type_node, size,
+ build_int_cst (size_type_node, 1)))));
+
+ /* What to do in case of error. */
+ if (status != NULL_TREE)
+ on_error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ status, build_int_cst (status_type, LIBERROR_ALLOCATION));
else
- {
- gfc_add_modify (&alloc_block, res,
- fold_convert (prvoid_type_node,
- build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MALLOC], 1,
- fold_build2_loc (input_location,
- MAX_EXPR, size_type_node, size,
- build_int_cst (size_type_node, 1)))));
- }
-
- msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
- ("Allocation would exceed memory limit"));
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_os_error, 1, msg);
-
- if (status != NULL_TREE && !integer_zerop (status))
- {
- /* Set the status variable if it's present. */
- tree tmp2;
-
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- status, build_int_cst (TREE_TYPE (status), 0));
- tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
- fold_build1_loc (input_location, INDIRECT_REF,
- status_type, status),
- build_int_cst (status_type, LIBERROR_ALLOCATION));
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- }
+ on_error = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1,
+ gfc_build_addr_expr (pchar_type_node,
+ gfc_build_localized_cstring_const
+ ("Allocation would exceed memory limit")));
@@ -668,3 +629,4 @@ gfc_allocate_with_status (stmtblock_t *
build_int_cst (prvoid_type_node, 0)),
- tmp, build_empty_stmt (input_location));
+ on_error, build_empty_stmt (input_location));
+
gfc_add_expr_to_block (&alloc_block, tmp);
@@ -676,2 +638,72 @@ gfc_allocate_with_status (stmtblock_t *
+/* Allocate memory, using an optional status argument.
+
+ This function follows the following pseudo-code:
+
+ void *
+ allocate (size_t size, integer_type stat)
+ {
+ void *newmem;
+
+ if (stat requested)
+ stat = 0;
+
+ newmem = _caf_register ( size, regtype, NULL, &stat, NULL, NULL);
+ if (newmem == NULL)
+ {
+ if (!stat requested)
+ runtime_error ("Allocation would exceed memory limit");
+ }
+ return newmem;
+ } */
+tree
+gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status,
+ tree errmsg, tree errlen)
+{
+ tree res, pstat;
+ tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
+
+ /* 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);
+
+ /* Set the optional status variable to zero. */
+ 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. */
+ if (status == NULL_TREE)
+ pstat = null_pointer_node;
+ else
+ pstat = gfc_build_addr_expr (NULL_TREE, status);
+
+ if (errmsg == NULL_TREE)
+ {
+ gcc_assert(errlen == NULL_TREE);
+ errmsg = 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,
+ MAX_EXPR, size_type_node, size,
+ build_int_cst (size_type_node, 1)),
+ build_int_cst (integer_type_node,
+ GFC_CAF_COARRAY_ALLOC),
+ null_pointer_node, /* token */
+ pstat, errmsg, errlen)));
+
+ return res;
+}
+
+
/* Generate code for an ALLOCATE statement when the argument is an
@@ -683,3 +715,3 @@ gfc_allocate_with_status (stmtblock_t *
void *
- allocate_allocatable (void *mem, size_t size, integer_type *stat)
+ allocate_allocatable (void *mem, size_t size, integer_type stat)
{
@@ -693,3 +725,3 @@ gfc_allocate_with_status (stmtblock_t *
mem = allocate (size, stat);
- *stat = LIBERROR_ALLOCATION;
+ stat = LIBERROR_ALLOCATION;
return mem;
@@ -704,4 +736,4 @@ gfc_allocate_with_status (stmtblock_t *
tree
-gfc_allocate_allocatable_with_status (stmtblock_t * block, tree mem, tree size,
- tree status, gfc_expr* expr)
+gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree status,
+ tree errmsg, tree errlen, gfc_expr* expr)
{
@@ -720,7 +752,12 @@ gfc_allocate_allocatable_with_status (st
- /* If mem is NULL, we call gfc_allocate_with_status. */
+ /* If mem is NULL, we call gfc_allocate_using_malloc or
+ gfc_allocate_using_lib. */
gfc_start_block (&alloc_block);
- tmp = gfc_allocate_with_status (&alloc_block, size, status,
- gfc_option.coarray == GFC_FCOARRAY_LIB
- && gfc_expr_attr (expr).codimension);
+
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB
+ && gfc_expr_attr (expr).codimension)
+ tmp = gfc_allocate_using_lib (&alloc_block, size, status,
+ errmsg, errlen);
+ else
+ tmp = gfc_allocate_using_malloc (&alloc_block, size, status);
@@ -749,5 +786,5 @@ gfc_allocate_allocatable_with_status (st
- if (status != NULL_TREE && !integer_zerop (status))
+ if (status != NULL_TREE)
{
- tree status_type = TREE_TYPE (TREE_TYPE (status));
+ tree status_type = TREE_TYPE (status);
stmtblock_t set_status_block;
@@ -760,14 +797,8 @@ gfc_allocate_allocatable_with_status (st
- tmp = gfc_allocate_with_status (&set_status_block, size, status, false);
+ 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,
- fold_build1_loc (input_location, INDIRECT_REF,
- status_type, status),
- build_int_cst (status_type, LIBERROR_ALLOCATION));
-
- tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- status, build_int_cst (status_type, 0));
- error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
- error, gfc_finish_block (&set_status_block));
+ gfc_add_modify (&set_status_block, status,
+ build_int_cst (status_type, LIBERROR_ALLOCATION));
+ error = gfc_finish_block (&set_status_block);
}
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 176528)
+++ gcc/fortran/trans.h (working copy)
@@ -543,7 +543,8 @@ tree gfc_build_memcpy_call (tree, tree,
/* Allocate memory for allocatable variables, with optional status variable. */
-tree gfc_allocate_allocatable_with_status (stmtblock_t*,
- tree, tree, tree, gfc_expr*);
+tree gfc_allocate_allocatable (stmtblock_t*, tree, tree,
+ tree, tree, tree, gfc_expr*);
/* Allocate memory, with optional status variable. */
-tree gfc_allocate_with_status (stmtblock_t *, tree, tree, bool);
+tree gfc_allocate_using_malloc (stmtblock_t *, tree, tree);
+tree gfc_allocate_using_lib (stmtblock_t *, tree, tree, tree, tree);
