int main(void) {
type_t tau;
init_type_table(&types, 0);
init_variables();
init_types();
// pair(A) = (tuple A A)
tau = pair_type(var[0], var[0]);
test_macro("pair", 1, var, tau);
// triple(B) = (tuple B B B)
tau = triple_type(var[1], var[1], var[1]);
test_macro("triple", 1, var+1, tau);
// test(C, D) = bool
test_macro("test", 2, var+2, base[0]);
// fun(E, F) = (-> (tuple E E) F)
tau = pair_type(var[4], var[4]);
tau = function_type(&types, var[5], 1, &tau);
test_macro("fun", 2, var+4, tau);
// two constructors
test_constructor("mk_type2", 2);
test_constructor("mk_type3", 3);
printf("\n====== TYPES ========\n");
print_type_table(stdout, &types);
printf("\n===== MACROS ========\n");
print_type_macros(stdout, &types);
printf("===\n\n");
// creation after remove
// vector[G] = (-> int G)
tau = int_type(&types);
tau = function_type(&types, var[6], 1, &tau);
test_macro("vector", 1, var+6, tau);
// matrix[H] = (-> int int H)
tau = int_type(&types);
tau = binary_ftype(tau, tau, var[7]);
test_macro("matrix", 1, var+7, tau);
printf("\n====== TYPES ========\n");
print_type_table(stdout, &types);
printf("\n===== MACROS ========\n");
print_type_macros(stdout, &types);
printf("===\n\n");
delete_type_table(&types);
return 0;
}
// [a, b -> c]
static type_t fun_type2(type_t a, type_t b, type_t c) {
type_t aux[2];
aux[0] = a;
aux[1] = b;
return function_type(&types, c, 2, aux);
}
/*
* Short cuts for type construction
*/
static type_t binary_ftype(type_t dom1, type_t dom2, type_t range) {
type_t a[2];
a[0] = dom1;
a[1] = dom2;
return function_type(&types, range, 2, a);
}
static type_t ternary_ftype(type_t dom1, type_t dom2, type_t dom3, type_t range) {
type_t a[3];
a[0] = dom1;
a[1] = dom2;
a[2] = dom3;
return function_type(&types, range, 3, a);
}
int MpiCallbacks::add(func_ptr_type fp) {
assert(fp != nullptr);
function_type f = function_type(fp);
const int id = add(f);
m_func_ptr_to_id[fp] = id;
return id;
}
SCM make_llvm_function(SCM scm_llvm, SCM scm_return_type, SCM scm_name, SCM scm_argument_types)
{
SCM retval;
struct llvm_module_t *llvm = get_llvm(scm_llvm);
struct llvm_function_t *self;
self = (struct llvm_function_t *)scm_gc_calloc(sizeof(struct llvm_function_t), "llvm function");
SCM_NEWSMOB(retval, llvm_function_tag, self);
self->builder = LLVMCreateBuilder();
char *name = scm_to_locale_string(scm_name);
self->function = LLVMAddFunction(llvm->module, name, function_type(scm_return_type, scm_argument_types));
LLVMSetFunctionCallConv(self->function, LLVMCCallConv);
free(name);
return retval;
}
SCM llvm_build_call(SCM scm_function, SCM scm_llvm, SCM scm_return_type, SCM scm_function_name, SCM scm_argument_types, SCM scm_values)
{
SCM retval;
struct llvm_function_t *function = get_llvm_function(scm_function);
struct llvm_module_t *llvm = get_llvm(scm_llvm);
char *function_name = scm_to_locale_string(scm_function_name);
LLVMValueRef function_pointer = LLVMAddFunction(llvm->module, function_name, function_type(scm_return_type, scm_argument_types));
free(function_name);
// LLVMAddFunctionAttr(function_pointer, LLVMExternalLinkage);
int n_values = scm_ilength(scm_values);
LLVMValueRef *values = scm_gc_malloc_pointerless(n_values * sizeof(LLVMValueRef), "llvm-build-call");
for (int i=0; i<n_values; i++) {
values[i] = get_llvm_value(scm_car(scm_values))->value;
scm_values = scm_cdr(scm_values);
};
struct llvm_value_t *result = (struct llvm_value_t *)scm_gc_calloc(sizeof(struct llvm_value_t), "llvmvalue");
SCM_NEWSMOB(retval, llvm_value_tag, result);
result->value = LLVMBuildCall(function->builder, function_pointer, values, n_values, "x");
return retval;
}
expv
compile_intrinsic_call(ID id, expv args) {
intrinsic_entry *ep = NULL;
int found = 0;
int nArgs = 0;
int nIntrArgs = 0;
int i;
expv ret = NULL;
expv a = NULL;
TYPE_DESC tp = NULL, ftp;
list lp;
INTR_OPS iOps = INTR_END;
const char *iName = NULL;
expv kindV = NULL;
int typeNotMatch = 0;
int isVarArgs = 0;
EXT_ID extid;
if (SYM_TYPE(ID_SYM(id)) != S_INTR) {
//fatal("%s: not intrinsic symbol", __func__);
// declarea as intrinsic but not defined in the intrinc table
SYM_TYPE(ID_SYM(id)) = S_INTR;
if (args == NULL) {
args = list0(LIST);
}
if (ID_TYPE(id) == NULL) implicit_declaration(id);
tp = ID_TYPE(id);
//tp = BASIC_TYPE_DESC(TYPE_SUBR);
expv symV = expv_sym_term(F_FUNC, NULL, ID_SYM(id));
ftp = function_type(tp);
TYPE_SET_INTRINSIC(ftp);
extid = new_external_id_for_external_decl(ID_SYM(id), ftp);
ID_TYPE(id) = ftp;
PROC_EXT_ID(id) = extid;
if (TYPE_IS_EXTERNAL(tp)){
ID_STORAGE(id) = STG_EXT;
}
else{
EXT_PROC_CLASS(extid) = EP_INTRINSIC;
}
ret = expv_cons(FUNCTION_CALL, tp, symV, args);
return ret;
}
ep = &(intrinsic_table[SYM_VAL(ID_SYM(id))]);
iOps = INTR_OP(ep);
iName = ID_NAME(id);
/* Count a number of argument, first. */
nArgs = 0;
if (args == NULL) {
args = list0(LIST);
}
FOR_ITEMS_IN_LIST(lp, args) {
nArgs++;
}
/* Search an intrinsic by checking argument types. */
found = 0;
for (;
((INTR_OP(ep) == iOps) &&
((strcasecmp(iName, INTR_NAME(ep)) == 0) ||
!(isValidString(INTR_NAME(ep)))));
ep++) {
kindV = NULL;
typeNotMatch = 0;
isVarArgs = 0;
/* Check a number of arguments. */
if (INTR_N_ARGS(ep) < 0 ||
INTR_N_ARGS(ep) == nArgs) {
/* varriable args or no kind arg. */
if (INTR_N_ARGS(ep) < 0) {
isVarArgs = 1;
}
nIntrArgs = nArgs;
} else if (INTR_HAS_KIND_ARG(ep) &&
((INTR_N_ARGS(ep) + 1) == nArgs)) {
/* could be intrinsic call with kind arg. */
expv lastV = expr_list_get_n(args, nArgs - 1);
if (lastV == NULL) {
return NULL; /* error recovery */
}
if (EXPV_KW_IS_KIND(lastV)) {
goto gotKind;
}
tp = EXPV_TYPE(lastV);
if (!(isValidType(tp))) {
return NULL; /* error recovery */
}
if (TYPE_BASIC_TYPE(tp) != TYPE_INT) {
/* kind arg must be integer type. */
continue;
}
gotKind:
nIntrArgs = INTR_N_ARGS(ep);
kindV = lastV;
} else {
continue;
}
/* The number of arguments matchs. Then check types. */
for (i = 0; i < nIntrArgs; i++) {
a = expr_list_get_n(args, i);
if (a == NULL) {
return NULL; /* error recovery */
}
tp = EXPV_TYPE(a);
if (!(isValidType(tp))) {
//return NULL; /* error recovery */
continue;
}
if (compare_intrinsic_arg_type(a, tp,
((isVarArgs == 0) ?
INTR_ARG_TYPE(ep)[i] :
INTR_ARG_TYPE(ep)[0])) != 0) {
/* Type mismatch. */
typeNotMatch = 1;
break;
}
}
if (typeNotMatch == 1) {
continue;
} else {
found = 1;
break;
}
}
if (found == 1) {
/* Yes we found an intrinsic to use. */
SYMBOL sp = NULL;
expv symV = NULL;
/* Then we have to determine return type. */
if (INTR_RETURN_TYPE(ep) != INTR_TYPE_NONE) {
tp = get_intrinsic_return_type(ep, args, kindV);
if (!(isValidType(tp))) {
//fatal("%s: can't determine return type.", __func__);
//return NULL;
tp = BASIC_TYPE_DESC(TYPE_GNUMERIC_ALL);
}
} else {
tp = BASIC_TYPE_DESC(TYPE_SUBR);
}
/* Finally find symbol for the intrinsic and make it expv. */
sp = find_symbol((char *)iName);
if (sp == NULL) {
fatal("%s: symbol '%s' is not created??",
__func__,
INTR_NAME(ep));
/* not reached */
return NULL;
}
symV = expv_sym_term(F_FUNC, NULL, sp);
if (symV == NULL) {
fatal("%s: symbol expv creation failure.", __func__);
/* not reached */
return NULL;
}
ftp = function_type(tp);
TYPE_SET_INTRINSIC(ftp);
/* set external id for functionType's type ID.
* dont call declare_external_id() */
extid = new_external_id_for_external_decl(ID_SYM(id), ftp);
ID_TYPE(id) = ftp;
PROC_EXT_ID(id) = extid;
if(TYPE_IS_EXTERNAL(tp)){
ID_STORAGE(id) = STG_EXT;
}else{
EXT_PROC_CLASS(extid) = EP_INTRINSIC;
}
ret = expv_cons(FUNCTION_CALL, tp, symV, args);
}
if (ret == NULL) {
error_at_node((expr)args,
"argument(s) mismatch for an intrinsic '%s()'.",
iName);
}
return ret;
}
// [a -> b]
static type_t fun_type1(type_t a, type_t b) {
return function_type(&types, b, 1, &a);
}
void
airport::BasicCrawler::add_observer(std::string &key, T t, std::string &module)
{
std::pair<function_type, std::string> p (function_type(t), module);
observers.insert( std::map<std::string, std::map<std::string, std::pair<function_type, std::string> > > :: value_type(key, p) );
}
