char fortran_are_conformable_types(type_t* t1, type_t* t2)
{
t1 = no_ref(t1);
t2 = no_ref(t2);
if (fortran_get_rank_of_type(t1) == fortran_get_rank_of_type(t2))
return 1;
else if (fortran_get_rank_of_type(t1) == 1
|| fortran_get_rank_of_type(t2) == 1)
return 1;
else
return 0;
}
char fortran_is_array_type(type_t* t)
{
t = no_ref(t);
return is_array_type(t)
&& !fortran_is_character_type(t);
}
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));
}
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)));
}
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;
}
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;
}
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));
}
}
}
int main()
{
A a("my name is a");
A b = a; // vad är skillnaden
A c(a); // mellan dessa
A d; // tre tekniker
d = a;
A *aa = new A[5];
delete [] aa ; // Vad kommer att hända ?
no_ref(a); // Bildas temporära objekt ?
with_ref(a); // Bildas temporära objekt ?
return 0;
}
type_t* fortran_get_n_ranked_type(type_t* scalar_type, int rank, decl_context_t decl_context)
{
scalar_type = no_ref(scalar_type);
ERROR_CONDITION(fortran_is_array_type(scalar_type), "This is not a scalar type!", 0);
if (rank == 0)
{
return scalar_type;
}
else if (rank > 0)
{
return get_array_type(fortran_get_n_ranked_type(scalar_type, rank-1, decl_context), nodecl_null(), decl_context);
}
else
{
internal_error("Invalid rank %d\n", rank);
}
}
int main() {
std::cout << " ==== main ==== \n";
A a("my name is a");
std::cout << "\t\t &a=" << &a << "\n";
A b = a; // vad e skillnaden
A c(a); // mellan dessa
A d; // tre tekniker?
d = a;
std::cout << "\t\t Call no_ref(" << &a << ") =>" << std::endl;
no_ref(a); // Bildas temporära objekt?
std::cout << "\t\t Call no_ref(" << &a << ") => ok" << std::endl;
with_ref(a); // Bildas temporära objekt?
A *aa = new A[5];
delete aa; // Vad kommer att hända?
std::cout << " ==== main ==== END \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;
}
int main()
{
DEBUG("1. constructor with arg");
A a("my name is a");
DEBUG("2. assignment to new variable");
A b = a; // vad är skillnaden
DEBUG("3. copy construction");
A c(a); // mellan dessa
DEBUG("4. uninitialized variable");
A d; // tre tekniker?
DEBUG("5. assignment to variable");
d = a;
DEBUG("--------");
DEBUG("6. call by value");
no_ref(a); // Bildas temporära objekt?
DEBUG("7. call by reference");
with_ref(a); // Bildas temporära objekt?
DEBUG("---------");
DEBUG("8. Allocate vector, put in A*");
A *aa = new A[5];
DEBUG("9. Free A* that points to A[]");
delete aa; // Vad kommer att hända?
DEBUG("done!");
return 0;
}
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;
}
char fortran_is_character_type_or_pointer_to(type_t* t)
{
t = no_ref(t);
return fortran_is_pointer_to_character_type(t)
|| fortran_is_character_type(t);
}
