void call_struct_constructor(Process *process, Obj *function, Obj **args, int arg_count) {
// Evaluation of a struct-definition (a dictionary) in function position (which means that it is used as a constructor)
Obj *name_obj = env_lookup(process, function, obj_new_keyword("name"));
assert_or_set_error(name_obj, "no key 'name' on struct definition: ", function);
char *name = name_obj->s;
Obj *struct_size_obj = env_lookup(process, function, obj_new_keyword("size"));
assert_or_set_error(struct_size_obj, "no key 'size' on struct definition: ", function);
int struct_size = struct_size_obj->i;
Obj *struct_member_count_obj = env_lookup(process, function, obj_new_keyword("member-count"));
assert_or_set_error(struct_member_count_obj, "no key 'member-count' on struct definition: ", function);
int member_count = struct_member_count_obj->i;
Obj *offsets_obj = env_lookup(process, function, obj_new_keyword("member-offsets"));
assert_or_set_error(offsets_obj, "no key 'member-offsets' on struct definition: ", function);
assert_or_set_error(offsets_obj->tag == 'A', "offsets must be an array: ", function);
Obj **offsets = offsets_obj->array;
Obj *member_types_obj = env_lookup(process, function, obj_new_keyword("member-types"));
assert_or_set_error(member_types_obj, "no key 'member-types' on struct definition: ", function);
assert_or_set_error(member_types_obj->tag == 'A', "member-types must be an array: ", function);
Obj **member_types = member_types_obj->array;
//printf("Will create a %s of size %d and member count %d.\n", name, size, member_count);
void *p = malloc(struct_size);
Obj *new_struct = obj_new_ptr(p);
shadow_stack_push(process, new_struct);
if(!new_struct->meta) {
new_struct->meta = obj_new_environment(NULL);
}
env_assoc(process, new_struct->meta, obj_new_keyword("type"), obj_new_keyword(name));
assert_or_set_error(!(arg_count < member_count), "Too few args to struct constructor: ", obj_new_string(name));
assert_or_set_error(!(arg_count > member_count), "Too many args to struct constructor: ", obj_new_string(name));
for(int i = 0; i < arg_count; i++) {
Obj *member_type = member_types[i];
int offset = offsets[i]->i;
if(args[i]->tag == 'V') {
assert_or_set_error(obj_eq(process, member_type, type_float), "Can't assign float to a member of type ", obj_to_string(process, member_type));
float *fp = (float *)(((char *)new_struct->void_ptr) + offset);
float f = args[i]->f32;
//printf("Setting member %d at offset %d to %f.\n", i, offset, f);
*fp = f;
}
else if(args[i]->tag == 'I') {
assert_or_set_error(obj_eq(process, member_type, type_int), "Can't assign int to a member of type ", obj_to_string(process, member_type));
int *xp = (int *)(((char *)new_struct->void_ptr) + offset);
int x = args[i]->i;
*xp = x;
}
else if(args[i]->tag == 'B') {
assert_or_set_error(obj_eq(process, member_type, type_bool), "Can't assign bool to a member of type ", obj_to_string(process, member_type));
bool *xp = (bool *)(((char *)new_struct->void_ptr) + offset);
bool x = args[i]->boolean;
*xp = x;
}
else if(args[i]->tag == 'Q') {
assert_or_set_error(!obj_eq(process, member_type, type_char), "Can't assign char to a member of type ", obj_to_string(process, member_type));
assert_or_set_error(!obj_eq(process, member_type, type_int), "Can't assign int to a member of type ", obj_to_string(process, member_type));
assert_or_set_error(!obj_eq(process, member_type, type_float), "Can't assign float to a member of type ", obj_to_string(process, member_type));
assert_or_set_error(!obj_eq(process, member_type, type_string), "Can't assign string to a member of type ", obj_to_string(process, member_type));
void **vp = (void **)(((char *)new_struct->void_ptr) + offset);
*vp = args[i]->void_ptr;
}
else if(args[i]->tag == 'S') {
assert_or_set_error(obj_eq(process, member_type, type_string), "Can't assign int to a member of type ", obj_to_string(process, member_type));
char **sp = (char **)(((char *)new_struct->void_ptr) + offset);
*sp = strdup(args[i]->s); // must strdup or the struct will ref Obj's on the stack that will get gc:ed
}
else if(args[i]->tag == 'T') {
assert_or_set_error(obj_eq(process, member_type, type_char), "Can't assign char to a member of type ", obj_to_string(process, member_type));
char *cp = (char *)(((char *)new_struct->void_ptr) + offset);
*cp = args[i]->character;
}
else if(args[i]->tag == 'A') {
//assert_or_set_error(obj_eq(member_type, type_array), "Can't assign array to a member of type ", obj_to_string(member_type));
// TODO: use this code for sending arrays to normal FFI functions too!!!
// TODO: use the SAME code for sending data to FFI and struct constructors.
// TODO: check that we send the expected type to the constructor
Array *a = obj_array_to_carp_array(process, args[i]);
if(!a) {
return;
}
void **ap = (void **)(((char *)new_struct->void_ptr) + offset);
*ap = a;
}
else {
eval_error = obj_new_string("Can't set member ");
char buffer[32];
sprintf(buffer, "%d", i);
obj_string_mut_append(eval_error, buffer);
obj_string_mut_append(eval_error, " of struct ");
obj_string_mut_append(eval_error, name);
obj_string_mut_append(eval_error, " to ");
obj_string_mut_append(eval_error, obj_to_string(process, args[i])->s);
obj_string_mut_append(eval_error, " (handled type).");
return;
}
}
shadow_stack_pop(process); // pop new_struct
stack_push(process, new_struct);
}
void call_foreign_function(Process *process, Obj *function, Obj **args, int arg_count) {
assert(function);
if(!function->funptr) {
eval_error = obj_new_string("Can't call foregin function, it's funptr is NULL. May be a stub function with just a signature?");
return;
}
assert(function->cif);
assert(function->arg_types);
assert(function->return_type);
// TODO: change name to 'arg_values' or something like that
void **values = calloc(sizeof(void*), arg_count);
assert(values);
#define assert_or_free_values_and_set_error(assertion, message, object) \
if(!(assertion)) { \
free(values); \
} \
assert_or_set_error((assertion), (message), (object));
Obj *p = function->arg_types;
for(int i = 0; i < arg_count; i++) {
if(p && p->cdr) {
assert(p->car);
Obj *type_obj = p->car;
// Handle ref types by unwrapping them: (:ref x) -> x
if(type_obj->tag == 'C' && type_obj->car && type_obj->cdr && type_obj->cdr->car && obj_eq(process, type_obj->car, type_ref)) {
type_obj = type_obj->cdr->car; // the second element of the list
}
args[i]->given_to_ffi = true; // This makes the GC ignore this value when deleting internal C-data, like inside a string
if(obj_eq(process, type_obj, type_int)) {
assert_or_free_values_and_set_error(args[i]->tag == 'I', "Invalid (expected int) type of arg: ", args[i]);
values[i] = &args[i]->i;
}
else if(obj_eq(process, type_obj, type_bool)) {
assert_or_free_values_and_set_error(args[i]->tag == 'B', "Invalid (expected bool) type of arg: ", args[i]);
bool b = args[i]->boolean;
values[i] = &b;
}
else if(obj_eq(process, type_obj, type_char)) {
assert_or_free_values_and_set_error(args[i]->tag == 'T', "Invalid (expected char) type of arg: ", args[i]);
char c = args[i]->character;
values[i] = &c;
}
else if(obj_eq(process, type_obj, type_float)) {
assert_or_free_values_and_set_error(args[i]->tag == 'V', "Invalid (expected float) type of arg: ", args[i]);
values[i] = &args[i]->f32;
}
else if(obj_eq(process, type_obj, type_double)) {
assert_or_free_values_and_set_error(args[i]->tag == 'W', "Invalid (expected double) type of arg: ", args[i]);
values[i] = &args[i]->f64;
}
else if(obj_eq(process, type_obj, type_string)) {
assert_or_free_values_and_set_error(args[i]->tag == 'S', "Invalid (expected string) type of arg: ", args[i]);
//args[i]->s = strdup(args[i]->s); // OBS! Duplicating string here. TODO: Think about if this is the correct thing to do!
values[i] = &args[i]->s;
}
else {
//printf("Calling function with expected parameter of type %s. Argument is of type %c.\n", obj_to_string(process, p->car)->s, args[i]->tag);
if(args[i]->tag == 'Q' /* || args[i]->tag == 'R' */) {
#ifdef CHECKING
if(args[i]->void_ptr == NULL || obj_eq(type_obj, obj_new_keyword("any"))) {
goto hack;
}
assert_or_free_values_and_set_error(args[i]->meta, "Argument is missing meta data: ", args[i]);
Obj *meta_type_tag = env_lookup(args[i]->meta, obj_new_keyword("type")); // TODO: make this keyword to a "singleton"
assert_or_free_values_and_set_error(meta_type_tag, "Argument is missing meta 'type' tag: ", args[i]);
bool eq = obj_eq(meta_type_tag, type_obj);
if(!eq) {
eval_error = obj_new_string("Invalid type of argument sent to function expecting '");
obj_string_mut_append(eval_error, obj_to_string(type_obj)->s);
obj_string_mut_append(eval_error, "' type: ");
obj_string_mut_append(eval_error, obj_to_string(meta_type_tag)->s);
return;
}
hack:;
#endif
values[i] = &args[i]->void_ptr;
}
else if(args[i]->tag == 'A') {
// TODO: Do some type checking here!!!
Array *a = obj_array_to_carp_array(process, args[i]);
if(eval_error) {
return;
}
assert(a);
values[i] = &a;
}
else if(args[i]->tag == 'F') {
values[i] = &args[i]->funptr;
}
else if(args[i]->tag == 'L') {
if(ALLOW_SENDING_LAMBDA_TO_FFI) {
//printf("Will call unbaked lambda from ffi function. Lambda should have types: %s\n", obj_to_string(type_obj)->s);
ffi_type *closure_args[1];
ffi_closure *closure;
void (*closure_fun_ptr)();
closure = ffi_closure_alloc(sizeof(ffi_closure), (void**)&closure_fun_ptr);
if (closure) {
/* Initialize the argument info vectors */
closure_args[0] = &ffi_type_pointer;
/* ffi_cif cif_static; */
/* ffi_cif *cif = &cif_static; */
/* ffi_prep_cif(cif, FFI_DEFAULT_ABI, 0, &ffi_type_void, closure_args); */
//printf("Type obj: %s\n", obj_to_string(type_obj)->s);
Obj *lambda_arg_types = type_obj->cdr->car;
Obj *lambda_return_type = type_obj->cdr->cdr->car;
int lambda_arg_count = 0;
Obj *p = lambda_arg_types;
while(p && p->car) {
p = p->cdr;
lambda_arg_count++;
}
ffi_cif *cif = create_cif(process, lambda_arg_types, lambda_arg_count, lambda_return_type, "TODO:proper-name");
Obj *lambda_arg = args[i];
LambdaAndItsType *lambda_and_its_type = malloc(sizeof(LambdaAndItsType)); // TODO: free!
lambda_and_its_type->lambda = lambda_arg; // the uncompiled lambda that was passed to the ffi function
lambda_and_its_type->signature = type_obj;
lambda_and_its_type->process = process;
typedef void (*LambdaCallback)(ffi_cif *, void *, void **, void *);
if (ffi_prep_closure_loc(closure, cif, (LambdaCallback)call_lambda_from_ffi, lambda_and_its_type, closure_fun_ptr) == FFI_OK) {
//printf("Closure preparation done.\n");
values[i] = &closure_fun_ptr;
}
else {
set_error("Closure prep failed. ", nil);
}
}
else {
set_error("Failed to allocate closure. ", nil);
}
} else {
free(values);
set_error("Can't send argument of lambda type (tag 'L') to ffi function, you need to compile it to a C function using (bake ...) first:\n", args[i]);
}
}
else {
free(values);
printf("INVALID ARG TYPE: %c\n", args[i]->tag);
printf("ARG: %s\n", obj_to_string(process, args[i])->s);
set_error("Can't send argument of invalid type to foreign function taking parameter of type ", p->car);
}
}
p = p->cdr;
}
else {
free(values);
set_error("Too many arguments to ", function);
}
}
if(p && p->car) {
free(values);
set_error("Too few arguments to ", function);
}
// Handle refs:
Obj *return_type = function->return_type;
if(return_type->tag == 'C' && return_type->car && return_type->cdr &&
return_type->cdr->car && obj_eq(process, return_type->car, type_ref)) {
return_type = return_type->cdr->car; // the second element of the list
}
void *result;
ffi_call(function->cif, function->funptr, &result, values);
Obj *obj_result = primitive_to_obj(process, result, return_type);
free(values);
if(!obj_result) {
printf("obj_result == NULL, return_type = %s\n", obj_to_string(process, return_type)->s);
return; // something went wrong
}
stack_push(process, obj_result);
}
