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);
}
}
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);
}
