char fortran_equivalent_tk_types(type_t* t1, type_t* t2)
{
type_t* r1 = t1;
if (is_function_type(r1))
{
r1 = function_type_get_return_type(r1);
}
r1 = fortran_get_rank0_type_internal(r1, /* ignore pointer */ 1);
type_t* r2 = t2;
if (is_function_type(r2))
{
r2 = function_type_get_return_type(r2);
}
r2 = fortran_get_rank0_type_internal(r2, /* ignore pointer */ 1);
// Preprocess for character types
if (fortran_is_character_type(r1))
{
r1 = get_unqualified_type(array_type_get_element_type(r1));
}
if (fortran_is_character_type(r2))
{
r2 = get_unqualified_type(array_type_get_element_type(r2));
}
return equivalent_types(get_unqualified_type(r1), get_unqualified_type(r2));
}
/**
* Check if two function types are compatible.
*/
static bool function_types_compatible(const function_type_t *func1,
const function_type_t *func2)
{
const type_t* const ret1 = skip_typeref(func1->return_type);
const type_t* const ret2 = skip_typeref(func2->return_type);
if (!types_compatible(ret1, ret2))
return false;
if (func1->linkage != func2->linkage)
return false;
cc_kind_t cc1 = func1->calling_convention;
if (cc1 == CC_DEFAULT)
cc1 = default_calling_convention;
cc_kind_t cc2 = func2->calling_convention;
if (cc2 == CC_DEFAULT)
cc2 = default_calling_convention;
if (cc1 != cc2)
return false;
if (func1->variadic != func2->variadic)
return false;
/* can parameters be compared? */
if ((func1->unspecified_parameters && !func1->kr_style_parameters)
|| (func2->unspecified_parameters && !func2->kr_style_parameters))
return true;
/* TODO: handling of unspecified parameters not correct yet */
/* all argument types must be compatible */
function_parameter_t *parameter1 = func1->parameters;
function_parameter_t *parameter2 = func2->parameters;
for ( ; parameter1 != NULL && parameter2 != NULL;
parameter1 = parameter1->next, parameter2 = parameter2->next) {
type_t *parameter1_type = skip_typeref(parameter1->type);
type_t *parameter2_type = skip_typeref(parameter2->type);
parameter1_type = get_unqualified_type(parameter1_type);
parameter2_type = get_unqualified_type(parameter2_type);
if (!types_compatible(parameter1_type, parameter2_type))
return false;
}
/* same number of arguments? */
if (parameter1 != NULL || parameter2 != NULL)
return false;
return true;
}
LoadVariableExpression* NodeBuilder::load_var(VariableSymbol* var)
{
Type* rtype = get_unqualified_type(var->get_type());
if (!is_kind_of<DataType>(rtype)) {
trash(var);
SUIF_THROW(SuifException(String("Cannot make a LoadVariableExpression out of ") +
to_id_string(var) + " whose type " +
to_id_string(rtype) + " is not a data type."));
}
return create_load_variable_expression(_suif_env, to<DataType>(rtype), var);
}
LoadExpression* NodeBuilder::load(Expression* addr)
{
Type* ptype = get_unqualified_type(addr->get_result_type());
if (!is_kind_of<PointerType>(ptype)) {
trash(addr);
SUIF_THROW(SuifException(String("Cannot make a LoadExpression out of ") +
to_id_string(addr) + " whose type " +
to_id_string(ptype) + " is not a pointer type."));
}
Type* btype =
get_unqualified_type(to<PointerType>(ptype)->get_reference_type());
if (!is_kind_of<DataType>(btype)) {
trash(addr);
SUIF_THROW(SuifException(String("Cannot make a LoadExpression out of ") +
to_id_string(addr) + " whose type " +
to_id_string(ptype) + " is not a pointer to a DataType."));
}
DataType *dtype = to<DataType>(btype);
return create_load_expression(_suif_env, dtype, addr);
}
static type_t* adjust_type_for_parameter_type(type_t* orig)
{
type_t* result = get_unqualified_type(orig);
if (is_function_type(result))
{
result = get_pointer_type(result);
}
else if (is_array_type(result))
{
result = get_pointer_type(array_type_get_element_type(result));
}
return result;
}
/** Decide if the two types are the same modular qualification.
*/
bool NodeBuilder::is_same_type(Type* t1, Type* t2)
{
return (TypeHelper::is_isomorphic_type(get_unqualified_type(t1),
get_unqualified_type(t2)));
}
/** If t is a pointer type (after removing qualification), return the type
* it points to.
* Otherwise return 0.
*/
Type* NodeBuilder::get_pointed_to_type(Type* t)
{
Type* ptype = get_unqualified_type(t);
if (!is_kind_of<PointerType>(ptype)) return 0;
return to<PointerType>(ptype)->get_reference_type();
}
TL::Symbol new_function_symbol(
TL::Symbol current_function,
const std::string& name,
TL::Type return_type,
TL::ObjectList<std::string> parameter_names,
TL::ObjectList<TL::Type> parameter_types)
{
if (IS_FORTRAN_LANGUAGE && current_function.is_nested_function())
{
// Get the enclosing function
current_function = current_function.get_scope().get_related_symbol();
}
decl_context_t decl_context = current_function.get_scope().get_decl_context();
ERROR_CONDITION(parameter_names.size() != parameter_types.size(), "Mismatch between names and types", 0);
decl_context_t function_context;
if (IS_FORTRAN_LANGUAGE)
{
function_context = new_program_unit_context(decl_context);
}
else
{
function_context = new_function_context(decl_context);
function_context = new_block_context(function_context);
}
// Build the function type
int num_parameters = 0;
scope_entry_t** parameter_list = NULL;
parameter_info_t* p_types = new parameter_info_t[parameter_types.size()];
parameter_info_t* it_ptypes = &(p_types[0]);
TL::ObjectList<TL::Type>::iterator type_it = parameter_types.begin();
for (TL::ObjectList<std::string>::iterator it = parameter_names.begin();
it != parameter_names.end();
it++, it_ptypes++, type_it++)
{
scope_entry_t* param = new_symbol(function_context, function_context.current_scope, it->c_str());
param->entity_specs.is_user_declared = 1;
param->kind = SK_VARIABLE;
param->locus = make_locus("", 0, 0);
param->defined = 1;
param->type_information = get_unqualified_type(type_it->get_internal_type());
P_LIST_ADD(parameter_list, num_parameters, param);
it_ptypes->is_ellipsis = 0;
it_ptypes->nonadjusted_type_info = NULL;
it_ptypes->type_info = get_indirect_type(param);
}
type_t *function_type = get_new_function_type(
return_type.get_internal_type(),
p_types,
parameter_types.size());
delete[] p_types;
// Now, we can create the new function symbol
scope_entry_t* new_function_sym = NULL;
if (!current_function.get_type().is_template_specialized_type())
{
new_function_sym = new_symbol(decl_context, decl_context.current_scope, name.c_str());
new_function_sym->entity_specs.is_user_declared = 1;
new_function_sym->kind = SK_FUNCTION;
new_function_sym->locus = make_locus("", 0, 0);
new_function_sym->type_information = function_type;
}
else
{
scope_entry_t* new_template_sym = new_symbol(
decl_context, decl_context.current_scope, name.c_str());
new_template_sym->kind = SK_TEMPLATE;
new_template_sym->locus = make_locus("", 0, 0);
new_template_sym->type_information = get_new_template_type(
decl_context.template_parameters,
function_type,
uniquestr(name.c_str()),
decl_context, make_locus("", 0, 0));
template_type_set_related_symbol(new_template_sym->type_information, new_template_sym);
// The new function is the primary template specialization
new_function_sym = named_type_get_symbol(
template_type_get_primary_type(
new_template_sym->type_information));
}
function_context.function_scope->related_entry = new_function_sym;
function_context.block_scope->related_entry = new_function_sym;
new_function_sym->related_decl_context = function_context;
new_function_sym->entity_specs.related_symbols = parameter_list;
new_function_sym->entity_specs.num_related_symbols = num_parameters;
for (int i = 0; i < new_function_sym->entity_specs.num_related_symbols; ++i)
{
symbol_set_as_parameter_of_function(
new_function_sym->entity_specs.related_symbols[i], new_function_sym, /* parameter position */ i);
}
// Make it static
new_function_sym->entity_specs.is_static = 1;
// Make it member if the enclosing function is member
if (current_function.is_member())
{
new_function_sym->entity_specs.is_member = 1;
new_function_sym->entity_specs.class_type = current_function.get_class_type().get_internal_type();
new_function_sym->entity_specs.access = AS_PUBLIC;
::class_type_add_member(new_function_sym->entity_specs.class_type, new_function_sym);
}
if (current_function.is_inline())
new_function_sym->entity_specs.is_inline = 1;
// new_function_sym->entity_specs.is_defined_inside_class_specifier =
// current_function.get_internal_symbol()->entity_specs.is_defined_inside_class_specifier;
if (IS_FORTRAN_LANGUAGE && current_function.is_in_module())
{
scope_entry_t* module_sym = current_function.in_module().get_internal_symbol();
new_function_sym->entity_specs.in_module = module_sym;
P_LIST_ADD(
module_sym->entity_specs.related_symbols,
module_sym->entity_specs.num_related_symbols,
new_function_sym);
new_function_sym->entity_specs.is_module_procedure = 1;
}
return new_function_sym;
}
