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

trans.c (gfc_allocate_with_status): Split into two functions gfc_allocate_using_malloc and gfc_allocate_usig_lib. 

2011-07-21  Daniel Carrera  <dcarrera@gmail.com>

	* trans.c (gfc_allocate_with_status): Split into two functions
	gfc_allocate_using_malloc and gfc_allocate_usig_lib.
	(gfc_allocate_using_malloc): The status parameter is now the
	actual status rather than a pointer. Code cleanup.
	(gfc_allocate_using_lib): Ditto. Add new parametrs errmsg and
	errlen. Pass these to the coarray lib.
	* trans-openmp.c (gfc_omp_clause_default_ctor): Update calls to
	gfc_allocate_allocatable.
	(gfc_omp_clause_copy_ctor): Ditto.
	(gfc_trans_omp_array_reduction): Ditto.
	* trans-stmt.c (gfc_trans_allocate): Ditto. Update call to
	gfc_allocate_using_malloc. Pass stat rather than pstat to the allocate
	fuctions. If using coarray lib, pass errmsg and errlen to the allocate
	functions. Move error checking outside the if (!gfc_array_allocate)
	block so that it also affects trees produced by gfc_array_allocate.
	* trans-array.c (gfc_array_allocate): Add new parameters errmsg
	and errlen. Replace parameter pstat by status. Code cleanup. Update
	calls to gfc_allocate_allocatable and gfc_allocate_using_malloc.
	* trans-array.h (gfc_array_allocate): Update signature of
	gfc_array_allocate.

From-SVN: r176606
This commit is contained in:
Daniel Carrera 2011-07-21 23:18:24 +00:00 committed by Daniel Carrera
parent ef74e2ba38
commit 8f992d640e
7 changed files with 224 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
gcc/fortran/ChangeLog
View File

@ -1,3 +1,26 @@
2011-07-21 Daniel Carrera <dcarrera@gmail.com>
* trans.c (gfc_allocate_with_status): Split into two functions
gfc_allocate_using_malloc and gfc_allocate_usig_lib.
(gfc_allocate_using_malloc): The status parameter is now the
actual status rather than a pointer. Code cleanup.
(gfc_allocate_using_lib): Ditto. Add new parametrs errmsg and
errlen. Pass these to the coarray lib.
* trans-openmp.c (gfc_omp_clause_default_ctor): Update calls to
gfc_allocate_allocatable.
(gfc_omp_clause_copy_ctor): Ditto.
(gfc_trans_omp_array_reduction): Ditto.
* trans-stmt.c (gfc_trans_allocate): Ditto. Update call to
gfc_allocate_using_malloc. Pass stat rather than pstat to the allocate
fuctions. If using coarray lib, pass errmsg and errlen to the allocate
functions. Move error checking outside the if (!gfc_array_allocate)
block so that it also affects trees produced by gfc_array_allocate.
* trans-array.c (gfc_array_allocate): Add new parameters errmsg
and errlen. Replace parameter pstat by status. Code cleanup. Update
calls to gfc_allocate_allocatable and gfc_allocate_using_malloc.
* trans-array.h (gfc_array_allocate): Update signature of
gfc_array_allocate.
2011-07-21 Steven G. Kargl <kargl@gcc.gnu.org>
* gfortran.texi: Remove a duplicate word.

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

@ -4383,7 +4383,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/*GCC ARRAYS*/
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)
{
tree tmp;
tree pointer;
@ -4478,22 +4479,15 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
1, msg);
}
if (pstat != NULL_TREE && !integer_zerop (pstat))
if (status != NULL_TREE)
{
/* Set the status variable if it's present. */
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);
}
gfc_start_block (&elseblock);
@ -4502,14 +4496,15 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
pointer = gfc_conv_descriptor_data_get (se->expr);
STRIP_NOPS (pointer);
/* 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);
gfc_add_expr_to_block (&elseblock, tmp);

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

@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree, gfc_expr*);
/* Generate code to initialize an 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);
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree);
/* 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 *,

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

@ -188,9 +188,9 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
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_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);
then_b = gfc_finish_block (&cond_block);
@ -241,9 +241,9 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
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_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);
call = build_call_expr_loc (input_location,
built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
@ -663,9 +663,9 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
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_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);
gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false,
false));

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

@ -4686,8 +4686,10 @@ gfc_trans_allocate (gfc_code * code)
tree tmp;
tree parm;
tree stat;
tree pstat;
tree error_label;
tree errmsg;
tree errlen;
tree label_errmsg;
tree label_finish;
tree memsz;
tree expr3;
tree slen3;
@ -4699,21 +4701,39 @@ gfc_trans_allocate (gfc_code * code)
if (!code->ext.alloc.list)
return NULL_TREE;
pstat = stat = error_label = tmp = memsz = NULL_TREE;
stat = tmp = memsz = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
gfc_init_block (&block);
gfc_init_block (&post);
/* Either STAT= and/or ERRMSG is present. */
if (code->expr1 || code->expr2)
/* STAT= (and maybe ERRMSG=) is present. */
if (code->expr1)
{
/* 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= only makes sense with STAT=. */
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);
}
else
{
errmsg = null_pointer_node;
errlen = build_int_cst (gfc_charlen_type_node, 0);
}
/* 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;
}
expr3 = NULL_TREE;
@ -4732,7 +4752,7 @@ gfc_trans_allocate (gfc_code * code)
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
if (!gfc_array_allocate (&se, expr, pstat))
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
{
/* A scalar or derived type. */
@ -4847,28 +4867,16 @@ gfc_trans_allocate (gfc_code * code)
/* Allocate - for non-pointers with re-alloc checking. */
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);
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);
if (code->expr1 || code->expr2)
{
tmp = build1_v (GOTO_EXPR, error_label);
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,
parm, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&se.pre, tmp);
}
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
{
tmp = build_fold_indirect_ref_loc (input_location, se.expr);
@ -4879,6 +4887,25 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_block_to_block (&block, &se.pre);
/* 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);
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,
parm, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
}
if (code->expr3 && !code->expr3->mold)
{
/* Initialization via SOURCE block
@ -5005,16 +5032,11 @@ gfc_trans_allocate (gfc_code * code)
}
/* STAT block. */
/* STAT (ERRMSG only makes sense with STAT). */
if (code->expr1)
{
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);
}
/* ERRMSG block. */
@ -5022,7 +5044,7 @@ gfc_trans_allocate (gfc_code * code)
{
/* A better error message may be possible, but not required. */
const char *msg = "Attempt to allocate an allocated object";
tree errmsg, slen, dlen;
tree slen, dlen;
gfc_init_se (&se, NULL);
gfc_conv_expr_lhs (&se, code->expr2);
@ -5050,6 +5072,22 @@ 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)
{
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);
gfc_add_block_to_block (&block, &post);

188
gcc/fortran/trans.c
View File

@ -565,12 +565,12 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
This function follows the following pseudo-code:
void *
allocate (size_t size, integer_type* stat)
allocate (size_t size, integer_type stat)
{
void *newmem;
if (stat)
*stat = 0;
if (stat requested)
stat = 0;
newmem = malloc (MAX (size, 1));
if (newmem == NULL)
@ -583,12 +583,11 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
return newmem;
} */
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;
/* Evaluate size only once, and make sure it has the right type. */
size = gfc_evaluate_now (size, block);
@ -599,74 +598,37 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status,
res = gfc_create_var (prvoid_type_node, NULL);
/* 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)));
/* The allocation itself. */
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")));
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)),
tmp, build_empty_stmt (input_location));
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));
@ -674,6 +636,61 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status,
}
/* Allocate memory, using an optional status argument.
This function follows the following pseudo-code:
void *
allocate (size_t size, integer_type stat)
{
void *newmem;
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)
{
tree res, 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;
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
allocatable variable. If the variable is currently allocated, it is an
error to allocate it again.
@ -681,7 +698,7 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status,
This function follows the following pseudo-code:
void *
allocate_allocatable (void *mem, size_t size, integer_type *stat)
allocate_allocatable (void *mem, size_t size, integer_type stat)
{
if (mem == NULL)
return allocate (size, stat);
@ -691,7 +708,7 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status,
{
free (mem);
mem = allocate (size, stat);
*stat = LIBERROR_ALLOCATION;
stat = LIBERROR_ALLOCATION;
return mem;
}
else
@ -702,8 +719,8 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status,
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
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)
{
stmtblock_t alloc_block;
tree res, tmp, null_mem, alloc, error;
@ -718,11 +735,16 @@ gfc_allocate_allocatable_with_status (stmtblock_t * block, tree mem, tree size,
boolean_type_node, mem,
build_int_cst (type, 0)));
/* 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);
gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
alloc = gfc_finish_block (&alloc_block);
@ -747,9 +769,9 @@ gfc_allocate_allocatable_with_status (stmtblock_t * block, tree mem, tree size,
"Attempting to allocate already allocated"
" variable");
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;
gfc_start_block (&set_status_block);
@ -758,18 +780,12 @@ gfc_allocate_allocatable_with_status (stmtblock_t * block, tree mem, tree size,
fold_convert (pvoid_type_node, mem));
gfc_add_expr_to_block (&set_status_block, tmp);
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);
}
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,

7
gcc/fortran/trans.h
View File

@ -541,11 +541,12 @@ 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. */
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);
/* Generate code to deallocate an array. */
tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*);