void match(Process *process, Obj *env, Obj *value, Obj *attempts) {
Obj *p = attempts;
while(p && p->car) {
//printf("\nWill match %s with value %s\n", obj_to_string(p->car)->s, obj_to_string(value)->s);
Obj *new_env = obj_new_environment(env);
shadow_stack_push(process, new_env);
bool result = obj_match(process, new_env, p->car, value);
if(result) {
//printf("Match found, evaling %s in env\n", obj_to_string(p->cdr->car)->s); //, obj_to_string(new_env)->s);
eval_internal(process, new_env, p->cdr->car); // eval the following form using the new environment
Obj *pop = shadow_stack_pop(process); // new_env
if(eval_error) {
return;
}
assert(pop == new_env);
return;
}
if(!p->cdr) {
set_error("Uneven nr of forms in match.", attempts);
}
p = p->cdr->cdr;
Obj *e = shadow_stack_pop(process); // new_env
assert(e == new_env);
}
set_error("Failed to find a suitable match for: ", value);
}
void obj_set_meta(Obj *o, Obj *key, Obj *value) {
if(!o->meta) {
o->meta = obj_new_environment(NULL);
}
env_extend(o->meta, key, value);
}
// 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);
}
}
Process *process_new() {
Process *process = malloc(sizeof(Process));
process->dead = false;
process->final_result = NULL;
#if BYTECODE_EVAL
process->frame = 0;
#else
process->frame = -1;
#endif
process->bytecodeObj = NULL;
pop_stacks_to_zero(process);
process->global_env = obj_new_environment(NULL);
nil = obj_new_cons(NULL, NULL);
define("nil", nil);
lisp_false = obj_new_bool(false);
define("false", lisp_false);
lisp_true = obj_new_bool(true);
define("true", lisp_true);
lisp_quote = obj_new_symbol("quote");
define("quote", lisp_quote);
ampersand = obj_new_symbol("&");
define("&", ampersand);
dotdotdot = obj_new_symbol("dotdotdot");
define("dotdotdot", dotdotdot);
hash = obj_new_keyword("hash");
define("hash", hash);
lisp_NULL = obj_new_ptr(NULL);
define("NULL", lisp_NULL);
type_ref = obj_new_keyword("ref");
define("type_ref", type_ref);
type_int = obj_new_keyword("int");
define("type-int", type_int); // without this it will get GC'd!
type_bool = obj_new_keyword("bool");
define("type-bool", type_bool);
type_float = obj_new_keyword("float");
define("type-float", type_float);
type_double = obj_new_keyword("double");
define("type-double", type_double);
type_string = obj_new_keyword("string");
define("type-string", type_string);
type_symbol = obj_new_keyword("symbol");
define("type-symbol", type_symbol);
type_keyword = obj_new_keyword("keyword");
define("type-keyword", type_keyword);
type_foreign = obj_new_keyword("foreign");
define("type-foreign", type_foreign);
type_primop = obj_new_keyword("primop");
define("type-primop", type_primop);
type_env = obj_new_keyword("env");
define("type-env", type_env);
type_macro = obj_new_keyword("macro");
define("type-macro", type_macro);
type_lambda = obj_new_keyword("lambda");
define("type-lambda", type_lambda);
type_list = obj_new_keyword("list");
define("type-list", type_list);
type_void = obj_new_keyword("void");
define("type-void", type_void);
type_ptr = obj_new_keyword("ptr");
define("type-ptr", type_ptr);
type_char = obj_new_keyword("char");
define("type-char", type_char);
type_array = obj_new_keyword("array");
define("type-array", type_array);
type_ptr_to_global = obj_new_keyword("ptr-to-global");
define("type-ptr-to-global", type_ptr_to_global);
prompt = define("prompt", obj_new_string(PROMPT));
prompt_unfinished_form = define("prompt-unfinished-form", obj_new_string(PROMPT_UNFINISHED_FORM));
register_primop(process, "open", p_open_file);
register_primop(process, "save", p_save_file);
register_primop(process, "+", p_add);
register_primop(process, "-", p_sub);
register_primop(process, "*", p_mul);
register_primop(process, "/", p_div);
//register_primop(process, "mod", p_mod);
register_primop(process, "=", p_eq);
register_primop(process, "list", p_list);
register_primop(process, "array", p_array);
register_primop(process, "dictionary", p_dictionary);
register_primop(process, "str", p_str);
register_primop(process, "str-append!", p_str_append_bang);
register_primop(process, "str-replace", p_str_replace);
register_primop(process, "join", p_join);
register_primop(process, "register", p_register);
register_primop(process, "register-variable", p_register_variable);
register_primop(process, "register-builtin", p_register_builtin);
register_primop(process, "print", p_print);
register_primop(process, "println", p_println);
register_primop(process, "prn", p_prn);
register_primop(process, "def?", p_def_QMARK);
//register_primop(process, "system", p_system);
register_primop(process, "get", p_get);
register_primop(process, "get-maybe", p_get_maybe);
register_primop(process, "dict-set!", p_dict_set_bang);
register_primop(process, "dict-remove!", p_dict_remove_bang);
register_primop(process, "first", p_first);
register_primop(process, "rest", p_rest);
register_primop(process, "cons", p_cons);
register_primop(process, "cons-last", p_cons_last);
register_primop(process, "concat", p_concat);
register_primop(process, "nth", p_nth);
register_primop(process, "count", p_count);
register_primop(process, "map", p_map);
register_primop(process, "map-copy", p_map); // only matters when compiling to C
register_primop(process, "map2", p_map2);
register_primop(process, "filter", p_filter);
register_primop(process, "reduce", p_reduce);
register_primop(process, "apply", p_apply);
register_primop(process, "type", p_type);
register_primop(process, "<", p_lt);
register_primop(process, "env", p_env);
register_primop(process, "load-lisp", p_load_lisp);
register_primop(process, "load-dylib", p_load_dylib);
register_primop(process, "unload-dylib", p_unload_dylib);
register_primop(process, "read", p_read);
register_primop(process, "read-many", p_read_many);
register_primop(process, "code", p_code);
register_primop(process, "copy", p_copy);
register_primop(process, "now", p_now);
register_primop(process, "name", p_name);
register_primop(process, "symbol", p_symbol);
register_primop(process, "keyword", p_keyword);
register_primop(process, "error", p_error);
register_primop(process, "keys", p_keys);
register_primop(process, "values", p_values);
register_primop(process, "signature", p_signature);
register_primop(process, "eval", p_eval);
register_primop(process, "meta-set!", p_meta_set_BANG);
register_primop(process, "meta-get", p_meta_get);
register_primop(process, "meta-get-all", p_meta_get_all);
register_primop(process, "array-to-list", p_array_to_list);
register_primop(process, "array-of-size", p_array_of_size);
register_primop(process, "array-set!", p_array_set_BANG);
register_primop(process, "array-set", p_array_set);
register_primop(process, "gc", p_gc);
register_primop(process, "hash", p_hash);
register_primop(process, "delete", p_delete);
register_primop(process, "stop", p_stop);
register_primop(process, "parallell", p_parallell);
register_primop(process, "bytecode", p_bytecode);
register_primop(process, "eval-bytecode", p_bytecode_eval);
register_primop(process, "lookup-in-substs-fast", p_lookup_in_substs_fast);
register_primop(process, "replace-subst-from-right-fast", p_replace_subst_from_right_fast);
register_primop(process, "types-exactly-eq?", p_types_exactly_eq);
register_primop(process, "extend-substitutions-fast", p_extend_substitutions_fast);
register_primop(process, "sort-by-fast", p_sort_by);
Obj *abs_args = obj_list(type_int);
register_ffi_internal(process, "abs", (VoidFn)abs, abs_args, type_int, true);
Obj *exit_args = obj_list(type_int);
register_ffi_internal(process, "exit", (VoidFn)exit, exit_args, type_void, true);
Obj *getenv_args = obj_list(type_string);
register_ffi_internal(process, "getenv", (VoidFn)getenv, getenv_args, type_string, true);
//printf("Global env: %s\n", obj_to_string(env)->s);
return process;
}
