void add_if(Process *process, Obj *env, Obj *bytecodeObj, int *position, Obj *form) {
assert_or_set_error(form->cdr->car, "Too few body forms in 'if' form: ", form);
assert_or_set_error(form->cdr->cdr->car, "Too few body forms in 'if' form: ", form);
assert_or_set_error(form->cdr->cdr->cdr->car, "Too few body forms in 'if' form: ", form);
assert_or_set_error(form->cdr->cdr->cdr->cdr->car == NULL, "Too many body forms in 'if' form (use explicit 'do').", form);
Obj *true_branch = form_to_bytecode(process, env, form->cdr->cdr->car);
Obj *false_branch = form_to_bytecode(process, env, form->cdr->cdr->cdr->car);
Obj *literals = bytecodeObj->bytecode_literals;
char new_literal_index = literals->count;
obj_array_mut_append(literals, true_branch);
obj_array_mut_append(literals, false_branch);
visit_form(process, env, bytecodeObj, position, form->cdr->car);
bytecodeObj->bytecode[*position] = 'i';
bytecodeObj->bytecode[*position + 1] = new_literal_index + 65;
*position += 2;
}
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_lambda_from_ffi(ffi_cif *cif, void *ret, void* args[], LambdaAndItsType *lambda_and_its_type) {
//printf("Calling lambda %s from ffi function!\n", obj_to_string(lambda_and_its_type->lambda)->s);
int arg_count = cif->nargs;
//printf("arg count: %d\n", arg_count);
Obj **obj_args = malloc(sizeof(Obj*) * arg_count);
//Obj *obj_args[arg_count];
Obj *lambda_type_signature = lambda_and_its_type->signature; // TODO: shadow stack?!
Obj *lambda_return_type = lambda_type_signature->cdr->cdr->car;
Obj *lambda_arg_type_list_p = lambda_type_signature->cdr->car;
//printf("Lambda signature: %s\n", obj_to_string(lambda_type_signature)->s);
Process *process = lambda_and_its_type->process;
for(int i = 0; i < arg_count; i++) {
Obj *lambda_arg_type_p = lambda_arg_type_list_p->car;
if(!lambda_arg_type_p) {
printf("Too many arguments (%d) sent to lambda with signature: %s\n", arg_count, obj_to_string(process, lambda_type_signature)->s);
eval_error = obj_new_string("Too many args.");
return;
}
// Unwrap ref args
if(lambda_arg_type_p->tag == 'C'
&& lambda_arg_type_p->car
&& lambda_arg_type_p->cdr && lambda_arg_type_p->cdr->car
&& obj_eq(process, lambda_arg_type_p->car, obj_new_keyword("ref")))
{
lambda_arg_type_p = lambda_arg_type_p->cdr->car; // the second element of the list
}
//printf("Lambda arg p: %s\n", obj_to_string(lambda_arg_type_p)->s);
if(cif->arg_types[i] == &ffi_type_sint) {
int *x = args[i];
obj_args[i] = obj_new_int(*x);
}
else if(cif->arg_types[i] == &ffi_type_float) {
float *x = args[i];
obj_args[i] = obj_new_float(*x);
}
else if(cif->arg_types[i] == &ffi_type_double) {
double *x = args[i];
obj_args[i] = obj_new_double(*x);
}
else if(cif->arg_types[i] == &ffi_type_schar) {
char *x = args[i];
obj_args[i] = obj_new_char(*x);
}
else {
if(obj_eq(process, lambda_arg_type_p, type_string)) {
char **x = args[i];
assert(*x);
char *new_s = strdup(*x);
//printf("new_s: %s\n", new_s);
obj_args[i] = obj_new_string(new_s);
}
else {
//printf("Lambda called from ffi with arg %d of type %s\n", i, obj_to_string(lambda_arg_type_p)->s);
/* printf("Can't handle arg type %p when calling ffi function.\n", cif->arg_types[i]); */
/* set_error("FFI function failed to call lambda: ", lambda_and_its_type->lambda); */
/* return; */
void **ptr = args[i];
obj_args[i] = obj_new_ptr(*ptr);
}
}
//printf("arg %d: %s\n", i, obj_to_string(obj_args[i])->s);
lambda_arg_type_list_p = lambda_arg_type_list_p->cdr;
//shadow_stack_push(obj_args[i]);
}
apply(process, lambda_and_its_type->lambda, obj_args, cif->nargs);
Obj *result = stack_pop(process);
free(obj_args);
// unwrap ref
if(lambda_return_type->tag == 'C' && lambda_return_type->car && lambda_return_type->cdr && lambda_return_type->cdr->car && obj_eq(process, lambda_return_type->car, obj_new_keyword("ref"))) {
lambda_return_type = lambda_return_type->cdr->car; // the second element of the list
}
// TODO: extract this and refactor to common helper function
if(obj_eq(process, lambda_return_type, type_int)) {
assert_or_set_error(result->tag == 'I', "Invalid type of return value: ", result);
int *integer = ret;
*integer = result->i;
}
else if(obj_eq(process, lambda_return_type, type_bool)) {
assert_or_set_error(result->tag == 'Y', "Invalid type of return value ", result);
bool b = is_true(result);
bool *boolean = ret;
*boolean = b;
}
else if(obj_eq(process, lambda_return_type, type_char)) {
assert_or_set_error(result->tag == 'T', "Invalid type of return value ", result);
char c = result->character;
char *character = ret;
*character = c;
}
else if(obj_eq(process, lambda_return_type, type_float)) {
assert_or_set_error(result->tag == 'V', "Invalid type of return value ", result);
float *x = ret;
*x = result->f32;
}
else if(obj_eq(process, lambda_return_type, type_double)) {
assert_or_set_error(result->tag == 'W', "Invalid type of return value ", result);
double *x = ret;
*x = result->f64;
}
else if(obj_eq(process, lambda_return_type, type_string)) {
assert_or_set_error(result->tag == 'S', "Invalid type of return value ", result);
char **s = ret;
*s = result->s;
}
else if(obj_eq(process, lambda_return_type, type_void)) {
}
else {
//set_error("Calling lambda from FFI can't handle return type ", lambda_return_type);
assert_or_set_error(result->tag == 'Q', "Invalid type of return value ", result);
void **p = ret;
*p = result->void_ptr;
}
/* for(int i = 0; i < arg_count; i++) { */
/* shadow_stack_pop(process); */
/* } */
}
