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));
}
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;
}
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_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));
}
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;
}
char is_sound_type(type_t* t, decl_context_t decl_context)
{
ERROR_CONDITION(t == NULL, "Invalid NULL here", 0);
if (is_array_type(t))
{
type_t* element_type = array_type_get_element_type(t);
if (is_void_type(element_type)
|| is_lvalue_reference_type(element_type)
|| is_function_type(element_type))
{
DEBUG_CODE()
{
fprintf(stderr, "TYPEORDER: Deduced type is not sound because it is an array of void/references/functions\n");
}
return 0;
}
type_t* fortran_replace_return_type_of_function_type(type_t* function_type, type_t* new_return_type)
{
ERROR_CONDITION(!is_function_type(function_type), "Must be a function type", 0);
int num_parameters = function_type_get_num_parameters(function_type);
if (!function_type_get_lacking_prototype(function_type))
{
parameter_info_t parameter_info[1 + num_parameters];
memset(¶meter_info, 0, sizeof(parameter_info));
int i;
for (i = 0; i < num_parameters; i++)
{
parameter_info[i].type_info = function_type_get_parameter_type_num(function_type, i);
}
return get_new_function_type(new_return_type, parameter_info, num_parameters);
}
else
{
return get_nonproto_function_type(new_return_type, num_parameters);
}
}
bool Symbol::is_template_function_name() const
{
return (this->_symbol->kind == SK_TEMPLATE
&& is_function_type(named_type_get_symbol(template_type_get_primary_type(_symbol->type_information))->type_information));
}
bool Type::is_function() const
{
return is_function_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;
}
static type_t* solve_spu_overload_name(scope_entry_t* overloaded_function, AST* arguments, int num_arguments)
{
// Why people insists on having overload in C?
char name[256];
// From gcc source at maximum 16 are defined
const int max_valid_overloads = 24;
char found_match = 0;
type_t* result = NULL;
DEBUG_CODE()
{
fprintf(stderr, "SPU-BUILTIN: Trying to figure out the exact version of '%s' given the following %d arguments\n",
overloaded_function->symbol_name,
num_arguments);
int j;
for (j = 0; j < num_arguments; j++)
{
fprintf(stderr, "SPU-BUILTIN: [%d] %s\n", j,
print_declarator(ASTExprType(arguments[j]),
overloaded_function->decl_context));
}
}
int i;
for (i = 0; (i < max_valid_overloads) && !found_match; i++)
{
snprintf(name, 255, "%s_%d", overloaded_function->symbol_name, i);
name[255] = '\0';
scope_entry_list_t *entry_list = query_unqualified_name_str(overloaded_function->decl_context, name);
// Let's assume no more overloads have been defined
if (entry_list == NULL)
{
break;
}
scope_entry_t* current_entry = entry_list->entry;
type_t* current_function_type = current_entry->type_information;
DEBUG_CODE()
{
fprintf(stderr, "SPU-BUILTIN: Checking with builtin '%s' of type '%s'\n",
current_entry->symbol_name,
print_declarator(current_function_type, overloaded_function->decl_context));
}
if (!is_function_type(current_function_type))
{
internal_error("spu builtin '%s' without function type\n", current_entry);
}
// Don't know if this case is considered but let's be kind with this crazy SDK
if (num_arguments != function_type_get_num_parameters(current_function_type))
{
continue;
}
int j;
char all_arguments_matched = 1;
for (j = 0; (j < num_arguments) && all_arguments_matched; j++)
{
type_t* argument_type = ASTExprType(arguments[j]);
all_arguments_matched = all_arguments_matched
&& equivalent_types(argument_type,
function_type_get_parameter_type_num(current_function_type, j),
overloaded_function->decl_context);
}
if (all_arguments_matched)
{
DEBUG_CODE()
{
fprintf(stderr, "SPU-BUILTIN: Builtin '%s' of type '%s' matched!\n",
current_entry->symbol_name,
print_declarator(current_function_type, overloaded_function->decl_context));
}
result = current_function_type;
found_match = 1;
}
}
return result;
}
