/* Reallocate MEM so it has SIZE bytes of data. This behaves like the
following pseudo-code:
void *
internal_realloc (void *mem, size_t size)
{
if (size < 0)
runtime_error ("Attempt to allocate a negative amount of memory.");
res = realloc (mem, size);
if (!res && size != 0)
_gfortran_os_error ("Out of memory");
if (size == 0)
return NULL;
return res;
} */
tree
gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
{
tree msg, res, negative, nonzero, zero, null_result, tmp;
tree type = TREE_TYPE (mem);
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 (type, NULL);
/* size < 0 ? */
negative = fold_build2 (LT_EXPR, boolean_type_node, size,
build_int_cst (size_type_node, 0));
msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
("Attempt to allocate a negative amount of memory."));
tmp = fold_build3 (COND_EXPR, void_type_node, negative,
build_call_expr_loc (input_location,
gfor_fndecl_runtime_error, 1, msg),
build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
/* Call realloc and check the result. */
tmp = build_call_expr_loc (input_location,
built_in_decls[BUILT_IN_REALLOC], 2,
fold_convert (pvoid_type_node, mem), size);
gfc_add_modify (block, res, fold_convert (type, tmp));
null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
build_int_cst (pvoid_type_node, 0));
nonzero = fold_build2 (NE_EXPR, boolean_type_node, size,
build_int_cst (size_type_node, 0));
null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
nonzero);
msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
("Out of memory"));
tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
build_call_expr_loc (input_location,
gfor_fndecl_os_error, 1, msg),
build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
/* if (size == 0) then the result is NULL. */
tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
zero = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, nonzero);
tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
return res;
}
void
gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock,
locus * where)
{
stmtblock_t block;
tree body;
tree tmp;
tree args;
char * message;
int line;
if (integer_zerop (cond))
return;
/* The code to generate the error. */
gfc_start_block (&block);
if (where)
{
#ifdef USE_MAPPED_LOCATION
line = LOCATION_LINE (where->lb->location);
#else
line = where->lb->linenum;
#endif
asprintf (&message, "%s (in file '%s', at line %d)", _(msgid),
where->lb->file->filename, line);
}
else
asprintf (&message, "%s (in file '%s', around line %d)", _(msgid),
gfc_source_file, input_line + 1);
tmp = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
gfc_free(message);
args = gfc_chainon_list (NULL_TREE, tmp);
tmp = build_function_call_expr (gfor_fndecl_runtime_error, args);
gfc_add_expr_to_block (&block, tmp);
body = gfc_finish_block (&block);
if (integer_onep (cond))
{
gfc_add_expr_to_block (pblock, body);
}
else
{
/* Tell the compiler that this isn't likely. */
cond = fold_convert (long_integer_type_node, cond);
tmp = gfc_chainon_list (NULL_TREE, cond);
tmp = gfc_chainon_list (tmp, build_int_cst (long_integer_type_node, 0));
cond = build_function_call_expr (built_in_decls[BUILT_IN_EXPECT], tmp);
cond = fold_convert (boolean_type_node, cond);
tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
gfc_add_expr_to_block (pblock, tmp);
}
}
/* Call malloc to allocate size bytes of memory, with special conditions:
+ if size == 0, return a malloced area of size 1,
+ if malloc returns NULL, issue a runtime error. */
tree
gfc_call_malloc (stmtblock_t * block, tree type, tree size)
{
tree tmp, msg, malloc_result, null_result, res, malloc_tree;
stmtblock_t block2;
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);
/* Call malloc. */
gfc_start_block (&block2);
size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
build_int_cst (size_type_node, 1));
malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
gfc_add_modify (&block2, res,
fold_convert (prvoid_type_node,
build_call_expr_loc (input_location,
malloc_tree, 1, size)));
/* Optionally check whether malloc was successful. */
if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
{
null_result = fold_build2_loc (input_location, EQ_EXPR,
boolean_type_node, res,
build_int_cst (pvoid_type_node, 0));
msg = gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const ("Memory allocation failed"));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
null_result,
build_call_expr_loc (input_location,
gfor_fndecl_os_error, 1, msg),
build_empty_stmt (input_location));
gfc_add_expr_to_block (&block2, tmp);
}
malloc_result = gfc_finish_block (&block2);
gfc_add_expr_to_block (block, malloc_result);
if (type != NULL)
res = fold_convert (type, res);
return res;
}
/* 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 = malloc (MAX (size, 1));
if (newmem == NULL)
{
if (stat)
*stat = LIBERROR_ALLOCATION;
else
runtime_error ("Allocation would exceed memory limit");
}
return newmem;
} */
void
gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
tree size, tree status)
{
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. */
size = gfc_evaluate_now (size, block);
if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
size = fold_convert (size_type_node, size);
/* 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_add_modify (block, pointer,
fold_convert (TREE_TYPE (pointer),
build_call_expr_loc (input_location,
builtin_decl_explicit (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
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")));
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,
gfc_unlikely (error_cond), on_error,
build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
}
/* Reallocate MEM so it has SIZE bytes of data. This behaves like the
following pseudo-code:
void *
internal_realloc (void *mem, size_t size)
{
res = realloc (mem, size);
if (!res && size != 0)
_gfortran_os_error ("Allocation would exceed memory limit");
if (size == 0)
return NULL;
return res;
} */
tree
gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
{
tree msg, res, nonzero, zero, null_result, tmp;
tree type = TREE_TYPE (mem);
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 (type, NULL);
/* Call realloc and check the result. */
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_REALLOC), 2,
fold_convert (pvoid_type_node, mem), size);
gfc_add_modify (block, res, fold_convert (type, tmp));
null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
res, build_int_cst (pvoid_type_node, 0));
nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size,
build_int_cst (size_type_node, 0));
null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
null_result, nonzero);
msg = 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,
null_result,
build_call_expr_loc (input_location,
gfor_fndecl_os_error, 1, msg),
build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
/* if (size == 0) then the result is NULL. */
tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, res,
build_int_cst (type, 0));
zero = fold_build1_loc (input_location, TRUTH_NOT_EXPR, boolean_type_node,
nonzero);
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, zero, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
return res;
}
tree
gfc_build_array_ref (tree base, tree offset, tree decl)
{
tree type = TREE_TYPE (base);
tree tmp;
gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
type = TREE_TYPE (type);
if (DECL_P (base))
TREE_ADDRESSABLE (base) = 1;
/* Strip NON_LVALUE_EXPR nodes. */
STRIP_TYPE_NOPS (offset);
/* If the array reference is to a pointer, whose target contains a
subreference, use the span that is stored with the backend decl
and reference the element with pointer arithmetic. */
if (decl && (TREE_CODE (decl) == FIELD_DECL
|| TREE_CODE (decl) == VAR_DECL
|| TREE_CODE (decl) == PARM_DECL)
&& GFC_DECL_SUBREF_ARRAY_P (decl)
&& !integer_zerop (GFC_DECL_SPAN(decl)))
{
offset = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
offset, GFC_DECL_SPAN(decl));
tmp = gfc_build_addr_expr (pvoid_type_node, base);
tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR,
pvoid_type_node, tmp,
fold_convert (sizetype, offset));
tmp = fold_convert (build_pointer_type (type), tmp);
if (!TYPE_STRING_FLAG (type))
tmp = build_fold_indirect_ref_loc (input_location, tmp);
return tmp;
}
else
/* Otherwise use a straightforward array reference. */
return build4_loc (input_location, ARRAY_REF, type, base, offset,
NULL_TREE, NULL_TREE);
}
/* Allocate memory, using an optional status argument.
This function follows the following pseudo-code:
void *
allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
{
void *newmem;
newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
return newmem;
} */
static void
gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
tree token, tree status, tree errmsg, tree errlen)
{
tree tmp, pstat;
gcc_assert (token != 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);
/* 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);
}
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,
GFC_CAF_COARRAY_ALLOC),
token, pstat, errmsg, errlen);
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);
}
/* 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)
*stat = 0;
// The only time this can happen is the size wraps around.
if (size < 0)
{
if (stat)
{
*stat = LIBERROR_ALLOCATION;
newmem = NULL;
}
else
runtime_error ("Attempt to allocate negative amount of memory. "
"Possible integer overflow");
}
else
{
newmem = malloc (MAX (size, 1));
if (newmem == NULL)
{
if (stat)
*stat = LIBERROR_ALLOCATION;
else
runtime_error ("Out of memory");
}
}
return newmem;
} */
tree
gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
{
stmtblock_t alloc_block;
tree res, tmp, error, msg, cond;
tree status_type = status ? TREE_TYPE (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 && !integer_zerop (status))
{
tmp = fold_build2 (MODIFY_EXPR, status_type,
fold_build1 (INDIRECT_REF, status_type, status),
build_int_cst (status_type, 0));
tmp = fold_build3 (COND_EXPR, void_type_node,
fold_build2 (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);
}
/* Generate the block of code handling (size < 0). */
msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
("Attempt to allocate negative amount of memory. "
"Possible integer overflow"));
error = build_call_expr_loc (input_location,
gfor_fndecl_runtime_error, 1, msg);
if (status != NULL_TREE && !integer_zerop (status))
{
/* Set the status variable if it's present. */
stmtblock_t set_status_block;
gfc_start_block (&set_status_block);
gfc_add_modify (&set_status_block,
fold_build1 (INDIRECT_REF, status_type, status),
build_int_cst (status_type, LIBERROR_ALLOCATION));
gfc_add_modify (&set_status_block, res,
build_int_cst (prvoid_type_node, 0));
tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
build_int_cst (TREE_TYPE (status), 0));
error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
gfc_finish_block (&set_status_block));
}
/* The allocation itself. */
gfc_start_block (&alloc_block);
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 (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
("Out of memory"));
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 (EQ_EXPR, boolean_type_node, status,
build_int_cst (TREE_TYPE (status), 0));
tmp2 = fold_build2 (MODIFY_EXPR, status_type,
fold_build1 (INDIRECT_REF, status_type, status),
build_int_cst (status_type, LIBERROR_ALLOCATION));
tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
tmp2);
}
tmp = fold_build3 (COND_EXPR, void_type_node,
fold_build2 (EQ_EXPR, boolean_type_node, res,
build_int_cst (prvoid_type_node, 0)),
tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&alloc_block, tmp);
cond = fold_build2 (LT_EXPR, boolean_type_node, size,
build_int_cst (TREE_TYPE (size), 0));
tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,
gfc_finish_block (&alloc_block));
gfc_add_expr_to_block (block, tmp);
return res;
}
/* User-deallocate; we emit the code directly from the front-end, and the
logic is the same as the previous library function:
void
deallocate (void *pointer, GFC_INTEGER_4 * stat)
{
if (!pointer)
{
if (stat)
*stat = 1;
else
runtime_error ("Attempt to DEALLOCATE unallocated memory.");
}
else
{
free (pointer);
if (stat)
*stat = 0;
}
}
In this front-end version, status doesn't have to be GFC_INTEGER_4.
Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
even when no status variable is passed to us (this is used for
unconditional deallocation generated by the front-end at end of
each procedure).
If a runtime-message is possible, `expr' must point to the original
expression being deallocated for its locus and variable name.
For coarrays, "pointer" must be the array descriptor and not its
"data" component. */
tree
gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
tree errlen, tree label_finish,
bool can_fail, gfc_expr* expr, bool coarray)
{
stmtblock_t null, non_null;
tree cond, tmp, error;
tree status_type = NULL_TREE;
tree caf_decl = NULL_TREE;
if (coarray)
{
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)));
caf_decl = pointer;
pointer = gfc_conv_descriptor_data_get (caf_decl);
STRIP_NOPS (pointer);
}
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
build_int_cst (TREE_TYPE (pointer), 0));
/* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
we emit a runtime error. */
gfc_start_block (&null);
if (!can_fail)
{
tree varname;
gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
varname = gfc_build_cstring_const (expr->symtree->name);
varname = gfc_build_addr_expr (pchar_type_node, varname);
error = gfc_trans_runtime_error (true, &expr->where,
"Attempt to DEALLOCATE unallocated '%s'",
varname);
}
else
error = build_empty_stmt (input_location);
if (status != NULL_TREE && !integer_zerop (status))
{
tree cond2;
status_type = TREE_TYPE (TREE_TYPE (status));
cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
status, build_int_cst (TREE_TYPE (status), 0));
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, 1));
error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
cond2, tmp, error);
}
gfc_add_expr_to_block (&null, error);
/* When POINTER is not NULL, we free it. */
gfc_start_block (&non_null);
if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB)
{
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_FREE), 1,
fold_convert (pvoid_type_node, pointer));
gfc_add_expr_to_block (&non_null, tmp);
if (status != NULL_TREE && !integer_zerop (status))
{
/* We set STATUS to zero if it is present. */
tree status_type = TREE_TYPE (TREE_TYPE (status));
tree cond2;
cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
status,
build_int_cst (TREE_TYPE (status), 0));
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,
gfc_unlikely (cond2), tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&non_null, tmp);
}
}
else
{
tree caf_type, token, cond2;
tree pstat = null_pointer_node;
if (errmsg == NULL_TREE)
{
gcc_assert (errlen == NULL_TREE);
errmsg = null_pointer_node;
errlen = build_zero_cst (integer_type_node);
}
else
{
gcc_assert (errlen != NULL_TREE);
if (!POINTER_TYPE_P (TREE_TYPE (errmsg)))
errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
}
caf_type = TREE_TYPE (caf_decl);
if (status != NULL_TREE && !integer_zerop (status))
{
gcc_assert (status_type == integer_type_node);
pstat = status;
}
if (GFC_DESCRIPTOR_TYPE_P (caf_type)
&& GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
token = gfc_conv_descriptor_token (caf_decl);
else if (DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
token = GFC_DECL_TOKEN (caf_decl);
else
{
gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
&& GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
}
token = gfc_build_addr_expr (NULL_TREE, token);
tmp = build_call_expr_loc (input_location,
gfor_fndecl_caf_deregister, 4,
token, pstat, errmsg, errlen);
gfc_add_expr_to_block (&non_null, tmp);
if (status != NULL_TREE)
{
tree stat = build_fold_indirect_ref_loc (input_location, status);
TREE_USED (label_finish) = 1;
tmp = build1_v (GOTO_EXPR, label_finish);
cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
stat, build_zero_cst (TREE_TYPE (stat)));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
gfc_unlikely (cond2), tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&non_null, tmp);
}
}
return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
gfc_finish_block (&null),
gfc_finish_block (&non_null));
}
/* 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)
{
if (mem == NULL)
return allocate (size, stat);
else
{
if (stat)
stat = LIBERROR_ALLOCATION;
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. */
void
gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
tree status, tree errmsg, tree errlen, tree label_finish,
gfc_expr* expr)
{
stmtblock_t alloc_block;
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);
null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, mem,
build_int_cst (type, 0)));
/* If mem is NULL, we call gfc_allocate_using_malloc or
gfc_allocate_using_lib. */
gfc_start_block (&alloc_block);
if (gfc_option.coarray == GFC_FCOARRAY_LIB
&& gfc_expr_attr (expr).codimension)
{
tree cond;
gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
errmsg, errlen);
if (status != NULL_TREE)
{
TREE_USED (label_finish) = 1;
tmp = build1_v (GOTO_EXPR, label_finish);
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
status, build_zero_cst (TREE_TYPE (status)));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
gfc_unlikely (cond), tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&alloc_block, tmp);
}
}
else
gfc_allocate_using_malloc (&alloc_block, mem, size, status);
alloc = gfc_finish_block (&alloc_block);
/* If mem is not NULL, we issue a runtime error or set the
status variable. */
if (expr)
{
tree varname;
gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
varname = gfc_build_cstring_const (expr->symtree->name);
varname = gfc_build_addr_expr (pchar_type_node, varname);
error = gfc_trans_runtime_error (true, &expr->where,
"Attempting to allocate already"
" allocated variable '%s'",
varname);
}
else
error = gfc_trans_runtime_error (true, NULL,
"Attempting to allocate already allocated"
" variable");
if (status != NULL_TREE)
{
tree status_type = TREE_TYPE (status);
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);
}
/* 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)
*stat = 0;
newmem = malloc (MAX (size, 1));
if (newmem == NULL)
{
if (stat)
*stat = LIBERROR_ALLOCATION;
else
runtime_error ("Allocation would exceed memory limit");
}
return newmem;
} */
tree
gfc_allocate_with_status (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;
/* 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 && !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);
}
/* The allocation itself. */
gfc_start_block (&alloc_block);
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);
}
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));
gfc_add_expr_to_block (&alloc_block, tmp);
gfc_add_expr_to_block (block, gfc_finish_block (&alloc_block));
return res;
}
tree
gfc_build_array_ref (tree base, tree offset, tree decl)
{
tree type = TREE_TYPE (base);
tree tmp;
tree span;
if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
{
gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
return fold_convert (TYPE_MAIN_VARIANT (type), base);
}
/* Scalar coarray, there is nothing to do. */
if (TREE_CODE (type) != ARRAY_TYPE)
{
gcc_assert (decl == NULL_TREE);
gcc_assert (integer_zerop (offset));
return base;
}
type = TREE_TYPE (type);
if (DECL_P (base))
TREE_ADDRESSABLE (base) = 1;
/* Strip NON_LVALUE_EXPR nodes. */
STRIP_TYPE_NOPS (offset);
/* If the array reference is to a pointer, whose target contains a
subreference, use the span that is stored with the backend decl
and reference the element with pointer arithmetic. */
if (decl && (TREE_CODE (decl) == FIELD_DECL
|| TREE_CODE (decl) == VAR_DECL
|| TREE_CODE (decl) == PARM_DECL)
&& ((GFC_DECL_SUBREF_ARRAY_P (decl)
&& !integer_zerop (GFC_DECL_SPAN(decl)))
|| GFC_DECL_CLASS (decl)))
{
if (GFC_DECL_CLASS (decl))
{
/* Allow for dummy arguments and other good things. */
if (POINTER_TYPE_P (TREE_TYPE (decl)))
decl = build_fold_indirect_ref_loc (input_location, decl);
/* Check if '_data' is an array descriptor. If it is not,
the array must be one of the components of the class object,
so return a normal array reference. */
if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl))))
return build4_loc (input_location, ARRAY_REF, type, base,
offset, NULL_TREE, NULL_TREE);
span = gfc_vtable_size_get (decl);
}
else if (GFC_DECL_SUBREF_ARRAY_P (decl))
span = GFC_DECL_SPAN(decl);
else
gcc_unreachable ();
offset = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
offset, span);
tmp = gfc_build_addr_expr (pvoid_type_node, base);
tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
tmp = fold_convert (build_pointer_type (type), tmp);
if (!TYPE_STRING_FLAG (type))
tmp = build_fold_indirect_ref_loc (input_location, tmp);
return tmp;
}
else
/* Otherwise use a straightforward array reference. */
return build4_loc (input_location, ARRAY_REF, type, base, offset,
NULL_TREE, NULL_TREE);
}
static tree
trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
va_list ap)
{
stmtblock_t block;
tree tmp;
tree arg, arg2;
tree *argarray;
tree fntype;
char *message;
const char *p;
int line, nargs, i;
location_t loc;
/* Compute the number of extra arguments from the format string. */
for (p = msgid, nargs = 0; *p; p++)
if (*p == '%')
{
p++;
if (*p != '%')
nargs++;
}
/* The code to generate the error. */
gfc_start_block (&block);
if (where)
{
line = LOCATION_LINE (where->lb->location);
asprintf (&message, "At line %d of file %s", line,
where->lb->file->filename);
}
else
asprintf (&message, "In file '%s', around line %d",
gfc_source_file, input_line + 1);
arg = gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (message));
free (message);
asprintf (&message, "%s", _(msgid));
arg2 = gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (message));
free (message);
/* Build the argument array. */
argarray = XALLOCAVEC (tree, nargs + 2);
argarray[0] = arg;
argarray[1] = arg2;
for (i = 0; i < nargs; i++)
argarray[2 + i] = va_arg (ap, tree);
/* Build the function call to runtime_(warning,error)_at; because of the
variable number of arguments, we can't use build_call_expr_loc dinput_location,
irectly. */
if (error)
fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
else
fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
loc = where ? where->lb->location : input_location;
tmp = fold_builtin_call_array (loc, TREE_TYPE (fntype),
fold_build1_loc (loc, ADDR_EXPR,
build_pointer_type (fntype),
error
? gfor_fndecl_runtime_error_at
: gfor_fndecl_runtime_warning_at),
nargs + 2, argarray);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
/* User-deallocate; we emit the code directly from the front-end, and the
logic is the same as the previous library function:
void
deallocate (void *pointer, GFC_INTEGER_4 * stat)
{
if (!pointer)
{
if (stat)
*stat = 1;
else
runtime_error ("Attempt to DEALLOCATE unallocated memory.");
}
else
{
free (pointer);
if (stat)
*stat = 0;
}
}
In this front-end version, status doesn't have to be GFC_INTEGER_4.
Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
even when no status variable is passed to us (this is used for
unconditional deallocation generated by the front-end at end of
each procedure).
If a runtime-message is possible, `expr' must point to the original
expression being deallocated for its locus and variable name. */
tree
gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
gfc_expr* expr)
{
stmtblock_t null, non_null;
tree cond, tmp, error;
cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
build_int_cst (TREE_TYPE (pointer), 0));
/* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
we emit a runtime error. */
gfc_start_block (&null);
if (!can_fail)
{
tree varname;
gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
varname = gfc_build_cstring_const (expr->symtree->name);
varname = gfc_build_addr_expr (pchar_type_node, varname);
error = gfc_trans_runtime_error (true, &expr->where,
"Attempt to DEALLOCATE unallocated '%s'",
varname);
}
else
error = build_empty_stmt (input_location);
if (status != NULL_TREE && !integer_zerop (status))
{
tree status_type = TREE_TYPE (TREE_TYPE (status));
tree cond2;
cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
build_int_cst (TREE_TYPE (status), 0));
tmp = fold_build2 (MODIFY_EXPR, status_type,
fold_build1 (INDIRECT_REF, status_type, status),
build_int_cst (status_type, 1));
error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
}
gfc_add_expr_to_block (&null, error);
/* When POINTER is not NULL, we free it. */
gfc_start_block (&non_null);
tmp = build_call_expr_loc (input_location,
built_in_decls[BUILT_IN_FREE], 1,
fold_convert (pvoid_type_node, pointer));
gfc_add_expr_to_block (&non_null, tmp);
if (status != NULL_TREE && !integer_zerop (status))
{
/* We set STATUS to zero if it is present. */
tree status_type = TREE_TYPE (TREE_TYPE (status));
tree cond2;
cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
build_int_cst (TREE_TYPE (status), 0));
tmp = fold_build2 (MODIFY_EXPR, status_type,
fold_build1 (INDIRECT_REF, status_type, status),
build_int_cst (status_type, 0));
tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&non_null, tmp);
}
return fold_build3 (COND_EXPR, void_type_node, cond,
gfc_finish_block (&null), gfc_finish_block (&non_null));
}
tree
gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
gfc_expr* expr, gfc_typespec ts)
{
stmtblock_t null, non_null;
tree cond, tmp, error;
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
build_int_cst (TREE_TYPE (pointer), 0));
/* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
we emit a runtime error. */
gfc_start_block (&null);
if (!can_fail)
{
tree varname;
gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
varname = gfc_build_cstring_const (expr->symtree->name);
varname = gfc_build_addr_expr (pchar_type_node, varname);
error = gfc_trans_runtime_error (true, &expr->where,
"Attempt to DEALLOCATE unallocated '%s'",
varname);
}
else
error = build_empty_stmt (input_location);
if (status != NULL_TREE && !integer_zerop (status))
{
tree status_type = TREE_TYPE (TREE_TYPE (status));
tree cond2;
cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
status, build_int_cst (TREE_TYPE (status), 0));
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, 1));
error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
cond2, tmp, error);
}
gfc_add_expr_to_block (&null, error);
/* When POINTER is not NULL, we free it. */
gfc_start_block (&non_null);
/* Free allocatable components. */
if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
{
tmp = build_fold_indirect_ref_loc (input_location, pointer);
tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
gfc_add_expr_to_block (&non_null, tmp);
}
else if (ts.type == BT_CLASS
&& ts.u.derived->components->ts.u.derived->attr.alloc_comp)
{
tmp = build_fold_indirect_ref_loc (input_location, pointer);
tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived,
tmp, 0);
gfc_add_expr_to_block (&non_null, tmp);
}
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_FREE), 1,
fold_convert (pvoid_type_node, pointer));
gfc_add_expr_to_block (&non_null, tmp);
if (status != NULL_TREE && !integer_zerop (status))
{
/* We set STATUS to zero if it is present. */
tree status_type = TREE_TYPE (TREE_TYPE (status));
tree cond2;
cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
status, build_int_cst (TREE_TYPE (status), 0));
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, cond2,
tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&non_null, tmp);
}
return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
gfc_finish_block (&null),
gfc_finish_block (&non_null));
}
static tree
gfc_trans_omp_atomic (gfc_code *code)
{
gfc_se lse;
gfc_se rse;
gfc_expr *expr2, *e;
gfc_symbol *var;
stmtblock_t block;
tree lhsaddr, type, rhs, x;
enum tree_code op = ERROR_MARK;
bool var_on_left = false;
code = code->block->next;
gcc_assert (code->op == EXEC_ASSIGN);
gcc_assert (code->next == NULL);
var = code->expr->symtree->n.sym;
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
gfc_start_block (&block);
gfc_conv_expr (&lse, code->expr);
gfc_add_block_to_block (&block, &lse.pre);
type = TREE_TYPE (lse.expr);
lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
expr2 = code->expr2;
if (expr2->expr_type == EXPR_FUNCTION
&& expr2->value.function.isym->generic_id == GFC_ISYM_CONVERSION)
expr2 = expr2->value.function.actual->expr;
if (expr2->expr_type == EXPR_OP)
{
gfc_expr *e;
switch (expr2->value.op.operator)
{
case INTRINSIC_PLUS:
op = PLUS_EXPR;
break;
case INTRINSIC_TIMES:
op = MULT_EXPR;
break;
case INTRINSIC_MINUS:
op = MINUS_EXPR;
break;
case INTRINSIC_DIVIDE:
if (expr2->ts.type == BT_INTEGER)
op = TRUNC_DIV_EXPR;
else
op = RDIV_EXPR;
break;
case INTRINSIC_AND:
op = TRUTH_ANDIF_EXPR;
break;
case INTRINSIC_OR:
op = TRUTH_ORIF_EXPR;
break;
case INTRINSIC_EQV:
op = EQ_EXPR;
break;
case INTRINSIC_NEQV:
op = NE_EXPR;
break;
default:
gcc_unreachable ();
}
e = expr2->value.op.op1;
if (e->expr_type == EXPR_FUNCTION
&& e->value.function.isym->generic_id == GFC_ISYM_CONVERSION)
e = e->value.function.actual->expr;
if (e->expr_type == EXPR_VARIABLE
&& e->symtree != NULL
&& e->symtree->n.sym == var)
{
expr2 = expr2->value.op.op2;
var_on_left = true;
}
else
{
e = expr2->value.op.op2;
if (e->expr_type == EXPR_FUNCTION
&& e->value.function.isym->generic_id == GFC_ISYM_CONVERSION)
e = e->value.function.actual->expr;
gcc_assert (e->expr_type == EXPR_VARIABLE
&& e->symtree != NULL
&& e->symtree->n.sym == var);
expr2 = expr2->value.op.op1;
var_on_left = false;
}
gfc_conv_expr (&rse, expr2);
gfc_add_block_to_block (&block, &rse.pre);
}
else
{
gcc_assert (expr2->expr_type == EXPR_FUNCTION);
switch (expr2->value.function.isym->generic_id)
{
case GFC_ISYM_MIN:
op = MIN_EXPR;
break;
case GFC_ISYM_MAX:
op = MAX_EXPR;
break;
case GFC_ISYM_IAND:
op = BIT_AND_EXPR;
break;
case GFC_ISYM_IOR:
op = BIT_IOR_EXPR;
break;
case GFC_ISYM_IEOR:
op = BIT_XOR_EXPR;
break;
default:
gcc_unreachable ();
}
e = expr2->value.function.actual->expr;
gcc_assert (e->expr_type == EXPR_VARIABLE
&& e->symtree != NULL
&& e->symtree->n.sym == var);
gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
gfc_add_block_to_block (&block, &rse.pre);
if (expr2->value.function.actual->next->next != NULL)
{
tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
gfc_actual_arglist *arg;
gfc_add_modify_expr (&block, accum, rse.expr);
for (arg = expr2->value.function.actual->next->next; arg;
arg = arg->next)
{
gfc_init_block (&rse.pre);
gfc_conv_expr (&rse, arg->expr);
gfc_add_block_to_block (&block, &rse.pre);
x = fold_build2 (op, TREE_TYPE (accum), accum, rse.expr);
gfc_add_modify_expr (&block, accum, x);
}
rse.expr = accum;
}
expr2 = expr2->value.function.actual->next->expr;
}
lhsaddr = save_expr (lhsaddr);
rhs = gfc_evaluate_now (rse.expr, &block);
x = convert (TREE_TYPE (rhs), build_fold_indirect_ref (lhsaddr));
if (var_on_left)
x = fold_build2 (op, TREE_TYPE (rhs), x, rhs);
else
x = fold_build2 (op, TREE_TYPE (rhs), rhs, x);
if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
&& TREE_CODE (type) != COMPLEX_TYPE)
x = build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (rhs)), x);
x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
gfc_add_expr_to_block (&block, x);
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
return gfc_finish_block (&block);
}
static tree
gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
bool fini_coarray, gfc_expr *class_size)
{
stmtblock_t block;
gfc_se se;
tree final_fndecl, array, size, tmp;
symbol_attribute attr;
gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
gcc_assert (var);
gfc_start_block (&block);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, final_wrapper);
final_fndecl = se.expr;
if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
if (ts.type == BT_DERIVED)
{
tree elem_size;
gcc_assert (!class_size);
elem_size = gfc_typenode_for_spec (&ts);
elem_size = TYPE_SIZE_UNIT (elem_size);
size = fold_convert (gfc_array_index_type, elem_size);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
if (var->rank)
{
se.descriptor_only = 1;
gfc_conv_expr_descriptor (&se, var);
array = se.expr;
}
else
{
gfc_conv_expr (&se, var);
gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
array = se.expr;
/* No copy back needed, hence set attr's allocatable/pointer
to zero. */
gfc_clear_attr (&attr);
gfc_init_se (&se, NULL);
array = gfc_conv_scalar_to_descriptor (&se, array, attr);
gcc_assert (se.post.head == NULL_TREE);
}
}
else
{
gfc_expr *array_expr;
gcc_assert (class_size);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, class_size);
gfc_add_block_to_block (&block, &se.pre);
gcc_assert (se.post.head == NULL_TREE);
size = se.expr;
array_expr = gfc_copy_expr (var);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
if (array_expr->rank)
{
gfc_add_class_array_ref (array_expr);
se.descriptor_only = 1;
gfc_conv_expr_descriptor (&se, array_expr);
array = se.expr;
}
else
{
gfc_add_data_component (array_expr);
gfc_conv_expr (&se, array_expr);
gfc_add_block_to_block (&block, &se.pre);
gcc_assert (se.post.head == NULL_TREE);
array = se.expr;
if (TREE_CODE (array) == ADDR_EXPR
&& POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
tmp = TREE_OPERAND (array, 0);
if (!gfc_is_coarray (array_expr))
{
/* No copy back needed, hence set attr's allocatable/pointer
to zero. */
gfc_clear_attr (&attr);
gfc_init_se (&se, NULL);
array = gfc_conv_scalar_to_descriptor (&se, array, attr);
}
gcc_assert (se.post.head == NULL_TREE);
}
gfc_free_expr (array_expr);
}
if (!POINTER_TYPE_P (TREE_TYPE (array)))
array = gfc_build_addr_expr (NULL, array);
gfc_add_block_to_block (&block, &se.pre);
tmp = build_call_expr_loc (input_location,
final_fndecl, 3, array,
size, fini_coarray ? boolean_true_node
: boolean_false_node);
gfc_add_block_to_block (&block, &se.post);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
/* Generate code for an ALLOCATE statement when the argument is an
allocatable array. If the array is currently allocated, it is an
error to allocate it again.
This function follows the following pseudo-code:
void *
allocate_array (void *mem, size_t size, integer_type *stat)
{
if (mem == NULL)
return allocate (size, stat);
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
gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
tree status, gfc_expr* expr)
{
stmtblock_t alloc_block;
tree res, 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 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, mem,
build_int_cst (type, 0));
/* If mem is NULL, we call gfc_allocate_with_status. */
gfc_start_block (&alloc_block);
tmp = gfc_allocate_with_status (&alloc_block, size, status);
gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
alloc = gfc_finish_block (&alloc_block);
/* Otherwise, we issue a runtime error or set the status variable. */
if (expr)
{
tree varname;
gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
varname = gfc_build_cstring_const (expr->symtree->name);
varname = gfc_build_addr_expr (pchar_type_node, varname);
error = gfc_trans_runtime_error (true, &expr->where,
"Attempting to allocate already"
" allocated variable '%s'",
varname);
}
else
error = gfc_trans_runtime_error (true, NULL,
"Attempting to allocate already allocated"
" variable");
if (status != NULL_TREE && !integer_zerop (status))
{
tree status_type = TREE_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_with_status (&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));
}
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
alloc, error);
gfc_add_expr_to_block (block, tmp);
return res;
}
