struct atom *eval_closure(struct atom *closure, struct atom *args,
struct env *env)
{
struct env *closure_env = closure->closure.env;
struct atom *param_value = args;
struct atom *param_name = CAR(closure->closure.params->list);
while (param_value && param_name)
{
struct atom *evaluated_param = eval(param_value, env);
closure_env = env_extend(closure_env, 1,
param_name->str.str, evaluated_param);
param_value = CDR(param_value);
param_name = CDR(param_name);
}
if (param_value && !param_name)
{
printf("error: incorrect number of arguments\n");
return &nil_atom;
}
if (!param_value && param_name)
{
printf("error: incorrect number of arguments\n");
return &nil_atom;
}
return eval(closure->closure.body, closure_env);
}
void global_env_extend(Obj *key, Obj *val) {
assert(global_env);
Obj *existing_binding = env_lookup_binding(global_env, key);
if(existing_binding->car) {
existing_binding->cdr = val;
} else {
env_extend(global_env, key, val);
}
}
void global_env_extend(Process *process, Obj *key, Obj *val) {
assert(process->global_env);
Obj *existing_binding = env_lookup_binding(process, process->global_env, key);
if(existing_binding->car) {
existing_binding->cdr = val;
}
else {
env_extend(process->global_env, key, val);
}
}
bool obj_match(Process *process, Obj *env, Obj *attempt, Obj *value) {
//printf("Matching %s with %s\n", obj_to_string(attempt)->s, obj_to_string(value)->s);
if(attempt->tag == 'C' && obj_eq(process, attempt->car, lisp_quote) && attempt->cdr && attempt->cdr->car) {
// Dubious HACK to enable matching on quoted things...
// Don't want to extend environment in this case!
Obj *quoted_attempt = attempt->cdr->car;
return obj_eq(process, quoted_attempt, value);
}
else if(attempt->tag == 'Y' && strcmp(attempt->s, "nil") == 0) {
// Using 'nil' on the left side of a match will bind the right side to that symbol, which is NOT what you want!
return obj_eq(process, value, nil);
}
else if(attempt->tag == 'Y') {
//printf("Binding %s to value %s in match.\n", obj_to_string(attempt)->s, obj_to_string(value)->s);
env_extend(env, attempt, value);
return true;
}
else if(attempt->tag == 'C' && value->tag == 'C') {
return obj_match_lists(process, env, attempt, value);
}
else if(attempt->tag == 'A' && value->tag == 'A') {
return obj_match_arrays(process, env, attempt, value);
}
else if(obj_eq(process, attempt, value)) {
return true;
}
else {
/* printf("attempt %s (%c) is NOT equal to value %s (%c)\n", */
/* obj_to_string(attempt)->s, */
/* attempt->tag, */
/* obj_to_string(value)->s, */
/* value->tag); */
return 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_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);
}
