void
gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
locus * where, const char * msgid, ...)
{
va_list ap;
stmtblock_t block;
tree body;
tree tmp;
tree tmpvar = NULL;
if (integer_zerop (cond))
return;
if (once)
{
tmpvar = gfc_create_var (boolean_type_node, "print_warning");
TREE_STATIC (tmpvar) = 1;
DECL_INITIAL (tmpvar) = boolean_true_node;
gfc_add_expr_to_block (pblock, tmpvar);
}
gfc_start_block (&block);
/* The code to generate the error. */
va_start (ap, msgid);
gfc_add_expr_to_block (&block,
trans_runtime_error_vararg (error, where,
msgid, ap));
va_end (ap);
if (once)
gfc_add_modify (&block, tmpvar, boolean_false_node);
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. */
if (once)
cond = fold_build2_loc (where->lb->location, TRUTH_AND_EXPR,
long_integer_type_node, tmpvar, cond);
else
cond = fold_convert (long_integer_type_node, cond);
cond = gfc_unlikely (cond);
tmp = fold_build3_loc (where->lb->location, COND_EXPR, void_type_node,
cond, body,
build_empty_stmt (where->lb->location));
gfc_add_expr_to_block (pblock, 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 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);
}
/* 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);
}
