char fortran_is_pointer_to_array_type(type_t* t)
{
t = no_ref(t);
return is_pointer_type(t)
&& fortran_is_array_type(pointer_type_get_pointee_type(t));
}
type_t* fortran_update_basic_type_with_type(type_t* type_info, type_t* basic_type)
{
if (is_error_type(basic_type))
return basic_type;
// Many functions drop the reference type, so chek it the first
if (is_lvalue_reference_type(type_info))
{
return get_lvalue_reference_type(
fortran_update_basic_type_with_type(reference_type_get_referenced_type(type_info), basic_type));
}
else if (is_pointer_type(type_info))
{
return get_pointer_type(
fortran_update_basic_type_with_type(pointer_type_get_pointee_type(type_info), basic_type)
);
}
else if (fortran_is_array_type(type_info))
{
return get_array_type_bounds(
fortran_update_basic_type_with_type(array_type_get_element_type(type_info), basic_type),
array_type_get_array_lower_bound(type_info),
array_type_get_array_upper_bound(type_info),
array_type_get_array_size_expr_context(type_info));
}
else if (is_function_type(type_info))
{
return fortran_replace_return_type_of_function_type(type_info, basic_type);
}
else
{
return basic_type;
}
}
char fortran_basic_type_is_implicit_none(type_t* t)
{
if (t == NULL)
{
return 0;
}
else if (is_implicit_none_type(t))
{
return 1;
}
else if (is_array_type(t))
{
return fortran_basic_type_is_implicit_none(array_type_get_element_type(t));
}
else if (is_function_type(t))
{
return fortran_basic_type_is_implicit_none(function_type_get_return_type(t));
}
else if (is_lvalue_reference_type(t))
{
return fortran_basic_type_is_implicit_none(reference_type_get_referenced_type(t));
}
else if (is_pointer_type(t))
{
return fortran_basic_type_is_implicit_none(pointer_type_get_pointee_type(t));
}
else
return 0;
}
char fortran_is_scalar_type(type_t* t)
{
return (!is_pointer_type(t)
&& !is_pointer_to_member_type(t)
&& !is_array_type(t)
&& !is_lvalue_reference_type(t)
&& !is_rvalue_reference_type(t)
&& !is_function_type(t)
&& !is_vector_type(t));
}
char fortran_is_pointer_to_character_type(type_t* t)
{
t = no_ref(t);
if (is_pointer_type(t))
{
return fortran_is_character_type(pointer_type_get_pointee_type(t));
}
return 0;
}
/*! \brief Validates a return statement.
*
* \param s
* the Stmt to validate.
* \param data
* a pointer to a validate_arg struct.
*
* If \a s is a return statement, this function validates the expression
* returned to make sure its type is as specified in the function's prototype.
*/
static void
validate_return (Stmt s, void *data)
{
validate_arg *arg = (validate_arg *)data;
FuncDcl parent_func;
Type return_type, expr_type;
bool return_is_multi, return_is_pointer, expr_is_multi, expr_is_pointer;
Expr ret;
if (P_GetStmtType (s) == ST_RETURN && (ret = P_GetStmtRet (s)))
{
/* Find the return's parent FuncDcl. */
parent_func = PST_GetStmtParentFunc (arg->ip_table, s);
return_type = PST_GetTypeType (arg->ip_table,
P_GetFuncDclType (parent_func));
expr_type = PST_ExprType (arg->ip_table, ret);
return_is_multi = is_multi_type (arg->ip_table, return_type);
return_is_pointer = is_pointer_type (arg->ip_table, return_type);
expr_is_multi = is_multi_type (arg->ip_table, expr_type);
expr_is_pointer = is_pointer_type (arg->ip_table, expr_type);
if (return_is_multi && !expr_is_multi)
{
/* Build (t.field = cur_arg, t) */
make_struct_pointer_multi (arg->ip_table, return_type, ret);
arg->must_flatten = TRUE;
}
else if (return_is_multi && expr_is_pointer)
{
/* Build (arg.field). */
ret = make_dot (arg->ip_table, ret, expr_type,
PST_GetFuncDclScope (arg->ip_table, parent_func));
arg->must_flatten = TRUE;
}
}
return;
}
char fortran_is_intrinsic_type(type_t* t)
{
t = no_ref(t);
if (is_pointer_type(t))
t = pointer_type_get_pointee_type(t);
return (is_integer_type(t)
|| is_floating_type(t)
|| is_complex_type(t)
|| is_bool_type(t)
|| fortran_is_character_type(t));
}
type_t* fortran_get_rank0_type_internal(type_t* t, char ignore_pointer)
{
t = no_ref(t);
if (ignore_pointer && is_pointer_type(t))
t = pointer_type_get_pointee_type(t);
while (fortran_is_array_type(t))
{
t = array_type_get_element_type(t);
}
return t;
}
XI_CAST_FUNC(ast_pointer, tt, fe) {
ast_type* t_elt = tt->element_type;
// Cast from another pointer type
// ------------------------------
if(is_pointer_type(fe->type)) {
ast_type* f_elt = fe->type->as<ast_pointer_type>()->element_type;
if(_builder.sametype(t_elt, f_elt)) return fe; // same type
else return bitcast_to(tt, fe);
}
// Cast from an integer type
// -------------------------
if(is_integer_type(fe->type)) {
auto ft = fe->type->as<ast_integer_type>();
uint32_t fw = ft->bitwidth;
bool fu = ft->is_unsigned;
if(!fu) {
return this->visit(tt,
this->visit(_builder.get_integer_type(fw, true), fe));
}
else {
return new ast_cast(tt, ast_op::utop, fe);
}
}
// Cast from an array type
// -----------------------
if(is_array_type(fe->type)) {
//TODO: check that array expression is addressable
auto ft = fe->type->as<ast_array_type>();
ast_type* f_elt = ft->element_type;
return new ast_addressof(tt,
_builder.make_index_expr(fe, _builder.make_zero(_builder.get_size_type())));
}
__throw_unhandled_ast_type(__FILE__, __LINE__, fe->type, "CAST_FUNC(ast_pointer)");
}
bool Type::is_pointer() const
{
return (is_pointer_type(_type_info));
}
const char* fortran_print_type_str(type_t* t)
{
t = no_ref(t);
if (is_error_type(t))
{
return "<error-type>";
}
if (is_hollerith_type(t))
{
return "HOLLERITH";
}
const char* result = "";
char is_pointer = 0;
if (is_pointer_type(t))
{
is_pointer = 1;
t = pointer_type_get_pointee_type(t);
}
struct array_spec_tag {
nodecl_t lower;
nodecl_t upper;
char is_undefined;
} array_spec_list[MCXX_MAX_ARRAY_SPECIFIER] = { { nodecl_null(), nodecl_null(), 0 } };
int array_spec_idx;
for (array_spec_idx = MCXX_MAX_ARRAY_SPECIFIER - 1;
fortran_is_array_type(t);
array_spec_idx--)
{
if (array_spec_idx < 0)
{
internal_error("too many array dimensions %d\n", MCXX_MAX_ARRAY_SPECIFIER);
}
if (!array_type_is_unknown_size(t))
{
array_spec_list[array_spec_idx].lower = array_type_get_array_lower_bound(t);
array_spec_list[array_spec_idx].upper = array_type_get_array_upper_bound(t);
}
else
{
array_spec_list[array_spec_idx].is_undefined = 1;
}
t = array_type_get_element_type(t);
}
char is_array = (array_spec_idx != (MCXX_MAX_ARRAY_SPECIFIER - 1));
if (is_bool_type(t)
|| is_integer_type(t)
|| is_floating_type(t)
|| is_double_type(t)
|| is_complex_type(t))
{
const char* type_name = NULL;
char c[128] = { 0 };
if (is_bool_type(t))
{
type_name = "LOGICAL";
}
else if (is_integer_type(t))
{
type_name = "INTEGER";
}
else if (is_floating_type(t))
{
type_name = "REAL";
}
else if (is_complex_type(t))
{
type_name = "COMPLEX";
}
else
{
internal_error("unreachable code", 0);
}
size_t size = type_get_size(t);
if (is_floating_type(t))
{
// KIND of floats is their size in byes (using the bits as in IEEE754)
size = (floating_type_get_info(t)->bits) / 8;
}
else if (is_complex_type(t))
{
// KIND of a complex is the KIND of its component type
type_t* f = complex_type_get_base_type(t);
size = (floating_type_get_info(f)->bits) / 8;
}
snprintf(c, 127, "%s(%zd)", type_name, size);
c[127] = '\0';
result = uniquestr(c);
}
else if (is_class_type(t))
{
scope_entry_t* entry = named_type_get_symbol(t);
char c[128] = { 0 };
snprintf(c, 127, "TYPE(%s)",
entry->symbol_name);
c[127] = '\0';
result = uniquestr(c);
}
else if (fortran_is_character_type(t))
{
nodecl_t length = array_type_get_array_size_expr(t);
char c[128] = { 0 };
snprintf(c, 127, "CHARACTER(LEN=%s)",
nodecl_is_null(length) ? "*" : codegen_to_str(length, nodecl_retrieve_context(length)));
c[127] = '\0';
result = uniquestr(c);
}
else if (is_function_type(t))
{
result = "PROCEDURE";
}
else
{
const char* non_printable = NULL;
uniquestr_sprintf(&non_printable, "non-fortran type '%s'", print_declarator(t));
return non_printable;
}
if (is_pointer)
{
result = strappend(result, ", POINTER");
}
if (is_array)
{
array_spec_idx++;
result = strappend(result, ", DIMENSION(");
while (array_spec_idx <= (MCXX_MAX_ARRAY_SPECIFIER - 1))
{
if (!array_spec_list[array_spec_idx].is_undefined)
{
result = strappend(result, codegen_to_str(array_spec_list[array_spec_idx].lower,
nodecl_retrieve_context(array_spec_list[array_spec_idx].lower)));
result = strappend(result, ":");
result = strappend(result, codegen_to_str(array_spec_list[array_spec_idx].upper,
nodecl_retrieve_context(array_spec_list[array_spec_idx].upper)));
}
else
{
result = strappend(result, ":");
}
if ((array_spec_idx + 1) <= (MCXX_MAX_ARRAY_SPECIFIER - 1))
{
result = strappend(result, ", ");
}
array_spec_idx++;
}
result = strappend(result, ")");
}
return result;
}
void
goto_symext::symex_step(reachability_treet & art)
{
assert(!cur_state->call_stack.empty());
const goto_programt::instructiont &instruction = *cur_state->source.pc;
// depth exceeded?
{
if (depth_limit != 0 && cur_state->depth > depth_limit)
cur_state->guard.add(false_expr);
cur_state->depth++;
}
// actually do instruction
switch (instruction.type) {
case SKIP:
case LOCATION:
// really ignore
cur_state->source.pc++;
break;
case END_FUNCTION:
symex_end_of_function();
// Potentially skip to run another function ptr target; if not,
// continue
if (!run_next_function_ptr_target(false))
cur_state->source.pc++;
break;
case GOTO:
{
expr2tc tmp(instruction.guard);
replace_nondet(tmp);
dereference(tmp, false);
replace_dynamic_allocation(tmp);
symex_goto(tmp);
}
break;
case ASSUME:
if (!cur_state->guard.is_false()) {
expr2tc tmp = instruction.guard;
replace_nondet(tmp);
dereference(tmp, false);
replace_dynamic_allocation(tmp);
cur_state->rename(tmp);
do_simplify(tmp);
if (!is_true(tmp)) {
expr2tc tmp2 = tmp;
expr2tc tmp3 = tmp2;
cur_state->guard.guard_expr(tmp2);
assume(tmp2);
// we also add it to the state guard
cur_state->guard.add(tmp3);
}
}
cur_state->source.pc++;
break;
case ASSERT:
if (!cur_state->guard.is_false()) {
if (!no_assertions ||
!cur_state->source.pc->location.user_provided()
|| deadlock_check) {
std::string msg = cur_state->source.pc->location.comment().as_string();
if (msg == "") msg = "assertion";
expr2tc tmp = instruction.guard;
replace_nondet(tmp);
dereference(tmp, false);
replace_dynamic_allocation(tmp);
claim(tmp, msg);
}
}
cur_state->source.pc++;
break;
case RETURN:
if (!cur_state->guard.is_false()) {
expr2tc thecode = instruction.code, assign;
if (make_return_assignment(assign, thecode)) {
goto_symext::symex_assign(assign);
}
symex_return();
}
cur_state->source.pc++;
break;
case ASSIGN:
if (!cur_state->guard.is_false()) {
code_assign2tc deref_code = instruction.code;
// XXX jmorse -- this is not fully symbolic.
if (thrown_obj_map.find(cur_state->source.pc) != thrown_obj_map.end()) {
symbol2tc thrown_obj = thrown_obj_map[cur_state->source.pc];
if (is_pointer_type(deref_code.get()->target.get()->type)
&& !is_pointer_type(thrown_obj.get()->type))
{
expr2tc new_thrown_obj(new address_of2t(thrown_obj.get()->type, thrown_obj));
deref_code.get()->source = new_thrown_obj;
}
else
deref_code.get()->source = thrown_obj;
thrown_obj_map.erase(cur_state->source.pc);
}
replace_nondet(deref_code);
code_assign2t &assign = to_code_assign2t(deref_code);
dereference(assign.target, true);
dereference(assign.source, false);
replace_dynamic_allocation(deref_code);
symex_assign(deref_code);
}
cur_state->source.pc++;
break;
case FUNCTION_CALL:
{
expr2tc deref_code = instruction.code;
replace_nondet(deref_code);
code_function_call2t &call = to_code_function_call2t(deref_code);
if (!is_nil_expr(call.ret)) {
dereference(call.ret, true);
}
replace_dynamic_allocation(deref_code);
for (std::vector<expr2tc>::iterator it = call.operands.begin();
it != call.operands.end(); it++)
if (!is_nil_expr(*it))
dereference(*it, false);
// Always run intrinsics, whether guard is false or not. This is due to the
// unfortunate circumstance where a thread starts with false guard due to
// decision taken in another thread in this trace. In that case the
// terminate intrinsic _has_ to run, or we explode.
if (is_symbol2t(call.function)) {
const irep_idt &id = to_symbol2t(call.function).thename;
if (has_prefix(id.as_string(), "c::__ESBMC")) {
cur_state->source.pc++;
std::string name = id.as_string().substr(3);
run_intrinsic(call, art, name);
return;
} else if (has_prefix(id.as_string(), "cpp::__ESBMC")) {
cur_state->source.pc++;
std::string name = id.as_string().substr(5);
name = name.substr(0, name.find("("));
run_intrinsic(call, art, name);
return;
}
}
// Don't run a function call if the guard is false.
if (!cur_state->guard.is_false()) {
symex_function_call(deref_code);
} else {
cur_state->source.pc++;
}
}
break;
case OTHER:
if (!cur_state->guard.is_false()) {
symex_other();
}
cur_state->source.pc++;
break;
case CATCH:
symex_catch();
break;
case THROW:
if (!cur_state->guard.is_false()) {
if(symex_throw())
cur_state->source.pc++;
} else {
cur_state->source.pc++;
}
break;
case THROW_DECL:
symex_throw_decl();
cur_state->source.pc++;
break;
case THROW_DECL_END:
// When we reach THROW_DECL_END, we must clear any throw_decl
if(stack_catch.size())
{
// Get to the correct try (always the last one)
goto_symex_statet::exceptiont* except=&stack_catch.top();
except->has_throw_decl=false;
except->throw_list_set.clear();
}
cur_state->source.pc++;
break;
default:
std::cerr << "GOTO instruction type " << instruction.type;
std::cerr << " not handled in goto_symext::symex_step" << std::endl;
abort();
}
}
/*! \brief Validates a function call.
*
* \param e
* the Expr to inspect.
* \param data
* a pointer to a validate_arg struct.
*
* Validates the arguments to a function call against the called
* function's param types. If a parameter is of a multi type union,
* the correct field is selected. If the call has too many or too few
* arguments, this is corrected
*/
static void
validate_call (Expr e, void *data)
{
validate_arg *arg = (validate_arg *)data;
Expr callee_expr, cur_arg, next_arg;
FuncDcl func;
Key func_scope_key;
Type func_type, param_type, cur_arg_type;
Param param;
if (e && P_GetExprOpcode (e) == OP_call)
{
/* Get the callee function's type. */
callee_expr = P_GetExprOperands (e);
func_type = PST_ExprType (arg->ip_table, P_GetExprOperands (e));
/* We can only validate direct calls of defined functions. */
if (P_IsIndirectFunctionCall (e))
{
func_scope_key = PST_GetScopeFromEntryKey (arg->ip_table, func_type);
/* If we have an indirect call with unspecified parameters, we
* can't do anything more. */
if (PST_GetTypeParam (arg->ip_table, func_type) == NULL)
return;
}
else if (P_IsDirectFunctionCall (e))
{
func = PST_GetFuncDclEntry (arg->ip_table,
P_GetExprVarKey (callee_expr));
if (!P_TstFuncDclQualifier (func, VQ_DEFINED) || \
P_TstFuncDclQualifier (func, VQ_APP_ELLIPSIS))
goto done;
func_scope_key = \
PST_GetScopeFromEntryKey (arg->ip_table,
P_GetExprVarKey (callee_expr));
}
if (!PST_IsFunctionType (arg->ip_table, func_type))
P_punt ("validate.c:validate_call:%d e does not result in a\n"
"function type (%d, %d)", __LINE__, func_type.file,
func_type.sym);
/* Loop through the call arguments and the function parameters to
* determine if we need to do anything. */
cur_arg = P_GetExprSibling (callee_expr);
param = PST_GetTypeParam (arg->ip_table, func_type);
while (cur_arg && param)
{
bool arg_is_multi, arg_is_pointer, param_is_multi, param_is_pointer;
next_arg = P_GetExprNext (cur_arg);
param_type = P_GetParamKey (param);
cur_arg_type = PST_ExprType (arg->ip_table, cur_arg);
/* If the current param is a vararg, the call does not require
* repair. */
if (PST_IsVarargType (arg->ip_table, param_type))
goto done;
arg_is_multi = is_multi_type (arg->ip_table, cur_arg_type);
arg_is_pointer = is_pointer_type (arg->ip_table, cur_arg_type);
param_is_multi = is_multi_type (arg->ip_table, param_type);
param_is_pointer = is_pointer_type (arg->ip_table, param_type);
if (param_is_pointer && arg_is_pointer)
{
/* Build (t.field1 = cur_arg, t).field2 */
TypeDcl td = PST_GetTypeTypeDcl (arg->ip_table, param_type);
Type multi_type = Plink_GetTypeDclMultiType (td);
cur_arg = make_struct_pointer_multi (arg->ip_table, multi_type,
cur_arg);
cur_arg = make_dot (arg->ip_table, cur_arg, multi_type,
func_scope_key);
arg->must_flatten = TRUE;
}
else if (param_is_pointer && arg_is_multi)
{
/* Build (arg.field). */
cur_arg = make_dot (arg->ip_table, cur_arg, cur_arg_type,
func_scope_key);
arg->must_flatten = TRUE;
}
else if (param_is_multi && !arg_is_multi)
{
/* Build (t.field = cur_arg, t) */
make_struct_pointer_multi (arg->ip_table, param_type, cur_arg);
arg->must_flatten = TRUE;
}
else
{
/* If the argument type doesn't match the parameter type, cast
* it. */
if (PST_IsPointerType (arg->ip_table, param_type) && \
PST_IsIntegralType (arg->ip_table, cur_arg_type))
{
Key scope_key = PST_GetExprScope (arg->ip_table, cur_arg);
Expr cast = PST_ScopeNewExprWithOpcode (arg->ip_table,
scope_key, OP_cast);
P_ExprSwap (&cur_arg, &cast);
P_AppendExprOperands (cast, cur_arg);
PST_SetExprType (arg->ip_table, cast, param_type);
}
}
cur_arg = next_arg;
param = P_GetParamNext (param);
}
if (cur_arg || param)
{
if (cur_arg)
{
/* If there are too many arguments, we need to remove extra ones
* from the end. */
e->pragma = \
P_AppendPragmaNext (e->pragma,
P_NewPragmaWithSpecExpr ("PLV_REMOVE",
NULL));
remove_args (arg->ip_table, e, cur_arg);
arg->must_flatten = TRUE;
}
else if (param)
{
/* If there are too few arguments, we need to add extras to pad
* the call. */
e->pragma = \
P_AppendPragmaNext (e->pragma,
P_NewPragmaWithSpecExpr ("PLV_ADD", NULL));
add_args (arg->ip_table, e, param);
}
}
}
done:
return;
}
