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_character_type(type_t* t)
{
t = no_ref(t);
return (is_array_type(t)
&& is_character_type(array_type_get_element_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;
}
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;
}
type_t* fortran_rebuild_array_type(type_t* rank0_type, type_t* array_type)
{
rank0_type = no_ref(rank0_type);
ERROR_CONDITION(!fortran_is_scalar_type(rank0_type)
&& !fortran_is_character_type(rank0_type), "Invalid rank0 type", 0);
if (!fortran_is_array_type(array_type))
{
return rank0_type;
}
else
{
type_t* t = fortran_rebuild_array_type(rank0_type, array_type_get_element_type(array_type));
if (array_type_has_region(array_type))
{
return get_array_type_bounds_with_regions(t,
array_type_get_array_lower_bound(array_type),
array_type_get_array_upper_bound(array_type),
array_type_get_array_size_expr_context(array_type),
// Why did we do this so difficult?
nodecl_make_range(
nodecl_shallow_copy(array_type_get_region_lower_bound(array_type)),
nodecl_shallow_copy(array_type_get_region_upper_bound(array_type)),
nodecl_shallow_copy(array_type_get_region_stride(array_type)),
fortran_get_default_integer_type(),
make_locus("", 0, 0)),
array_type_get_region_size_expr_context(array_type)
);
}
else if (array_type_with_descriptor(array_type))
{
return get_array_type_bounds_with_descriptor(t,
array_type_get_array_lower_bound(array_type),
array_type_get_array_upper_bound(array_type),
array_type_get_array_size_expr_context(array_type));
}
else
{
return get_array_type_bounds(t,
array_type_get_array_lower_bound(array_type),
array_type_get_array_upper_bound(array_type),
array_type_get_array_size_expr_context(array_type));
}
}
}
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;
}
int fortran_get_rank_of_type(type_t* t)
{
t = no_ref(t);
if (!fortran_is_array_type(t)
&& !fortran_is_pointer_to_array_type(t))
return 0;
if (fortran_is_pointer_to_array_type(t))
{
t = pointer_type_get_pointee_type(t);
}
int result = 0;
while (fortran_is_array_type(t))
{
result++;
t = array_type_get_element_type(t);
}
return result;
}
Type Type::array_element() const
{
return array_type_get_element_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;
}
