+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.
/*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;
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);
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);
/* 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 *,
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);
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,
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));
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;
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;
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. */
/* 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);
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
}
- /* 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. */
{
/* 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);
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);
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)
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);
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));
}
+/* 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.
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);
{
free (mem);
mem = allocate (size, stat);
- *stat = LIBERROR_ALLOCATION;
+ stat = LIBERROR_ALLOCATION;
return mem;
}
else
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;
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);
"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);
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,
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*);
projects / gcc.git / commitdiff