translation_unit_t* add_new_file_to_compilation_process(
compilation_file_process_t* current_file_process,
const char* file_path,
const char* output_file,
compilation_configuration_t* configuration,
int tag)
{
ERROR_CONDITION(tag < 0, "Invalid tag", 0);
translation_unit_t* translation_unit = NEW0(translation_unit_t);
// Initialize with the translation unit root tree
translation_unit->input_filename = uniquestr(file_path);
compilation_file_process_t *new_compiled_file = NEW0(compilation_file_process_t);
configuration->verbose = CURRENT_CONFIGURATION->verbose;
configuration->do_not_link = CURRENT_CONFIGURATION->do_not_link;
configuration->do_not_compile = CURRENT_CONFIGURATION->do_not_compile;
configuration->do_not_prettyprint = CURRENT_CONFIGURATION->do_not_prettyprint;
new_compiled_file->translation_unit = translation_unit;
new_compiled_file->compilation_configuration = configuration;
new_compiled_file->tag = tag;
if ((configuration->do_not_link
|| configuration->do_not_compile)
&& output_file != NULL)
{
translation_unit->output_filename = uniquestr(output_file);
}
// Give a fallback value
if (configuration->do_not_link
&& configuration->do_not_compile
&& translation_unit->output_filename == NULL)
{
translation_unit->output_filename = "-";
}
if (current_file_process == NULL)
{
P_LIST_ADD(compilation_process.translation_units,
compilation_process.num_translation_units,
new_compiled_file);
}
else
{
P_LIST_ADD(current_file_process->secondary_translation_units,
current_file_process->num_secondary_translation_units,
new_compiled_file);
}
return translation_unit;
}
// Set additional mcxx options
int config_set_options(struct compilation_configuration_tag* config, const char* index, const char* value)
{
int num;
const char** blank_separated_options = blank_separate_values(value, &num);
num++;
const char** real_options = calloc(num, sizeof(*real_options));
int i;
for (i = 1; i < num; i++)
{
real_options[i] = blank_separated_options[i - 1];
}
// Change the current configuration otherwise we will handle the parameters
// in the wrong profile
struct compilation_configuration_tag* previous = CURRENT_CONFIGURATION;
SET_CURRENT_CONFIGURATION(config);
real_options[0] = uniquestr("mcxx");
parse_arguments(num, real_options, /* from_command_line= */ 0, /* parse_implicits_only*/ 0);
// Restore the original one
SET_CURRENT_CONFIGURATION(previous);
return 0;
}
int config_add_preprocessor_prefix(struct compilation_configuration_tag* config, const char* index, const char* value)
{
const char *reserved[] = {
"gcc",
"mcc",
"mcxx",
/* sentinel */ NULL
};
int i;
for (i = 0; reserved[i] != NULL; i++)
{
if (strcasecmp(value, reserved[i]) == 0)
{
fprintf(stderr, "%s is a reserved pragma prefix\n", reserved[i]);
return 1;
}
}
// Reuse P_LIST_ADD
int num_prefixes = config->num_pragma_custom_prefix;
P_LIST_ADD(config->pragma_custom_prefix,
config->num_pragma_custom_prefix,
uniquestr(value));
// Allocate pragma directive info
pragma_directive_set_t* new_info = calloc(1, sizeof(*new_info));
P_LIST_ADD(config->pragma_custom_prefix_info,
num_prefixes, new_info);
return 0;
}
const char* get_unique_name(void)
{
static int num_var = 100;
char result[15];
snprintf(result, 14, "$.anon%05d", num_var);
return uniquestr(result);
}
tl_type_t tl_string(const char* str)
{
tl_type_t result;
result.kind = TL_STRING;
result.data._string = uniquestr(str);
return result;
}
std::string Type::get_declaration_with_parameters(Scope sc, const std::string& symbol_name,
ObjectList<std::string>& parameters, ObjectList<std::string>& parameter_attributes, TypeDeclFlags flags) const
{
int num_parameters = this->parameters().size();
const char** parameter_names = new const char*[num_parameters + 1];
const char** param_attributes = new const char*[num_parameters + 1];
for (int i = 0; i < num_parameters; i++)
{
parameter_names[i] = NULL;
param_attributes[i] = NULL;
}
int orig_size = parameters.size();
for (int i = 0; i < orig_size; i++)
{
parameter_names[i] = uniquestr(parameters[i].c_str());
param_attributes[i] = uniquestr(parameter_attributes[i].c_str());
}
const char* result = get_declaration_string(_type_info, sc._decl_context, symbol_name.c_str(),
"", 0, num_parameters, parameter_names, param_attributes, flags == PARAMETER_DECLARATION);
for (int i = 0; i < num_parameters; i++)
{
if (i < orig_size)
{
parameters[i] = parameter_names[i];
}
else
{
if (parameter_names[i] != NULL)
parameters.append(parameter_names[i]);
else
parameters.append("");
}
}
delete[] parameter_names;
delete[] param_attributes;
return result;
}
int config_add_compiler_phase(struct compilation_configuration_tag* config, const char* index, const char* value)
{
compiler_phase_loader_t* cl = calloc(1, sizeof(*cl));
cl->func = compiler_phase_loader;
cl->data = (void*)uniquestr(value);
P_LIST_ADD(config->phase_loader,
config->num_compiler_phases,
cl);
return 0;
}
const char* strappend(const char* orig, const char* appended)
{
int total = strlen(orig) + strlen(appended) + 1;
char append_tmp[total];
append_tmp[0] = '\0';
strcat(append_tmp, orig);
strcat(append_tmp, appended);
return uniquestr(append_tmp);
}
// Very minimal html stripping, DO NOT RELY ON IT FOR CRITICAL MISSIONS
static const char* mini_strip_html(const char* c)
{
if (c == NULL)
return "";
int size = strlen(c);
if (size == 0)
return "";
char output[size * 2];
const char *p = c;
char *q = output;
while (*p != '\0')
{
if (q >= &output[size * 2])
internal_error("string is too large for protection", 0);
// We only remove < and > but for sure there are many others to be
// removed
if (*p == '<')
{
if ((q + 3) >= &output[size * 2])
internal_error("string is too large for protection", 0);
*q = '&'; q++;
*q = 'l'; q++;
*q = 't'; q++;
*q = ';'; q++;
}
else if (*p == '>')
{
if ((q + 3) >= &output[size * 2])
internal_error("string is too large for protection", 0);
*q = '&'; q++;
*q = 'g'; q++;
*q = 't'; q++;
*q = ';'; q++;
}
else
{
*q = *p; q++;
}
p++;
}
*q = '\0';
return uniquestr(output);
}
const char* strtolower(const char* c)
{
if (c != NULL)
{
int n = strlen(c);
char result[n + 1];
int i;
for (i = 0; i < n; i++)
{
result[i] = tolower(c[i]);
}
result[n] = '\0';
return uniquestr(result);
}
return NULL;
}
void* extensible_struct_get_field(extensible_struct_t* extensible_struct,
const char* field_name)
{
if (extensible_struct->hash == NULL)
return NULL;
rb_red_blk_node* n = rb_tree_query(extensible_struct->hash, uniquestr(field_name));
if (n != NULL)
{
return rb_node_get_info(n);
}
else
{
return NULL;
}
}
compilation_configuration_t* new_compilation_configuration(
const char* name,
compilation_configuration_t* base)
{
compilation_configuration_t* result = xcalloc(1, sizeof(*result));
result->configuration_name = uniquestr(name);
result->base_configuration = base;
// Default target tools
result->target_objcopy = TARGET_OBJCOPY;
result->target_objdump = TARGET_OBJDUMP;
result->target_ar = TARGET_AR;
// Fortran default column widths
result->input_column_width = 72;
result->output_column_width = 132;
return result;
}
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;
}
// Set linker name
int config_set_linker_name(struct compilation_configuration_tag* config, const char* index, const char* value)
{
config->linker_name = uniquestr(value);
return 0;
}
TL::Symbol new_function_symbol(
TL::Symbol current_function,
const std::string& name,
TL::Type return_type,
TL::ObjectList<std::string> parameter_names,
TL::ObjectList<TL::Type> parameter_types)
{
if (IS_FORTRAN_LANGUAGE && current_function.is_nested_function())
{
// Get the enclosing function
current_function = current_function.get_scope().get_related_symbol();
}
decl_context_t decl_context = current_function.get_scope().get_decl_context();
ERROR_CONDITION(parameter_names.size() != parameter_types.size(), "Mismatch between names and types", 0);
decl_context_t function_context;
if (IS_FORTRAN_LANGUAGE)
{
function_context = new_program_unit_context(decl_context);
}
else
{
function_context = new_function_context(decl_context);
function_context = new_block_context(function_context);
}
// Build the function type
int num_parameters = 0;
scope_entry_t** parameter_list = NULL;
parameter_info_t* p_types = new parameter_info_t[parameter_types.size()];
parameter_info_t* it_ptypes = &(p_types[0]);
TL::ObjectList<TL::Type>::iterator type_it = parameter_types.begin();
for (TL::ObjectList<std::string>::iterator it = parameter_names.begin();
it != parameter_names.end();
it++, it_ptypes++, type_it++)
{
scope_entry_t* param = new_symbol(function_context, function_context.current_scope, it->c_str());
param->entity_specs.is_user_declared = 1;
param->kind = SK_VARIABLE;
param->locus = make_locus("", 0, 0);
param->defined = 1;
param->type_information = get_unqualified_type(type_it->get_internal_type());
P_LIST_ADD(parameter_list, num_parameters, param);
it_ptypes->is_ellipsis = 0;
it_ptypes->nonadjusted_type_info = NULL;
it_ptypes->type_info = get_indirect_type(param);
}
type_t *function_type = get_new_function_type(
return_type.get_internal_type(),
p_types,
parameter_types.size());
delete[] p_types;
// Now, we can create the new function symbol
scope_entry_t* new_function_sym = NULL;
if (!current_function.get_type().is_template_specialized_type())
{
new_function_sym = new_symbol(decl_context, decl_context.current_scope, name.c_str());
new_function_sym->entity_specs.is_user_declared = 1;
new_function_sym->kind = SK_FUNCTION;
new_function_sym->locus = make_locus("", 0, 0);
new_function_sym->type_information = function_type;
}
else
{
scope_entry_t* new_template_sym = new_symbol(
decl_context, decl_context.current_scope, name.c_str());
new_template_sym->kind = SK_TEMPLATE;
new_template_sym->locus = make_locus("", 0, 0);
new_template_sym->type_information = get_new_template_type(
decl_context.template_parameters,
function_type,
uniquestr(name.c_str()),
decl_context, make_locus("", 0, 0));
template_type_set_related_symbol(new_template_sym->type_information, new_template_sym);
// The new function is the primary template specialization
new_function_sym = named_type_get_symbol(
template_type_get_primary_type(
new_template_sym->type_information));
}
function_context.function_scope->related_entry = new_function_sym;
function_context.block_scope->related_entry = new_function_sym;
new_function_sym->related_decl_context = function_context;
new_function_sym->entity_specs.related_symbols = parameter_list;
new_function_sym->entity_specs.num_related_symbols = num_parameters;
for (int i = 0; i < new_function_sym->entity_specs.num_related_symbols; ++i)
{
symbol_set_as_parameter_of_function(
new_function_sym->entity_specs.related_symbols[i], new_function_sym, /* parameter position */ i);
}
// Make it static
new_function_sym->entity_specs.is_static = 1;
// Make it member if the enclosing function is member
if (current_function.is_member())
{
new_function_sym->entity_specs.is_member = 1;
new_function_sym->entity_specs.class_type = current_function.get_class_type().get_internal_type();
new_function_sym->entity_specs.access = AS_PUBLIC;
::class_type_add_member(new_function_sym->entity_specs.class_type, new_function_sym);
}
if (current_function.is_inline())
new_function_sym->entity_specs.is_inline = 1;
// new_function_sym->entity_specs.is_defined_inside_class_specifier =
// current_function.get_internal_symbol()->entity_specs.is_defined_inside_class_specifier;
if (IS_FORTRAN_LANGUAGE && current_function.is_in_module())
{
scope_entry_t* module_sym = current_function.in_module().get_internal_symbol();
new_function_sym->entity_specs.in_module = module_sym;
P_LIST_ADD(
module_sym->entity_specs.related_symbols,
module_sym->entity_specs.num_related_symbols,
new_function_sym);
new_function_sym->entity_specs.is_module_procedure = 1;
}
return new_function_sym;
}
Symbol Overload::solve(
ObjectList<Symbol> candidate_functions,
Type implicit_argument_type,
ObjectList<Type> argument_types,
const std::string filename,
int line,
bool &valid,
ObjectList<Symbol>& viable_functions,
ObjectList<Symbol>& argument_conversor)
{
valid = false;
// Try hard to not to do useless work
if (candidate_functions.empty())
{
return Symbol(NULL);
}
scope_entry_list_t* first_candidate_list = NULL;
// Build the candidates list
for (ObjectList<Symbol>::iterator it = candidate_functions.begin();
it != candidate_functions.end();
it++)
{
Symbol sym(*it);
first_candidate_list = entry_list_add(first_candidate_list, sym.get_internal_symbol());
}
// Build the type array
unsigned int i = argument_types.size();
type_t** argument_types_array = new type_t*[argument_types.size() + 1];
argument_types_array[0] = implicit_argument_type.get_internal_type();
for (i = 0; i < argument_types.size(); i++)
{
argument_types_array[i+1] = argument_types[i].get_internal_type();
}
// Now we need a decl_context_t but we were not given any explicitly,
// use the one of the first candidate
decl_context_t decl_context = candidate_functions[0].get_scope().get_decl_context();
// Unfold and mix!
scope_entry_list_t* candidate_list = NULL;
candidate_list = unfold_and_mix_candidate_functions(first_candidate_list,
NULL /* builtins */,
&argument_types_array[1], argument_types.size(),
decl_context,
uniquestr(filename.c_str()), line,
NULL /* explicit template arguments */);
{
ObjectList<Symbol> list;
Scope::convert_to_vector(candidate_list, list);
viable_functions.append(list);
}
candidate_t* candidate_set = NULL;
scope_entry_list_iterator_t* it = NULL;
for (it = entry_list_iterator_begin(candidate_list);
!entry_list_iterator_end(it);
entry_list_iterator_next(it))
{
scope_entry_t* entry = entry_list_iterator_current(it);
if (entry->entity_specs.is_member)
{
candidate_set = add_to_candidate_set(candidate_set,
entry,
argument_types.size() + 1,
argument_types_array);
}
else
{
candidate_set = add_to_candidate_set(candidate_set,
entry,
argument_types.size(),
argument_types_array + 1);
}
}
entry_list_iterator_free(it);
// We also need a scope_entry_t** for holding the conversor argument
scope_entry_t** conversor_per_argument = new scope_entry_t*[argument_types.size() + 1];
// Now invoke all the machinery
scope_entry_t* entry_result =
solve_overload(candidate_set,
decl_context,
uniquestr(filename.c_str()), line,
conversor_per_argument);
if (entry_result != NULL)
{
valid = true;
// Store the arguments
argument_conversor.clear();
for (i = 0; i < argument_types.size(); i++)
{
argument_conversor.append(Symbol(conversor_per_argument[i]));
}
}
// Free the conversor per argument
delete[] conversor_per_argument;
// Free the type array
delete[] argument_types_array;
// Free the scope entry list
free_scope_entry_list(candidate_list);
// This one has been allocated above
free_scope_entry_list(first_candidate_list);
return Symbol(entry_result);
}
void extensible_struct_set_field(extensible_struct_t* extensible_struct,
const char* field_name,
void *data)
{
rb_tree_insert(extensible_struct->hash, uniquestr(field_name), data);
}
void Symbol::set_name(std::string name)
{
_symbol->symbol_name = uniquestr(name.c_str());
}
int config_set_fortran_preprocessor_name(struct compilation_configuration_tag* config, const char* index, const char* value)
{
config->fortran_preprocessor_name = uniquestr(value);
return 0;
}
