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; } }
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; }
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_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)); } } }
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); } }
bool Type::is_fortran_array() const { return (fortran_is_array_type(_type_info)); }
char fortran_is_array_type_or_pointer_to(type_t* t) { return fortran_is_array_type(t) || fortran_is_pointer_to_array_type(t); }
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; }