void stack_print(Process *process) {
printf("----- STACK -----\n");
for(int i = 0; i < process->stack_pos; i++) {
printf("%d\t%s\n", i, obj_to_string(process, process->stack[i])->s);
}
printf("----- END -----\n\n");
}
void repl(Process *process) {
while(1) {
/* int r = */ setjmp(jumpbuffer);
//printf("r = %d\n", r);
if(GC_COLLECT_BEFORE_REPL_INPUT) {
if(LOG_GC_POINTS) {
printf("Running GC before taking REPL input:\n");
}
gc(process);
}
if(prompt) {
printf("%s", prompt->cdr->s);
}
int read_offset = 0;
read_more:;
void *eof = fgets(input + read_offset, MAX_INPUT_BUFFER_SIZE - read_offset, stdin);
if(eof == NULL) {
break;
}
if(paren_balance(input) <= 0) {
process_reset(process);
eval_text(process, process->global_env, input, true, obj_new_string("repl"));
pop_stacks_to_zero(process);
printf("\n");
if(process->dead) {
break;
}
}
else {
//printf("Unbalanced, waiting for ending parenthesis.\n");
if(prompt_unfinished_form) {
printf("%s", prompt_unfinished_form->cdr->s);
}
read_offset = strlen(input);
goto read_more;
}
//assert(stack_pos == 0);
//stack_print();
if(parallell) {
process_tick(parallell);
printf("Ticked parallell process with result: %s\n", parallell->final_result ? obj_to_string(process, parallell->final_result)->s : "NULL");
if(parallell->final_result) {
parallell = NULL;
}
}
}
gc(process);
}
void stack_push(Process *process, Obj *o) {
assert(o);
if(LOG_STACK) {
printf("Pushing %s\n", obj_to_string(process, o)->s);
}
if(process->stack_pos >= STACK_SIZE) {
printf("Stack overflow:\n");
stack_print(process);
exit(1);
}
process->stack[process->stack_pos++] = o;
if(LOG_STACK) {
stack_print(process);
}
}
Obj *stack_pop(Process *process) {
if(eval_error) {
return nil;
}
if(process->stack_pos <= 0) {
printf("Stack underflow.\n");
assert(false);
}
if(LOG_STACK) {
printf("Popping %s\n", obj_to_string(process, process->stack[process->stack_pos - 1])->s);
}
Obj *o = process->stack[--process->stack_pos];
if(LOG_STACK) {
stack_print(process);
}
return o;
}
void obj_print(Obj *o) {
assert(o);
Obj *s = obj_to_string(o);
printf("%s", s->s);
}
void print_generic_array_or_struct(Obj *total, Obj *type_lookup, struct Obj *arg_to_str_obj) {
assert(total);
assert(total->tag == 'S');
assert(type_lookup);
assert(arg_to_str_obj);
shadow_stack_push(total);
shadow_stack_push(type_lookup);
shadow_stack_push(arg_to_str_obj);
Obj *reffed_arg_type = obj_list(obj_new_keyword("ref"), type_lookup); // HACK: ref needed when sending arrays into str
Obj *args_type = obj_list(reffed_arg_type);
Obj *signature = obj_list(obj_new_keyword("fn"), args_type, type_string);
Obj *quoted_sig = obj_list(lisp_quote, signature);
//printf("quoted_sig: %s\n", obj_to_string(quoted_sig)->s);
Obj *call_to_generic_name = obj_list(obj_new_symbol("generic-name"), obj_new_string("str"), quoted_sig);
shadow_stack_push(call_to_generic_name);
Obj *generic_name_result = eval(global_env, call_to_generic_name);
shadow_stack_push(generic_name_result);
if(eval_error) {
printf("Error when calling generic-name:\n");
printf("%s\n", obj_to_string(eval_error)->s);
return;
}
else {
//printf("Generic name: %s\n", obj_to_string_not_prn(generic_name_result)->s);
}
// Also make sure this particular version of the str primop has been baked:
Obj *call_to_bake_generic_primop_auto = obj_list(obj_new_symbol("bake-generic-primop-auto"), obj_new_string("str"), quoted_sig);
shadow_stack_push(call_to_bake_generic_primop_auto);
eval(global_env, call_to_bake_generic_primop_auto);
if(eval_error) {
printf("Error when calling bake-generic-primop-auto from print_generic_array_or_struct:\n");
printf("%s\n", obj_to_string(eval_error)->s);
function_trace_print();
return;
}
else {
//printf("%s should now exists\n", obj_to_string_not_prn(generic_name_result)->s);
}
char *generic_name = obj_to_string_not_prn(generic_name_result)->s;
//printf("generic_name 1: %s\n", generic_name);
Obj *call_to_str = obj_list(obj_new_symbol(generic_name), (struct Obj *)arg_to_str_obj);
// OBS!!!
//
// Calling obj_to_string on the call_to_str form will result in an infinite loop:
// printf("Call to str: %s\n", obj_to_string(call_to_str)->s);
//
// DON'T DO IT!!!
shadow_stack_push(call_to_str);
Obj *array_to_string_result = eval(global_env, call_to_str);
shadow_stack_push(array_to_string_result);
if(eval_error) {
printf("Error when calling str function for void ptr of type '%s':\n", obj_to_string(type_lookup)->s);
printf("%s\n", obj_to_string(eval_error)->s);
assert(false);
stack_pop();
obj_string_mut_append(total, "FAIL");
return;
}
obj_string_mut_append(total, obj_to_string_not_prn(array_to_string_result)->s);
Obj *pop1 = shadow_stack_pop();
assert(pop1 == array_to_string_result);
shadow_stack_pop();
shadow_stack_pop();
shadow_stack_pop();
shadow_stack_pop();
shadow_stack_pop();
shadow_stack_pop();
Obj *pop8 = shadow_stack_pop();
assert(pop8 == total);
return;
}
void obj_to_string_internal(Obj *total, const Obj *o, bool prn, int indent) {
assert(o);
int x = indent;
if(o->tag == 'C') {
obj_string_mut_append(total, "(");
x++;
int save_x = x;
const Obj *p = o;
while(p && p->car) {
obj_to_string_internal(total, p->car, true, x);
if(p->cdr && p->cdr->tag != 'C') {
obj_string_mut_append(total, " . ");
obj_to_string_internal(total, o->cdr, true, x);
break;
}
else if(p->cdr && p->cdr->car) {
if(/* p->car->tag == 'C' || */p->car->tag == 'E') {
obj_string_mut_append(total, "\n");
x = save_x;
add_indentation(total, x);
}
else {
obj_string_mut_append(total, " ");
x++;
}
}
p = p->cdr;
}
obj_string_mut_append(total, ")");
x++;
}
else if(o->tag == 'A') {
//printf("Will print Obj Array with count %d\n", o->count);
shadow_stack_push((struct Obj *)o);
x++;
//int save_x = x;
obj_string_mut_append(total, "[");
for(int i = 0; i < o->count; i++) {
obj_to_string_internal(total, o->array[i], true, x);
if(i < o->count - 1) {
/* if(o->array[i]->car->tag == 'Q' || o->array[i]->car->tag == 'E') { */
/* obj_string_mut_append(total, "\n"); */
/* x = save_x; */
/* add_indentation(total, x); */
/* } */
/* else { */
/* obj_string_mut_append(total, " "); */
/* x++; */
/* } */
obj_string_mut_append(total, " ");
}
}
obj_string_mut_append(total, "]");
shadow_stack_pop();
x++;
}
else if(o->tag == 'E') {
shadow_stack_push((struct Obj *)o);
obj_string_mut_append(total, "{");
x++;
Obj *p = o->bindings;
while(p && p->car) {
char *key_s = obj_to_string(p->car->car)->s;
obj_string_mut_append(total, key_s);
obj_string_mut_append(total, " ");
obj_to_string_internal(total, p->car->cdr, true, x + (int)strlen(key_s) + 1);
p = p->cdr;
if(p && p->car && p->car->car) {
obj_string_mut_append(total, ", \n");
add_indentation(total, x);
}
}
obj_string_mut_append(total, "}");
if(o->parent) {
obj_string_mut_append(total, " -> \n");
Obj *parent_printout = obj_to_string(o->parent);
obj_string_mut_append(total, parent_printout->s);
}
shadow_stack_pop();
}
else if(o->tag == 'I') {
static char temp[64];
snprintf(temp, 64, "%d", o->i);
obj_string_mut_append(total, temp);
}
else if(o->tag == 'V') {
static char temp[64];
snprintf(temp, 64, "%f", o->f32);
obj_string_mut_append(total, temp);
obj_string_mut_append(total, "f");
}
else if(o->tag == 'W') {
static char temp[64];
snprintf(temp, 64, "%f", o->f64);
obj_string_mut_append(total, temp);
}
else if(o->tag == 'S') {
if(prn) {
obj_string_mut_append(total, "\"");
}
obj_string_mut_append(total, o->s);
if(prn) {
obj_string_mut_append(total, "\"");
}
}
else if(o->tag == 'Y') {
obj_string_mut_append(total, o->s);
}
else if(o->tag == 'K') {
obj_string_mut_append(total, ":");
obj_string_mut_append(total, o->s);
}
else if(o->tag == 'P') {
obj_string_mut_append(total, "<primop:");
static char temp[256];
snprintf(temp, 256, "%p", o->primop);
obj_string_mut_append(total, temp);
if(o->meta) {
Obj *name = env_lookup(o->meta, obj_new_keyword("name"));
if(name) {
obj_string_mut_append(total, ":");
obj_string_mut_append(total, obj_to_string_not_prn(name)->s);
}
}
obj_string_mut_append(total, ">");
}
else if(o->tag == 'D') {
obj_string_mut_append(total, "<dylib:");
static char temp[256];
snprintf(temp, 256, "%p", o->primop);
obj_string_mut_append(total, temp);
obj_string_mut_append(total, ">");
}
else if(o->tag == 'Q') {
shadow_stack_push((struct Obj *)o);
Obj *type_lookup;
if(o->meta && (type_lookup = env_lookup(o->meta, obj_new_keyword("type")))) {
if(type_lookup->tag == 'C' && type_lookup->cdr->car && obj_eq(type_lookup->car, obj_new_keyword("Array"))) {
print_generic_array_or_struct(total, type_lookup, (struct Obj *)o);
}
else {
print_generic_array_or_struct(total, type_lookup, (struct Obj *)o);
/* obj_string_mut_append(total, "<ptr"); */
/* obj_string_mut_append(total, obj_to_string(type_lookup)->s); */
/* obj_string_mut_append(total, ">"); */
}
}
else {
obj_string_mut_append(total, "<ptr:");
static char temp[256];
snprintf(temp, 256, "%p", o->primop);
obj_string_mut_append(total, temp);
obj_string_mut_append(total, " of unknown type");
obj_string_mut_append(total, ">");
}
shadow_stack_pop();
}
else if(o->tag == 'F') {
obj_string_mut_append(total, "<ffi:");
static char temp[256];
snprintf(temp, 256, "%p", o->funptr);
obj_string_mut_append(total, temp);
if(o->meta) {
Obj *name = env_lookup(o->meta, obj_new_keyword("name"));
if(name) {
obj_string_mut_append(total, ":");
obj_string_mut_append(total, obj_to_string_not_prn(name)->s);
}
}
else {
}
obj_string_mut_append(total, ">");
}
else if(o->tag == 'L') {
if(setting_print_lambda_body) {
obj_string_mut_append(total, "(fn");
obj_string_mut_append(total, " ");
obj_string_mut_append(total, obj_to_string(o->params)->s);
obj_string_mut_append(total, " ");
obj_string_mut_append(total, obj_to_string(o->body)->s);
obj_string_mut_append(total, ")");
}
else {
obj_string_mut_append(total, "<lambda>");
}
}
else if(o->tag == 'M') {
if(setting_print_lambda_body) {
obj_string_mut_append(total, "(macro");
obj_string_mut_append(total, " ");
obj_string_mut_append(total, obj_to_string(o->params)->s);
obj_string_mut_append(total, " ");
obj_string_mut_append(total, obj_to_string(o->body)->s);
obj_string_mut_append(total, ")");
}
else {
obj_string_mut_append(total, "<macro>");
}
}
else if(o->tag == 'T') {
char s[2] = { o->character, '\0' };
if(prn) {
obj_string_mut_append(total, "\\");
}
obj_string_mut_append(total, s);
}
else if(o->tag == 'B') {
if(o->boolean) {
obj_string_mut_append(total, "true");
}
else {
obj_string_mut_append(total, "false");
}
}
else {
printf("obj_to_string() can't handle type tag %c (%d).\n", o->tag, o->tag);
assert(false);
}
}
void env_extend_with_args(Process *process, Obj *calling_env, Obj *function, int arg_count, Obj **args, bool allow_restargs) {
// TODO: remove the whole 'C' branch and only allow arrays for parameters
Obj *paramp = function->params;
if(paramp->tag == 'C') {
for(int i = 0; i < arg_count; i++) {
if(allow_restargs && obj_eq(process, paramp->car, dotdotdot)) {
printf("Found dotdotdot\n");
if(paramp->cdr->car) {
int rest_count = arg_count - i;
printf("Rest count: %d\n", rest_count);
Obj *rest_array = obj_new_array(rest_count);
for(int j = 0; j < rest_count; j++) {
rest_array->array[j] = args[i + j];
}
env_extend(calling_env, paramp->cdr->car, rest_array);
return;
}
else {
printf("No arguments after dotdotdot\n");
return;
}
}
if(!paramp || !paramp->car) {
set_error("Too many arguments (C) to function: ", function);
}
env_extend(calling_env, paramp->car, args[i]);
paramp = paramp->cdr;
}
if(paramp && paramp->cdr) {
set_error("Too few arguments to function: ", function);
}
}
else if(paramp->tag == 'A') {
int i = 0;
for(; i < arg_count; i++) {
if(allow_restargs && obj_eq(process, paramp->array[i], dotdotdot)) {
int rest_count = arg_count - i;
Obj *rest_list = obj_new_cons(NULL, NULL);
Obj *last = rest_list;
for(int j = 0; j < rest_count; j++) {
Obj *new_element = args[i + j];
last->car = new_element;
Obj *new_last = obj_new_cons(NULL, NULL);
last->cdr = new_last;
last = new_last;
}
env_extend(calling_env, paramp->array[i + 1], rest_list);
return;
}
env_extend(calling_env, paramp->array[i], args[i]);
}
if(i < paramp->count) {
if(allow_restargs && obj_eq(process, paramp->array[i], dotdotdot)) {
env_extend(calling_env, paramp->array[i + 1], obj_new_array(0));
}
else {
set_error("Too few arguments to function/macro: ", function);
}
}
if(arg_count > paramp->count) {
printf("arguments: %s\n", obj_to_string(process, paramp)->s);
//printf("meta: %s\n", (function->meta ? obj_to_string(process, function->meta)->s : "NULL"));
Obj *name = function;
if(function->meta) {
Obj *name_lookup = env_lookup(process, function->meta, obj_new_keyword("name"));
if(name_lookup) {
name = name_lookup;
}
}
set_error("Too many arguments (A) to function/macro: ", name);
}
}
}
void obj_print(Process *process, Obj *o) {
assert(o);
Obj *s = obj_to_string(process, o);
printf("%s", s->s);
}
void print_generic_array_or_struct(Process *process, Obj *total, Obj *type_lookup, struct Obj *arg_to_str_obj) {
assert(total);
assert(total->tag == 'S');
assert(type_lookup);
assert(arg_to_str_obj);
shadow_stack_push(process, total);
shadow_stack_push(process, type_lookup);
shadow_stack_push(process, arg_to_str_obj);
Obj *reffed_arg_type = obj_list(obj_new_keyword("ref"), type_lookup); // HACK: ref needed when sending arrays into str
Obj *args_type = obj_list(reffed_arg_type);
Obj *signature = obj_list(obj_new_keyword("fn"), args_type, type_string);
Obj *quoted_sig = obj_list(lisp_quote, signature);
//printf("quoted_sig: %s\n", obj_to_string(quoted_sig)->s);
Obj *generic_name_result = generic_name(process, "prn", quoted_sig);
if(eval_error) {
return;
}
shadow_stack_push(process, generic_name_result);
bake_generic_primop_auto(process, "prn", quoted_sig);
if(eval_error) {
return;
}
// TODO: why this conversion?
char *generic_name = obj_to_string_not_prn(process, generic_name_result)->s;
//printf("generic_name 1: %s\n", generic_name);
Obj *call_to_str = obj_list(obj_new_symbol(generic_name), (struct Obj *)arg_to_str_obj);
// OBS!!!
//
// Calling obj_to_string on the call_to_str form will result in an infinite loop:
// printf("Call to str: %s\n", obj_to_string(call_to_str)->s);
//
// DON'T DO IT!!!
shadow_stack_push(process, call_to_str);
Obj *array_to_string_result = NULL;
if(BYTECODE_EVAL) {
array_to_string_result = bytecode_sub_eval_form(process, process->global_env, call_to_str);
}
else {
array_to_string_result = eval(process, process->global_env, call_to_str);
}
shadow_stack_push(process, array_to_string_result);
if(eval_error) {
printf("Error when calling str function for void ptr of type '%s':\n", obj_to_string(process, type_lookup)->s);
printf("%s\n", obj_to_string(process, eval_error)->s);
assert(false);
stack_pop(process);
obj_string_mut_append(total, "FAIL");
return;
}
obj_string_mut_append(total, obj_to_string_not_prn(process, array_to_string_result)->s);
Obj *pop1 = shadow_stack_pop(process);
assert(pop1 == array_to_string_result);
shadow_stack_pop(process);
shadow_stack_pop(process);
shadow_stack_pop(process);
shadow_stack_pop(process);
Obj *pop8 = shadow_stack_pop(process);
assert(pop8 == total);
return;
}
void obj_to_string_internal(Process *process, Obj *total, const Obj *o, bool prn, int indent) {
assert(o);
int x = indent;
if(o->tag == 'C') {
obj_string_mut_append(total, "(");
x++;
int save_x = x;
const Obj *p = o;
while(p && p->car) {
obj_to_string_internal(process, total, p->car, true, x);
if(p->cdr && p->cdr->tag != 'C') {
obj_string_mut_append(total, " . ");
obj_to_string_internal(process, total, o->cdr, true, x);
break;
}
else if(p->cdr && p->cdr->car) {
if(/* p->car->tag == 'C' || */ p->car->tag == 'E') {
obj_string_mut_append(total, "\n");
x = save_x;
add_indentation(total, x);
}
else {
obj_string_mut_append(total, " ");
x++;
}
}
p = p->cdr;
}
obj_string_mut_append(total, ")");
x++;
}
else if(o->tag == 'A') {
//printf("Will print Obj Array with count %d\n", o->count);
shadow_stack_push(process, (struct Obj *)o);
x++;
//int save_x = x;
obj_string_mut_append(total, "[");
for(int i = 0; i < o->count; i++) {
obj_to_string_internal(process, total, o->array[i], true, x);
if(i < o->count - 1) {
/* if(o->array[i]->car->tag == 'Q' || o->array[i]->car->tag == 'E') { */
/* obj_string_mut_append(total, "\n"); */
/* x = save_x; */
/* add_indentation(total, x); */
/* } */
/* else { */
/* obj_string_mut_append(total, " "); */
/* x++; */
/* } */
obj_string_mut_append(total, " ");
}
}
obj_string_mut_append(total, "]");
shadow_stack_pop(process);
x++;
}
else if(o->tag == 'E') {
shadow_stack_push(process, (struct Obj *)o);
if(o == process->global_env) {
obj_string_mut_append(total, "{ GLOBAL ENVIRONMENT }");
return;
}
obj_string_mut_append(total, "{");
x++;
Obj *p = o->bindings;
while(p && p->car) {
char *key_s = obj_to_string(process, p->car->car)->s;
obj_string_mut_append(total, key_s);
obj_string_mut_append(total, " ");
obj_to_string_internal(process, total, p->car->cdr, true, x + (int)strlen(key_s) + 1);
p = p->cdr;
if(p && p->car && p->car->car) {
obj_string_mut_append(total, ", \n");
add_indentation(total, x);
}
}
obj_string_mut_append(total, "}");
if(o->parent) {
obj_string_mut_append(total, " -> \n");
Obj *parent_printout = obj_to_string(process, o->parent);
obj_string_mut_append(total, parent_printout->s);
}
shadow_stack_pop(process);
}
else if(o->tag == 'I') {
static char temp[64];
snprintf(temp, 64, "%d", o->i);
obj_string_mut_append(total, temp);
}
else if(o->tag == 'V') {
static char temp[64];
snprintf(temp, 64, "%f", o->f32);
obj_string_mut_append(total, temp);
obj_string_mut_append(total, "f");
}
else if(o->tag == 'W') {
static char temp[64];
snprintf(temp, 64, "%f", o->f64);
obj_string_mut_append(total, temp);
}
else if(o->tag == 'S') {
if(prn) {
obj_string_mut_append(total, "\"");
}
obj_string_mut_append(total, o->s);
if(prn) {
obj_string_mut_append(total, "\"");
}
}
else if(o->tag == 'Y') {
obj_string_mut_append(total, o->s);
}
else if(o->tag == 'K') {
obj_string_mut_append(total, ":");
obj_string_mut_append(total, o->s);
}
else if(o->tag == 'P') {
obj_string_mut_append(total, "<primop:");
static char temp[256];
snprintf(temp, 256, "%p", o->primop);
obj_string_mut_append(total, temp);
if(o->meta) {
Obj *name = env_lookup(process, o->meta, obj_new_keyword("name"));
if(name) {
obj_string_mut_append(total, ":");
obj_string_mut_append(total, obj_to_string_not_prn(process, name)->s);
}
}
obj_string_mut_append(total, ">");
}
else if(o->tag == 'D') {
obj_string_mut_append(total, "<dylib:");
static char temp[256];
snprintf(temp, 256, "%p", o->primop);
obj_string_mut_append(total, temp);
obj_string_mut_append(total, ">");
}
else if(o->tag == 'Q') {
shadow_stack_push(process, (struct Obj *)o);
Obj *type_lookup;
if(o->meta && (type_lookup = env_lookup(process, o->meta, obj_new_keyword("type")))) {
if(type_lookup->tag == 'C' && type_lookup->cdr->car && obj_eq(process, type_lookup->car, obj_new_keyword("Array"))) {
print_generic_array_or_struct(process, total, type_lookup, (struct Obj *)o);
}
else {
print_generic_array_or_struct(process, total, type_lookup, (struct Obj *)o);
/* obj_string_mut_append(total, "<ptr"); */
/* obj_string_mut_append(total, obj_to_string(type_lookup)->s); */
/* obj_string_mut_append(total, ">"); */
}
}
else {
obj_string_mut_append(total, "<ptr:");
static char temp[256];
snprintf(temp, 256, "%p", o->primop);
obj_string_mut_append(total, temp);
obj_string_mut_append(total, " of unknown type");
obj_string_mut_append(total, ">");
}
shadow_stack_pop(process);
}
else if(o->tag == 'R') {
shadow_stack_push(process, (struct Obj *)o);
if(!o->void_ptr) {
eval_error = obj_new_string("Pointer to global is NULL.\n");
return;
}
Obj *type_lookup;
//printf("o %p %p\n", o, o->void_ptr);
if(o->void_ptr == NULL) {
obj_string_mut_append(total, "NULL");
}
else if(o->meta && (type_lookup = env_lookup(process, o->meta, obj_new_keyword("type")))) {
//printf("type %s\n", obj_to_string(type_lookup)->s);
if(type_lookup->tag == 'C' && type_lookup->cdr->car && obj_eq(process, type_lookup->car, obj_new_keyword("Array"))) {
void *dereffed = *(void **)o->void_ptr;
assert(dereffed);
Obj *x = primitive_to_obj(process, dereffed, type_lookup);
shadow_stack_push(process, x);
obj_string_mut_append(total, obj_to_string(process, x)->s);
shadow_stack_pop(process); // x
}
else if(obj_eq(process, type_lookup, type_int)) {
//int i = 123;
void *dereffed = *(void **)o->void_ptr;
assert(dereffed);
Obj *x = primitive_to_obj(process, dereffed, type_int);
obj_string_mut_append(total, obj_to_string(process, x)->s);
}
else if(obj_eq(process, type_lookup, type_float)) {
//int i = 123;
void *dereffed = *(void **)o->void_ptr;
assert(dereffed);
Obj *x = primitive_to_obj(process, dereffed, type_float);
obj_string_mut_append(total, obj_to_string(process, x)->s);
}
else if(obj_eq(process, type_lookup, type_double)) {
void *dereffed = *(void **)o->void_ptr;
assert(dereffed);
Obj *x = primitive_to_obj(process, dereffed, type_double);
obj_string_mut_append(total, obj_to_string(process, x)->s);
}
else if(obj_eq(process, type_lookup, type_bool)) {
void *dereffed = *(void **)o->void_ptr;
// can't assert since false == NULL
Obj *x = primitive_to_obj(process, dereffed, type_bool);
obj_string_mut_append(total, obj_to_string(process, x)->s);
}
else if(obj_eq(process, type_lookup, type_string)) {
void *dereffed = *(void **)o->void_ptr;
assert(dereffed);
Obj *x = primitive_to_obj(process, dereffed, type_string);
obj_string_mut_append(total, x->s);
}
else if(obj_eq(process, type_lookup, type_char)) {
void *dereffed = *(void **)o->void_ptr;
assert(dereffed);
Obj *x = primitive_to_obj(process, dereffed, type_char);
obj_string_mut_append(total, obj_to_string(process, x)->s);
}
else {
void *dereffed = *(void **)o->void_ptr;
assert(dereffed);
Obj *x = primitive_to_obj(process, dereffed, type_lookup);
print_generic_array_or_struct(process, total, type_lookup, (struct Obj *)x);
/* obj_string_mut_append(total, "<ptr"); */
/* obj_string_mut_append(total, obj_to_string(type_lookup)->s); */
/* obj_string_mut_append(total, ">"); */
}
}
obj_string_mut_append(total, " ; ptr-to-global");
shadow_stack_pop(process);
}
else if(o->tag == 'F') {
obj_string_mut_append(total, "<ffi:");
static char temp[256];
snprintf(temp, 256, "%p", o->funptr);
obj_string_mut_append(total, temp);
if(o->meta) {
Obj *name = env_lookup(process, o->meta, obj_new_keyword("name"));
if(name) {
obj_string_mut_append(total, ":");
obj_string_mut_append(total, obj_to_string_not_prn(process, name)->s);
}
}
else {
}
obj_string_mut_append(total, ">");
}
else if(o->tag == 'L') {
if(setting_print_lambda_body) {
obj_string_mut_append(total, "(fn");
obj_string_mut_append(total, " ");
obj_string_mut_append(total, obj_to_string(process, o->params)->s);
obj_string_mut_append(total, " ");
obj_string_mut_append(total, obj_to_string(process, o->body)->s);
obj_string_mut_append(total, ")");
}
else {
obj_string_mut_append(total, "<lambda>");
}
}
else if(o->tag == 'M') {
if(setting_print_lambda_body) {
obj_string_mut_append(total, "(macro");
obj_string_mut_append(total, " ");
obj_string_mut_append(total, obj_to_string(process, o->params)->s);
obj_string_mut_append(total, " ");
obj_string_mut_append(total, obj_to_string(process, o->body)->s);
obj_string_mut_append(total, ")");
}
else {
obj_string_mut_append(total, "<macro>");
}
}
else if(o->tag == 'T') {
char s[2] = {o->character, '\0'};
if(prn) {
obj_string_mut_append(total, "\\");
}
obj_string_mut_append(total, s);
}
else if(o->tag == 'B') {
if(o->boolean) {
obj_string_mut_append(total, "true");
}
else {
obj_string_mut_append(total, "false");
}
}
else if(o->tag == 'X') {
obj_string_mut_append(total, "(\n");
for(char *p = o->bytecode; *p != '\0';) {
const int buffer_size = 128;
char buffer[buffer_size];
snprintf(buffer, buffer_size, "%4d ", (int)(p - o->bytecode));
obj_string_mut_append(total, buffer);
char c = *p;
p++;
if(c == 'l') {
snprintf(buffer, buffer_size, "LOAD LIT %d", *((int*)p));
p += sizeof(int);
}
else if(c == 'a') {
snprintf(buffer, buffer_size, "LOAD λ %d", *((int*)p));
p += sizeof(int);
}
else if(c == 'c') {
snprintf(buffer, buffer_size, "CALL %d", *((int*)p));
p += sizeof(int);
}
else if(c == 'd') {
snprintf(buffer, buffer_size, "DEFINE %d", *((int*)p));
p += sizeof(int);
}
else if(c == 'y') {
snprintf(buffer, buffer_size, "LOOKUP %d", *((int*)p));
p += sizeof(int);
}
else if(c == 'i') {
snprintf(buffer, buffer_size, "JUMP IF NOT %d", *((int*)p));
p += sizeof(int);
}
else if(c == 'j') {
snprintf(buffer, buffer_size, "JUMP %d", *((int*)p));
p += sizeof(int);
}
else if(c == 'r') {
snprintf(buffer, buffer_size, "RESET %d", *((int*)p));
p += sizeof(int);
}
else if(c == 't') {
snprintf(buffer, buffer_size, "LET %d", *((int*)p));
p += sizeof(int);
}
else if(c == 'e') {
snprintf(buffer, buffer_size, "DISCARD");
}
else if(c == 'g') {
snprintf(buffer, buffer_size, "CATCH");
}
else if(c == 'n') {
snprintf(buffer, buffer_size, "NOT");
}
else if(c == 'p') {
snprintf(buffer, buffer_size, "PUSH NIL");
}
else if(c == 'v') {
snprintf(buffer, buffer_size, "POP LET-SCOPE");
}
else if(c == 'x') {
snprintf(buffer, buffer_size, "DIRECT LOOKUP");
}
else if(c == 'q') {
snprintf(buffer, buffer_size, "END");
}
else {
snprintf(buffer, buffer_size, "UNHANDLED OP (%c)", *p);
p++;
}
obj_string_mut_append(total, buffer);
obj_string_mut_append(total, "\n");
}
obj_string_mut_append(total, "Literals: ");
obj_string_mut_append(total, obj_to_string(process, o->bytecode_literals)->s);
obj_string_mut_append(total, "\n");
obj_string_mut_append(total, ")");
}
else {
printf("obj_to_string() can't handle type tag %c (%d).\n", o->tag, o->tag);
assert(false);
}
}
// returns NULL if not done yet
Obj *bytecode_eval_internal(Process *process, Obj *bytecodeObj, int steps) {
Obj *literal, *function, *lookup, *result, *bindings, *let_env, *binding;
int arg_count, i, bindings_index, body_index;
for(int step = 0; step < steps; step++) {
if(eval_error) {
return nil;
}
Obj **literals_array = process->frames[process->frame].bytecodeObj->bytecode_literals->array;
char *bytecode = process->frames[process->frame].bytecodeObj->bytecode;
int p = process->frames[process->frame].p;
char c = bytecode[p];
//printf("frame = %d, c = %c\n", frame, c);
switch(c) {
case 'l':
i = bytecode[p + 1] - 65;
literal = literals_array[i];
//printf("Pushing literal "); obj_print_cout(literal); printf("\n");
stack_push(process, literal);
process->frames[process->frame].p += 2;
break;
case 'd':
i = bytecode[p + 1] - 65;
literal = literals_array[i];
result = env_extend(process->global_env, literal, stack_pop(process));
stack_push(process, result->cdr);
process->frames[process->frame].p += 2;
break;
case 'n':
if(is_true(stack_pop(process))) {
stack_push(process, lisp_false);
} else {
stack_push(process, lisp_true);
}
process->frames[process->frame].p += 1;
break;
case 'r':
i = bytecode[p + 1] - 65;
literal = literals_array[i];
binding = env_lookup_binding(process, process->frames[process->frame].env, literal);
if(binding->car) {
//printf("binding: %s\n", obj_to_string(process, binding)->s);
binding->cdr = stack_pop(process);
stack_push(process, binding->cdr);
} else {
eval_error = obj_new_string("reset! can't find variable to reset: ");
obj_string_mut_append(eval_error, obj_to_string(process, literal)->s);
return nil;
}
process->frames[process->frame].p += 2;
break;
case 't':
//printf("entering let\n");
//shadow_stack_push(process, let_env);
bindings_index = bytecode[p + 1] - 65;
body_index = bytecode[p + 2] - 65;
bindings = literals_array[bindings_index];
//printf("bindings: %s\n", obj_to_string(process, bindings)->s);
let_env = obj_new_environment(process->frames[process->frame].env);
for(int i = 0; i < bindings->count; i++) {
env_extend(let_env, bindings->array[i], stack_pop(process));
}
process->frames[process->frame].p += 3;
process->frames[process->frame + 1].p = 0;
process->frames[process->frame + 1].bytecodeObj = literals_array[body_index];
process->frames[process->frame + 1].env = let_env;
process->frame++;
//printf("will now execute: %s\n", obj_to_string(process, process->frames[process->frame].bytecodeObj)->s);
break;
case 'y':
i = bytecode[p + 1] - 65;
literal = literals_array[i];
//printf("Looking up literal "); obj_print_cout(literal); printf("\n");
lookup = env_lookup(process, process->frames[process->frame].env, literal);
if(!lookup) {
set_error_return_nil("Failed to lookup ", literal);
}
stack_push(process, lookup);
process->frames[process->frame].p += 2;
break;
case 'i':
i = bytecode[p + 1] - 65;
if(is_true(stack_pop(process))) {
process->frames[process->frame].p = 0;
process->frames[process->frame].bytecodeObj = literals_array[i];
process->frames[process->frame].env = process->frames[process->frame - 1].env;
}
else {
process->frames[process->frame].p = 0;
process->frames[process->frame].bytecodeObj = literals_array[i + 1];
process->frames[process->frame].env = process->frames[process->frame - 1].env;
}
break;
case 'c':
function = stack_pop(process);
arg_count = bytecode[p + 1] - 65;
Obj **args = NULL;
if(arg_count > 0) {
args = malloc(sizeof(Obj*) * arg_count);
}
for(int i = 0; i < arg_count; i++) {
Obj *arg = stack_pop(process);
args[arg_count - i - 1] = arg;
//shadow_stack_push(process, arg);
}
process->frames[process->frame].p += 2;
if(function->tag == 'P') {
stack_push(process, function->primop((struct Process*)process, args, arg_count));
}
else if(function->tag == 'F') {
call_foreign_function(process, function, args, arg_count);
}
else if(function->tag == 'K') {
if(arg_count != 1) {
eval_error = obj_new_string("Args to keyword lookup must be a single arg.");
}
else if(args[0]->tag != 'E') {
eval_error = obj_new_string("Arg 0 to keyword lookup must be a dictionary: ");
obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s);
}
else {
Obj *value = env_lookup(process, args[0], function);
if(value) {
stack_push(process, value);
} else {
eval_error = obj_new_string("Failed to lookup keyword '");
obj_string_mut_append(eval_error, obj_to_string(process, function)->s);
obj_string_mut_append(eval_error, "'");
obj_string_mut_append(eval_error, " in \n");
obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s);
obj_string_mut_append(eval_error, "\n");
}
}
}
else if(function->tag == 'L') {
Obj *calling_env = obj_new_environment(function->env);
//printf("arg_count = %d\n", arg_count);
env_extend_with_args(process, calling_env, function, arg_count, args, true);
process->frame++;
process->frames[process->frame].p = 0;
if(function->body->tag != 'X') {
set_error_return_nil("The body of the lambda must be bytecode, ", function);
}
process->frames[process->frame].bytecodeObj = function->body;
process->frames[process->frame].env = calling_env;
//printf("Pushing new stack frame with bytecode '%s'\n", process->frames[process->frame].bytecode); // and env %s\n", process->frames[process->frame].bytecode, obj_to_string(process, calling_env)->s);
}
else {
printf("Can't handle other calling methods yet %c\n", function->tag);
obj_print_cout(function);
return nil;
}
break;
case 'q':
process->frame--;
if(process->frame < 0) {
goto done;
}
break;
default:
printf("Unhandled instruction: %c\n", c);
exit(-1);
}
}
done:;
return stack_pop(process);
}
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 apply(Process *process, Obj *function, Obj **args, int arg_count) {
if(function->tag == 'L') {
//printf("Calling lambda "); obj_print_cout(function); printf(" with params: "); obj_print_cout(function->params); printf("\n");
//printf("Applying %s with arg count %d\n", obj_to_string(process, function)->s, arg_count);
#if BYTECODE_EVAL
Obj *calling_env = obj_new_environment(function->env);
bool allow_rest_args = true;
env_extend_with_args(process, calling_env, function, arg_count, args, allow_rest_args);
//printf("calling_env: %s\n", obj_to_string(process, calling_env)->s);
shadow_stack_push(process, function);
shadow_stack_push(process, calling_env);
/* printf("before\n"); */
/* shadow_stack_print(process); */
Obj *result = bytecode_sub_eval_internal(process, calling_env, function->body);
if(eval_error) {
return;
}
assert(result);
//printf("result = %s\n", obj_to_string(process, result)->s);
stack_push(process, result); // put it back on stack (TODO: fix this unnecessary work?)
/* printf("after\n"); */
/* shadow_stack_print(process); */
Obj *pop1 = shadow_stack_pop(process);
Obj *pop2 = shadow_stack_pop(process);
assert(pop1 == calling_env);
assert(pop2 == function);
#else
Obj *calling_env = obj_new_environment(function->env);
bool allow_rest_args = true;
env_extend_with_args(process, calling_env, function, arg_count, args, allow_rest_args);
//printf("Lambda env: %s\n", obj_to_string(calling_env)->s);
shadow_stack_push(process, function);
shadow_stack_push(process, calling_env);
if(function->body->tag == 'X') {
eval_error = obj_new_string("Can't apply lambda with bytecode body.");
}
else {
eval_internal(process, calling_env, function->body);
}
if(eval_error) {
return;
}
Obj *pop1 = shadow_stack_pop(process);
Obj *pop2 = shadow_stack_pop(process);
assert(pop1 == calling_env);
assert(pop2 == function);
#endif
}
else if(function->tag == 'P') {
Obj *result = function->primop((struct Process *)process, args, arg_count);
stack_push(process, result);
}
else if(function->tag == 'F') {
call_foreign_function(process, function, args, arg_count);
}
else if(function->tag == 'K') {
if(arg_count != 1) {
eval_error = obj_new_string("Args to keyword lookup must be a single arg.");
}
else if(args[0]->tag != 'E') {
eval_error = obj_new_string("Arg 0 to keyword lookup must be a dictionary: ");
obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s);
}
else {
Obj *value = env_lookup(process, args[0], function);
if(value) {
stack_push(process, value);
}
else {
eval_error = obj_new_string("Failed to lookup keyword '");
obj_string_mut_append(eval_error, obj_to_string(process, function)->s);
obj_string_mut_append(eval_error, "'");
obj_string_mut_append(eval_error, " in \n");
obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s);
obj_string_mut_append(eval_error, "\n");
}
}
}
else if(function->tag == 'E' && obj_eq(process, env_lookup(process, function, obj_new_keyword("struct")), lisp_true)) {
//printf("Calling struct: %s\n", obj_to_string(process, function)->s);
if(obj_eq(process, env_lookup(process, function, obj_new_keyword("generic")), lisp_true)) {
//printf("Calling generic struct constructor.\n");
Obj *function_call_symbol = obj_new_symbol("dynamic-generic-constructor-call");
shadow_stack_push(process, function_call_symbol);
Obj **copied_args = malloc(sizeof(Obj *) * arg_count);
for(int i = 0; i < arg_count; i++) {
copied_args[i] = obj_copy(process, args[i]);
if(args[i]->meta) {
copied_args[i]->meta = obj_copy(process, args[i]->meta);
}
}
Obj *carp_array = obj_new_array(arg_count);
carp_array->array = copied_args;
Obj *call_to_concretize_struct = obj_list(function_call_symbol,
function,
carp_array);
shadow_stack_push(process, call_to_concretize_struct);
eval_internal(process, process->global_env, call_to_concretize_struct);
shadow_stack_pop(process);
shadow_stack_pop(process);
}
else {
call_struct_constructor(process, function, args, arg_count);
}
}
else {
set_error("Can't call non-function: ", function);
}
}
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);
}
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); */
/* } */
}
