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));
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);
tmp = build_int_cst (long_integer_type_node, 0);
cond = build_call_expr_loc (where->lb->location,
built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
cond = fold_convert (boolean_type_node, 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);
}
}
/* 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;
}
/* 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);
}
static tree
cp_ubsan_instrument_vptr (location_t loc, tree op, tree type, bool is_addr,
enum ubsan_null_ckind ckind)
{
type = TYPE_MAIN_VARIANT (type);
const char *mangled = mangle_type_string (type);
hashval_t str_hash1 = htab_hash_string (mangled);
hashval_t str_hash2 = iterative_hash (mangled, strlen (mangled), 0);
tree str_hash = wide_int_to_tree (uint64_type_node,
wi::uhwi (((uint64_t) str_hash1 << 32)
| str_hash2, 64));
if (!is_addr)
op = build_fold_addr_expr_loc (loc, op);
op = save_expr (op);
tree vptr = fold_build3_loc (loc, COMPONENT_REF,
TREE_TYPE (TYPE_VFIELD (type)),
build_fold_indirect_ref_loc (loc, op),
TYPE_VFIELD (type), NULL_TREE);
vptr = fold_convert_loc (loc, pointer_sized_int_node, vptr);
vptr = fold_convert_loc (loc, uint64_type_node, vptr);
if (ckind == UBSAN_DOWNCAST_POINTER)
{
tree cond = build2_loc (loc, NE_EXPR, boolean_type_node, op,
build_zero_cst (TREE_TYPE (op)));
/* This is a compiler generated comparison, don't emit
e.g. -Wnonnull-compare warning for it. */
TREE_NO_WARNING (cond) = 1;
vptr = build3_loc (loc, COND_EXPR, uint64_type_node, cond,
vptr, build_int_cst (uint64_type_node, 0));
}
tree ti_decl = get_tinfo_decl (type);
mark_used (ti_decl);
tree ptype = build_pointer_type (type);
tree call
= build_call_expr_internal_loc (loc, IFN_UBSAN_VPTR,
void_type_node, 5, op, vptr, str_hash,
build_address (ti_decl),
build_int_cst (ptype, ckind));
TREE_SIDE_EFFECTS (call) = 1;
return fold_build2 (COMPOUND_EXPR, TREE_TYPE (op), call, op);
}
/* Free a given variable, if it's not NULL. */
tree
gfc_call_free (tree var)
{
stmtblock_t block;
tree tmp, cond, call;
if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
var = fold_convert (pvoid_type_node, var);
gfc_start_block (&block);
var = gfc_evaluate_now (var, &block);
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, var,
build_int_cst (pvoid_type_node, 0));
call = build_call_expr_loc (input_location,
built_in_decls[BUILT_IN_FREE], 1, var);
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, call,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
static void
create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
{
segment_info *s, *next_s;
tree union_type;
tree *field_link;
tree field;
tree field_init = NULL_TREE;
record_layout_info rli;
tree decl;
bool is_init = false;
bool is_saved = false;
/* Declare the variables inside the common block.
If the current common block contains any equivalence object, then
make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
alias analyzer work well when there is no address overlapping for
common variables in the current common block. */
if (saw_equiv)
union_type = make_node (UNION_TYPE);
else
union_type = make_node (RECORD_TYPE);
rli = start_record_layout (union_type);
field_link = &TYPE_FIELDS (union_type);
/* Check for overlapping initializers and replace them with a single,
artificial field that contains all the data. */
if (saw_equiv)
field = get_init_field (head, union_type, &field_init, rli);
else
field = NULL_TREE;
if (field != NULL_TREE)
{
is_init = true;
*field_link = field;
field_link = &DECL_CHAIN (field);
}
for (s = head; s; s = s->next)
{
build_field (s, union_type, rli);
/* Link the field into the type. */
*field_link = s->field;
field_link = &DECL_CHAIN (s->field);
/* Has initial value. */
if (s->sym->value)
is_init = true;
/* Has SAVE attribute. */
if (s->sym->attr.save)
is_saved = true;
}
finish_record_layout (rli, true);
if (com)
decl = build_common_decl (com, union_type, is_init);
else
decl = build_equiv_decl (union_type, is_init, is_saved);
if (is_init)
{
tree ctor, tmp;
VEC(constructor_elt,gc) *v = NULL;
if (field != NULL_TREE && field_init != NULL_TREE)
CONSTRUCTOR_APPEND_ELT (v, field, field_init);
else
for (s = head; s; s = s->next)
{
if (s->sym->value)
{
/* Add the initializer for this field. */
tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
TREE_TYPE (s->field),
s->sym->attr.dimension,
s->sym->attr.pointer
|| s->sym->attr.allocatable, false);
CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
}
}
gcc_assert (!VEC_empty (constructor_elt, v));
ctor = build_constructor (union_type, v);
TREE_CONSTANT (ctor) = 1;
TREE_STATIC (ctor) = 1;
DECL_INITIAL (decl) = ctor;
#ifdef ENABLE_CHECKING
{
tree field, value;
unsigned HOST_WIDE_INT idx;
FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
gcc_assert (TREE_CODE (field) == FIELD_DECL);
}
#endif
}
/* Build component reference for each variable. */
for (s = head; s; s = next_s)
{
tree var_decl;
var_decl = build_decl (s->sym->declared_at.lb->location,
VAR_DECL, DECL_NAME (s->field),
TREE_TYPE (s->field));
TREE_STATIC (var_decl) = TREE_STATIC (decl);
/* Mark the variable as used in order to avoid warnings about
unused variables. */
TREE_USED (var_decl) = 1;
if (s->sym->attr.use_assoc)
DECL_IGNORED_P (var_decl) = 1;
if (s->sym->attr.target)
TREE_ADDRESSABLE (var_decl) = 1;
/* Fake variables are not visible from other translation units. */
TREE_PUBLIC (var_decl) = 0;
/* To preserve identifier names in COMMON, chain to procedure
scope unless at top level in a module definition. */
if (com
&& s->sym->ns->proc_name
&& s->sym->ns->proc_name->attr.flavor == FL_MODULE)
var_decl = pushdecl_top_level (var_decl);
else
gfc_add_decl_to_function (var_decl);
SET_DECL_VALUE_EXPR (var_decl,
fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (s->field),
decl, s->field, NULL_TREE));
DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
if (s->sym->attr.assign)
{
gfc_allocate_lang_decl (var_decl);
GFC_DECL_ASSIGN (var_decl) = 1;
GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field);
GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field);
}
s->sym->backend_decl = var_decl;
next_s = s->next;
free (s);
}
}
/* 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);
}
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));
}
bool
gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
{
tree tmp;
gfc_ref *ref;
gfc_expr *expr;
gfc_expr *final_expr = NULL;
gfc_expr *elem_size = NULL;
bool has_finalizer = false;
if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
return false;
if (expr2->ts.type == BT_DERIVED)
{
gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
if (!final_expr)
return false;
}
/* If we have a class array, we need go back to the class
container. */
expr = gfc_copy_expr (expr2);
if (expr->ref && expr->ref->next && !expr->ref->next->next
&& expr->ref->next->type == REF_ARRAY
&& expr->ref->type == REF_COMPONENT
&& strcmp (expr->ref->u.c.component->name, "_data") == 0)
{
gfc_free_ref_list (expr->ref);
expr->ref = NULL;
}
else
for (ref = expr->ref; ref; ref = ref->next)
if (ref->next && ref->next->next && !ref->next->next->next
&& ref->next->next->type == REF_ARRAY
&& ref->next->type == REF_COMPONENT
&& strcmp (ref->next->u.c.component->name, "_data") == 0)
{
gfc_free_ref_list (ref->next);
ref->next = NULL;
}
if (expr->ts.type == BT_CLASS)
{
has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL);
if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as)
expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;
final_expr = gfc_copy_expr (expr);
gfc_add_vptr_component (final_expr);
gfc_add_component_ref (final_expr, "_final");
elem_size = gfc_copy_expr (expr);
gfc_add_vptr_component (elem_size);
gfc_add_component_ref (elem_size, "_size");
}
gcc_assert (final_expr->expr_type == EXPR_VARIABLE);
tmp = gfc_build_final_call (expr->ts, final_expr, expr,
false, elem_size);
if (expr->ts.type == BT_CLASS && !has_finalizer)
{
tree cond;
gfc_se se;
gfc_init_se (&se, NULL);
se.want_pointer = 1;
gfc_conv_expr (&se, final_expr);
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
/* For CLASS(*) not only sym->_vtab->_final can be NULL
but already sym->_vtab itself. */
if (UNLIMITED_POLY (expr))
{
tree cond2;
gfc_expr *vptr_expr;
vptr_expr = gfc_copy_expr (expr);
gfc_add_vptr_component (vptr_expr);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
gfc_conv_expr (&se, vptr_expr);
gfc_free_expr (vptr_expr);
cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
se.expr,
build_int_cst (TREE_TYPE (se.expr), 0));
cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
boolean_type_node, cond2, cond);
}
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
cond, tmp, build_empty_stmt (input_location));
}
gfc_add_expr_to_block (block, tmp);
return true;
}
tree
cilk_for_number_of_iterations (tree cilk_for)
{
tree t, v, n1, n2, step, type, init, cond, incr, itype;
enum tree_code cond_code;
location_t loc = EXPR_LOCATION (cilk_for);
init = TREE_VEC_ELT (OMP_FOR_INIT (cilk_for), 0);
v = TREE_OPERAND (init, 0);
cond = TREE_VEC_ELT (OMP_FOR_COND (cilk_for), 0);
incr = TREE_VEC_ELT (OMP_FOR_INCR (cilk_for), 0);
type = TREE_TYPE (v);
gcc_assert (TREE_CODE (TREE_TYPE (v)) == INTEGER_TYPE
|| TREE_CODE (TREE_TYPE (v)) == POINTER_TYPE);
n1 = TREE_OPERAND (init, 1);
cond_code = TREE_CODE (cond);
n2 = TREE_OPERAND (cond, 1);
switch (cond_code)
{
case LT_EXPR:
case GT_EXPR:
case NE_EXPR:
break;
case LE_EXPR:
if (POINTER_TYPE_P (TREE_TYPE (n2)))
n2 = fold_build_pointer_plus_hwi_loc (loc, n2, 1);
else
n2 = fold_build2_loc (loc, PLUS_EXPR, TREE_TYPE (n2), n2,
build_int_cst (TREE_TYPE (n2), 1));
cond_code = LT_EXPR;
break;
case GE_EXPR:
if (POINTER_TYPE_P (TREE_TYPE (n2)))
n2 = fold_build_pointer_plus_hwi_loc (loc, n2, -1);
else
n2 = fold_build2_loc (loc, MINUS_EXPR, TREE_TYPE (n2), n2,
build_int_cst (TREE_TYPE (n2), 1));
cond_code = GT_EXPR;
break;
default:
gcc_unreachable ();
}
step = NULL_TREE;
switch (TREE_CODE (incr))
{
case PREINCREMENT_EXPR:
case POSTINCREMENT_EXPR:
step = build_int_cst (TREE_TYPE (v), 1);
break;
case PREDECREMENT_EXPR:
case POSTDECREMENT_EXPR:
step = build_int_cst (TREE_TYPE (v), -1);
break;
case MODIFY_EXPR:
t = TREE_OPERAND (incr, 1);
gcc_assert (TREE_OPERAND (t, 0) == v);
switch (TREE_CODE (t))
{
case PLUS_EXPR:
step = TREE_OPERAND (t, 1);
break;
case POINTER_PLUS_EXPR:
step = fold_convert (ssizetype, TREE_OPERAND (t, 1));
break;
case MINUS_EXPR:
step = TREE_OPERAND (t, 1);
step = fold_build1_loc (loc, NEGATE_EXPR, TREE_TYPE (step), step);
break;
default:
gcc_unreachable ();
}
break;
default:
gcc_unreachable ();
}
itype = type;
if (POINTER_TYPE_P (itype))
itype = signed_type_for (itype);
if (cond_code == NE_EXPR)
{
/* For NE_EXPR, we need to find out if the iterator increases
or decreases from whether step is positive or negative. */
tree stype = itype;
if (TYPE_UNSIGNED (stype))
stype = signed_type_for (stype);
cond = fold_build2_loc (loc, GE_EXPR, boolean_type_node,
fold_convert_loc (loc, stype, step),
build_int_cst (stype, 0));
t = fold_build3_loc (loc, COND_EXPR, itype, cond,
build_int_cst (itype, -1),
build_int_cst (itype, 1));
}
else
t = build_int_cst (itype, (cond_code == LT_EXPR ? -1 : 1));
t = fold_build2_loc (loc, PLUS_EXPR, itype,
fold_convert_loc (loc, itype, step), t);
t = fold_build2_loc (loc, PLUS_EXPR, itype, t,
fold_convert_loc (loc, itype, n2));
t = fold_build2_loc (loc, MINUS_EXPR, itype, t,
fold_convert_loc (loc, itype, n1));
if (TYPE_UNSIGNED (itype) && cond_code == GT_EXPR)
t = fold_build2_loc (loc, TRUNC_DIV_EXPR, itype,
fold_build1_loc (loc, NEGATE_EXPR, itype, t),
fold_build1_loc (loc, NEGATE_EXPR, itype,
fold_convert_loc (loc, itype,
step)));
else if (TYPE_UNSIGNED (itype) && cond_code == NE_EXPR)
{
tree t1
= fold_build2_loc (loc, TRUNC_DIV_EXPR, itype, t,
fold_convert_loc (loc, itype, step));
tree t2
= fold_build2_loc (loc, TRUNC_DIV_EXPR, itype,
fold_build1_loc (loc, NEGATE_EXPR, itype, t),
fold_build1_loc (loc, NEGATE_EXPR, itype,
fold_convert_loc (loc, itype,
step)));
t = fold_build3_loc (loc, COND_EXPR, itype, cond, t1, t2);
}
else
t = fold_build2_loc (loc, TRUNC_DIV_EXPR, itype, t,
fold_convert_loc (loc, itype, step));
cond = fold_build2_loc (loc, cond_code, boolean_type_node, n1, n2);
t = fold_build3_loc (loc, COND_EXPR, itype, cond, t,
build_int_cst (itype, 0));
return t;
}
/* 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;
}
/* 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;
}
static tree
c_fully_fold_internal (tree expr, bool in_init, bool *maybe_const_operands,
bool *maybe_const_itself, bool for_int_const)
{
tree ret = expr;
enum tree_code code = TREE_CODE (expr);
enum tree_code_class kind = TREE_CODE_CLASS (code);
location_t loc = EXPR_LOCATION (expr);
tree op0, op1, op2, op3;
tree orig_op0, orig_op1, orig_op2;
bool op0_const = true, op1_const = true, op2_const = true;
bool op0_const_self = true, op1_const_self = true, op2_const_self = true;
bool nowarning = TREE_NO_WARNING (expr);
bool unused_p;
source_range old_range;
/* Constants, declarations, statements, errors, SAVE_EXPRs and
anything else not counted as an expression cannot usefully be
folded further at this point. */
if (!IS_EXPR_CODE_CLASS (kind)
|| kind == tcc_statement
|| code == SAVE_EXPR)
return expr;
if (IS_EXPR_CODE_CLASS (kind))
old_range = EXPR_LOCATION_RANGE (expr);
/* Operands of variable-length expressions (function calls) have
already been folded, as have __builtin_* function calls, and such
expressions cannot occur in constant expressions. */
if (kind == tcc_vl_exp)
{
*maybe_const_operands = false;
ret = fold (expr);
goto out;
}
if (code == C_MAYBE_CONST_EXPR)
{
tree pre = C_MAYBE_CONST_EXPR_PRE (expr);
tree inner = C_MAYBE_CONST_EXPR_EXPR (expr);
if (C_MAYBE_CONST_EXPR_NON_CONST (expr))
*maybe_const_operands = false;
if (C_MAYBE_CONST_EXPR_INT_OPERANDS (expr))
{
*maybe_const_itself = false;
inner = c_fully_fold_internal (inner, in_init, maybe_const_operands,
maybe_const_itself, true);
}
if (pre && !in_init)
ret = build2 (COMPOUND_EXPR, TREE_TYPE (expr), pre, inner);
else
ret = inner;
goto out;
}
/* Assignment, increment, decrement, function call and comma
operators, and statement expressions, cannot occur in constant
expressions if evaluated / outside of sizeof. (Function calls
were handled above, though VA_ARG_EXPR is treated like a function
call here, and statement expressions are handled through
C_MAYBE_CONST_EXPR to avoid folding inside them.) */
switch (code)
{
case MODIFY_EXPR:
case PREDECREMENT_EXPR:
case PREINCREMENT_EXPR:
case POSTDECREMENT_EXPR:
case POSTINCREMENT_EXPR:
case COMPOUND_EXPR:
*maybe_const_operands = false;
break;
case VA_ARG_EXPR:
case TARGET_EXPR:
case BIND_EXPR:
case OBJ_TYPE_REF:
*maybe_const_operands = false;
ret = fold (expr);
goto out;
default:
break;
}
/* Fold individual tree codes as appropriate. */
switch (code)
{
case COMPOUND_LITERAL_EXPR:
/* Any non-constancy will have been marked in a containing
C_MAYBE_CONST_EXPR; there is no more folding to do here. */
goto out;
case COMPONENT_REF:
orig_op0 = op0 = TREE_OPERAND (expr, 0);
op1 = TREE_OPERAND (expr, 1);
op2 = TREE_OPERAND (expr, 2);
op0 = c_fully_fold_internal (op0, in_init, maybe_const_operands,
maybe_const_itself, for_int_const);
STRIP_TYPE_NOPS (op0);
if (op0 != orig_op0)
ret = build3 (COMPONENT_REF, TREE_TYPE (expr), op0, op1, op2);
if (ret != expr)
{
TREE_READONLY (ret) = TREE_READONLY (expr);
TREE_THIS_VOLATILE (ret) = TREE_THIS_VOLATILE (expr);
}
goto out;
case ARRAY_REF:
orig_op0 = op0 = TREE_OPERAND (expr, 0);
orig_op1 = op1 = TREE_OPERAND (expr, 1);
op2 = TREE_OPERAND (expr, 2);
op3 = TREE_OPERAND (expr, 3);
op0 = c_fully_fold_internal (op0, in_init, maybe_const_operands,
maybe_const_itself, for_int_const);
STRIP_TYPE_NOPS (op0);
op1 = c_fully_fold_internal (op1, in_init, maybe_const_operands,
maybe_const_itself, for_int_const);
STRIP_TYPE_NOPS (op1);
op1 = decl_constant_value_for_optimization (op1);
if (op0 != orig_op0 || op1 != orig_op1)
ret = build4 (ARRAY_REF, TREE_TYPE (expr), op0, op1, op2, op3);
if (ret != expr)
{
TREE_READONLY (ret) = TREE_READONLY (expr);
TREE_SIDE_EFFECTS (ret) = TREE_SIDE_EFFECTS (expr);
TREE_THIS_VOLATILE (ret) = TREE_THIS_VOLATILE (expr);
}
ret = fold (ret);
goto out;
case COMPOUND_EXPR:
case MODIFY_EXPR:
case PREDECREMENT_EXPR:
case PREINCREMENT_EXPR:
case POSTDECREMENT_EXPR:
case POSTINCREMENT_EXPR:
case PLUS_EXPR:
case MINUS_EXPR:
case MULT_EXPR:
case POINTER_PLUS_EXPR:
case TRUNC_DIV_EXPR:
case CEIL_DIV_EXPR:
case FLOOR_DIV_EXPR:
case TRUNC_MOD_EXPR:
case RDIV_EXPR:
case EXACT_DIV_EXPR:
case LSHIFT_EXPR:
case RSHIFT_EXPR:
case BIT_IOR_EXPR:
case BIT_XOR_EXPR:
case BIT_AND_EXPR:
case LT_EXPR:
case LE_EXPR:
case GT_EXPR:
case GE_EXPR:
case EQ_EXPR:
case NE_EXPR:
case COMPLEX_EXPR:
case TRUTH_AND_EXPR:
case TRUTH_OR_EXPR:
case TRUTH_XOR_EXPR:
case UNORDERED_EXPR:
case ORDERED_EXPR:
case UNLT_EXPR:
case UNLE_EXPR:
case UNGT_EXPR:
case UNGE_EXPR:
case UNEQ_EXPR:
/* Binary operations evaluating both arguments (increment and
decrement are binary internally in GCC). */
orig_op0 = op0 = TREE_OPERAND (expr, 0);
orig_op1 = op1 = TREE_OPERAND (expr, 1);
op0 = c_fully_fold_internal (op0, in_init, maybe_const_operands,
maybe_const_itself, for_int_const);
STRIP_TYPE_NOPS (op0);
if (code != MODIFY_EXPR
&& code != PREDECREMENT_EXPR
&& code != PREINCREMENT_EXPR
&& code != POSTDECREMENT_EXPR
&& code != POSTINCREMENT_EXPR)
op0 = decl_constant_value_for_optimization (op0);
/* The RHS of a MODIFY_EXPR was fully folded when building that
expression for the sake of conversion warnings. */
if (code != MODIFY_EXPR)
op1 = c_fully_fold_internal (op1, in_init, maybe_const_operands,
maybe_const_itself, for_int_const);
STRIP_TYPE_NOPS (op1);
op1 = decl_constant_value_for_optimization (op1);
if (for_int_const && (TREE_CODE (op0) != INTEGER_CST
|| TREE_CODE (op1) != INTEGER_CST))
goto out;
if (op0 != orig_op0 || op1 != orig_op1 || in_init)
ret = in_init
? fold_build2_initializer_loc (loc, code, TREE_TYPE (expr), op0, op1)
: fold_build2_loc (loc, code, TREE_TYPE (expr), op0, op1);
else
ret = fold (expr);
if (TREE_OVERFLOW_P (ret)
&& !TREE_OVERFLOW_P (op0)
&& !TREE_OVERFLOW_P (op1))
overflow_warning (EXPR_LOC_OR_LOC (expr, input_location), ret);
if (code == LSHIFT_EXPR
&& TREE_CODE (orig_op0) != INTEGER_CST
&& TREE_CODE (TREE_TYPE (orig_op0)) == INTEGER_TYPE
&& TREE_CODE (op0) == INTEGER_CST
&& c_inhibit_evaluation_warnings == 0
&& tree_int_cst_sgn (op0) < 0)
warning_at (loc, OPT_Wshift_negative_value,
"left shift of negative value");
if ((code == LSHIFT_EXPR || code == RSHIFT_EXPR)
&& TREE_CODE (orig_op1) != INTEGER_CST
&& TREE_CODE (op1) == INTEGER_CST
&& (TREE_CODE (TREE_TYPE (orig_op0)) == INTEGER_TYPE
|| TREE_CODE (TREE_TYPE (orig_op0)) == FIXED_POINT_TYPE)
&& TREE_CODE (TREE_TYPE (orig_op1)) == INTEGER_TYPE
&& c_inhibit_evaluation_warnings == 0)
{
if (tree_int_cst_sgn (op1) < 0)
warning_at (loc, OPT_Wshift_count_negative,
(code == LSHIFT_EXPR
? G_("left shift count is negative")
: G_("right shift count is negative")));
else if (compare_tree_int (op1,
TYPE_PRECISION (TREE_TYPE (orig_op0)))
>= 0)
warning_at (loc, OPT_Wshift_count_overflow,
(code == LSHIFT_EXPR
? G_("left shift count >= width of type")
: G_("right shift count >= width of type")));
}
if (code == LSHIFT_EXPR
/* If either OP0 has been folded to INTEGER_CST... */
&& ((TREE_CODE (orig_op0) != INTEGER_CST
&& TREE_CODE (TREE_TYPE (orig_op0)) == INTEGER_TYPE
&& TREE_CODE (op0) == INTEGER_CST)
/* ...or if OP1 has been folded to INTEGER_CST... */
|| (TREE_CODE (orig_op1) != INTEGER_CST
&& TREE_CODE (TREE_TYPE (orig_op1)) == INTEGER_TYPE
&& TREE_CODE (op1) == INTEGER_CST))
&& c_inhibit_evaluation_warnings == 0)
/* ...then maybe we can detect an overflow. */
maybe_warn_shift_overflow (loc, op0, op1);
if ((code == TRUNC_DIV_EXPR
|| code == CEIL_DIV_EXPR
|| code == FLOOR_DIV_EXPR
|| code == EXACT_DIV_EXPR
|| code == TRUNC_MOD_EXPR)
&& TREE_CODE (orig_op1) != INTEGER_CST
&& TREE_CODE (op1) == INTEGER_CST
&& (TREE_CODE (TREE_TYPE (orig_op0)) == INTEGER_TYPE
|| TREE_CODE (TREE_TYPE (orig_op0)) == FIXED_POINT_TYPE)
&& TREE_CODE (TREE_TYPE (orig_op1)) == INTEGER_TYPE)
warn_for_div_by_zero (loc, op1);
goto out;
case INDIRECT_REF:
case FIX_TRUNC_EXPR:
case FLOAT_EXPR:
CASE_CONVERT:
case ADDR_SPACE_CONVERT_EXPR:
case VIEW_CONVERT_EXPR:
case NON_LVALUE_EXPR:
case NEGATE_EXPR:
case BIT_NOT_EXPR:
case TRUTH_NOT_EXPR:
case ADDR_EXPR:
case CONJ_EXPR:
case REALPART_EXPR:
case IMAGPART_EXPR:
/* Unary operations. */
orig_op0 = op0 = TREE_OPERAND (expr, 0);
op0 = c_fully_fold_internal (op0, in_init, maybe_const_operands,
maybe_const_itself, for_int_const);
STRIP_TYPE_NOPS (op0);
if (code != ADDR_EXPR && code != REALPART_EXPR && code != IMAGPART_EXPR)
op0 = decl_constant_value_for_optimization (op0);
if (for_int_const && TREE_CODE (op0) != INTEGER_CST)
goto out;
/* ??? Cope with user tricks that amount to offsetof. The middle-end is
not prepared to deal with them if they occur in initializers. */
if (op0 != orig_op0
&& code == ADDR_EXPR
&& (op1 = get_base_address (op0)) != NULL_TREE
&& INDIRECT_REF_P (op1)
&& TREE_CONSTANT (TREE_OPERAND (op1, 0)))
ret = fold_convert_loc (loc, TREE_TYPE (expr), fold_offsetof_1 (op0));
else if (op0 != orig_op0 || in_init)
ret = in_init
? fold_build1_initializer_loc (loc, code, TREE_TYPE (expr), op0)
: fold_build1_loc (loc, code, TREE_TYPE (expr), op0);
else
ret = fold (expr);
if (code == INDIRECT_REF
&& ret != expr
&& INDIRECT_REF_P (ret))
{
TREE_READONLY (ret) = TREE_READONLY (expr);
TREE_SIDE_EFFECTS (ret) = TREE_SIDE_EFFECTS (expr);
TREE_THIS_VOLATILE (ret) = TREE_THIS_VOLATILE (expr);
}
switch (code)
{
case FIX_TRUNC_EXPR:
case FLOAT_EXPR:
CASE_CONVERT:
/* Don't warn about explicit conversions. We will already
have warned about suspect implicit conversions. */
break;
default:
if (TREE_OVERFLOW_P (ret) && !TREE_OVERFLOW_P (op0))
overflow_warning (EXPR_LOCATION (expr), ret);
break;
}
goto out;
case TRUTH_ANDIF_EXPR:
case TRUTH_ORIF_EXPR:
/* Binary operations not necessarily evaluating both
arguments. */
orig_op0 = op0 = TREE_OPERAND (expr, 0);
orig_op1 = op1 = TREE_OPERAND (expr, 1);
op0 = c_fully_fold_internal (op0, in_init, &op0_const, &op0_const_self,
for_int_const);
STRIP_TYPE_NOPS (op0);
unused_p = (op0 == (code == TRUTH_ANDIF_EXPR
? truthvalue_false_node
: truthvalue_true_node));
c_disable_warnings (unused_p);
op1 = c_fully_fold_internal (op1, in_init, &op1_const, &op1_const_self,
for_int_const);
STRIP_TYPE_NOPS (op1);
c_enable_warnings (unused_p);
if (for_int_const
&& (TREE_CODE (op0) != INTEGER_CST
/* Require OP1 be an INTEGER_CST only if it's evaluated. */
|| (!unused_p && TREE_CODE (op1) != INTEGER_CST)))
goto out;
if (op0 != orig_op0 || op1 != orig_op1 || in_init)
ret = in_init
? fold_build2_initializer_loc (loc, code, TREE_TYPE (expr), op0, op1)
: fold_build2_loc (loc, code, TREE_TYPE (expr), op0, op1);
else
ret = fold (expr);
*maybe_const_operands &= op0_const;
*maybe_const_itself &= op0_const_self;
if (!(flag_isoc99
&& op0_const
&& op0_const_self
&& (code == TRUTH_ANDIF_EXPR
? op0 == truthvalue_false_node
: op0 == truthvalue_true_node)))
*maybe_const_operands &= op1_const;
if (!(op0_const
&& op0_const_self
&& (code == TRUTH_ANDIF_EXPR
? op0 == truthvalue_false_node
: op0 == truthvalue_true_node)))
*maybe_const_itself &= op1_const_self;
goto out;
case COND_EXPR:
orig_op0 = op0 = TREE_OPERAND (expr, 0);
orig_op1 = op1 = TREE_OPERAND (expr, 1);
orig_op2 = op2 = TREE_OPERAND (expr, 2);
op0 = c_fully_fold_internal (op0, in_init, &op0_const, &op0_const_self,
for_int_const);
STRIP_TYPE_NOPS (op0);
c_disable_warnings (op0 == truthvalue_false_node);
op1 = c_fully_fold_internal (op1, in_init, &op1_const, &op1_const_self,
for_int_const);
STRIP_TYPE_NOPS (op1);
c_enable_warnings (op0 == truthvalue_false_node);
c_disable_warnings (op0 == truthvalue_true_node);
op2 = c_fully_fold_internal (op2, in_init, &op2_const, &op2_const_self,
for_int_const);
STRIP_TYPE_NOPS (op2);
c_enable_warnings (op0 == truthvalue_true_node);
if (for_int_const
&& (TREE_CODE (op0) != INTEGER_CST
/* Only the evaluated operand must be an INTEGER_CST. */
|| (op0 == truthvalue_true_node
? TREE_CODE (op1) != INTEGER_CST
: TREE_CODE (op2) != INTEGER_CST)))
goto out;
if (op0 != orig_op0 || op1 != orig_op1 || op2 != orig_op2)
ret = fold_build3_loc (loc, code, TREE_TYPE (expr), op0, op1, op2);
else
ret = fold (expr);
*maybe_const_operands &= op0_const;
*maybe_const_itself &= op0_const_self;
if (!(flag_isoc99
&& op0_const
&& op0_const_self
&& op0 == truthvalue_false_node))
*maybe_const_operands &= op1_const;
if (!(op0_const
&& op0_const_self
&& op0 == truthvalue_false_node))
*maybe_const_itself &= op1_const_self;
if (!(flag_isoc99
&& op0_const
&& op0_const_self
&& op0 == truthvalue_true_node))
*maybe_const_operands &= op2_const;
if (!(op0_const
&& op0_const_self
&& op0 == truthvalue_true_node))
*maybe_const_itself &= op2_const_self;
goto out;
case VEC_COND_EXPR:
orig_op0 = op0 = TREE_OPERAND (expr, 0);
orig_op1 = op1 = TREE_OPERAND (expr, 1);
orig_op2 = op2 = TREE_OPERAND (expr, 2);
op0 = c_fully_fold_internal (op0, in_init, maybe_const_operands,
maybe_const_itself, for_int_const);
STRIP_TYPE_NOPS (op0);
op1 = c_fully_fold_internal (op1, in_init, maybe_const_operands,
maybe_const_itself, for_int_const);
STRIP_TYPE_NOPS (op1);
op2 = c_fully_fold_internal (op2, in_init, maybe_const_operands,
maybe_const_itself, for_int_const);
STRIP_TYPE_NOPS (op2);
if (op0 != orig_op0 || op1 != orig_op1 || op2 != orig_op2)
ret = fold_build3_loc (loc, code, TREE_TYPE (expr), op0, op1, op2);
else
ret = fold (expr);
goto out;
case EXCESS_PRECISION_EXPR:
/* Each case where an operand with excess precision may be
encountered must remove the EXCESS_PRECISION_EXPR around
inner operands and possibly put one around the whole
expression or possibly convert to the semantic type (which
c_fully_fold does); we cannot tell at this stage which is
appropriate in any particular case. */
gcc_unreachable ();
default:
/* Various codes may appear through folding built-in functions
and their arguments. */
goto out;
}
out:
/* Some folding may introduce NON_LVALUE_EXPRs; all lvalue checks
have been done by this point, so remove them again. */
nowarning |= TREE_NO_WARNING (ret);
STRIP_TYPE_NOPS (ret);
if (nowarning && !TREE_NO_WARNING (ret))
{
if (!CAN_HAVE_LOCATION_P (ret))
ret = build1 (NOP_EXPR, TREE_TYPE (ret), ret);
TREE_NO_WARNING (ret) = 1;
}
if (ret != expr)
{
protected_set_expr_location (ret, loc);
if (IS_EXPR_CODE_CLASS (kind))
set_source_range (ret, old_range.m_start, old_range.m_finish);
}
return ret;
}
static void
genericize_cp_loop (tree *stmt_p, location_t start_locus, tree cond, tree body,
tree incr, bool cond_is_first, int *walk_subtrees,
void *data)
{
tree blab, clab;
tree entry = NULL, exit = NULL, t;
tree stmt_list = NULL;
blab = begin_bc_block (bc_break, start_locus);
clab = begin_bc_block (bc_continue, start_locus);
if (incr && EXPR_P (incr))
SET_EXPR_LOCATION (incr, start_locus);
cp_walk_tree (&cond, cp_genericize_r, data, NULL);
cp_walk_tree (&body, cp_genericize_r, data, NULL);
cp_walk_tree (&incr, cp_genericize_r, data, NULL);
*walk_subtrees = 0;
/* If condition is zero don't generate a loop construct. */
if (cond && integer_zerop (cond))
{
if (cond_is_first)
{
t = build1_loc (start_locus, GOTO_EXPR, void_type_node,
get_bc_label (bc_break));
append_to_statement_list (t, &stmt_list);
}
}
else
{
/* Expand to gotos, just like c_finish_loop. TODO: Use LOOP_EXPR. */
tree top = build1 (LABEL_EXPR, void_type_node,
create_artificial_label (start_locus));
/* If we have an exit condition, then we build an IF with gotos either
out of the loop, or to the top of it. If there's no exit condition,
then we just build a jump back to the top. */
exit = build1 (GOTO_EXPR, void_type_node, LABEL_EXPR_LABEL (top));
if (cond && !integer_nonzerop (cond))
{
/* Canonicalize the loop condition to the end. This means
generating a branch to the loop condition. Reuse the
continue label, if possible. */
if (cond_is_first)
{
if (incr)
{
entry = build1 (LABEL_EXPR, void_type_node,
create_artificial_label (start_locus));
t = build1_loc (start_locus, GOTO_EXPR, void_type_node,
LABEL_EXPR_LABEL (entry));
}
else
t = build1_loc (start_locus, GOTO_EXPR, void_type_node,
get_bc_label (bc_continue));
append_to_statement_list (t, &stmt_list);
}
t = build1 (GOTO_EXPR, void_type_node, get_bc_label (bc_break));
exit = fold_build3_loc (start_locus,
COND_EXPR, void_type_node, cond, exit, t);
}
append_to_statement_list (top, &stmt_list);
}
append_to_statement_list (body, &stmt_list);
finish_bc_block (&stmt_list, bc_continue, clab);
append_to_statement_list (incr, &stmt_list);
append_to_statement_list (entry, &stmt_list);
append_to_statement_list (exit, &stmt_list);
finish_bc_block (&stmt_list, bc_break, blab);
if (stmt_list == NULL_TREE)
stmt_list = build1 (NOP_EXPR, void_type_node, integer_zero_node);
*stmt_p = stmt_list;
}
