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; }