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);
}
static obj make_lambda_binding (obj params, obj args)
{
uint16_t len = internal_len (params);
if (len != internal_len (args))
throw_error (bad_argc);
if (len == 0)
return (obj_NIL);
obj res = new_extended_object (environment_type, 1 + 2 * len);
objhdr *p = get_header (res);
// protect res across the eval_internal() calls
p -> flags |= gc_fixed;
{
uint16_t i = 2;
while (params)
{
obj val;
decons (args, &val, &args);
val = eval_internal (val);
obj *bindings = p -> u.array_val;
decons (params, &bindings [i], ¶ms);
bindings [i + 1] = val;
i += 2;
}
}
p -> flags &= ~ gc_fixed;
return (res);
}
static obj make_argv (obj args, bool is_fexpr)
{
if (is_fexpr)
{
obj res = new_extended_object (array_type, 2);
obj *p = get_header (res) -> u.array_val;
p [1] = args;
p [2] = current_environment;
return (res);
}
else
{
uint16_t argc = internal_len (args);
obj res = new_extended_object (array_type, argc);
objhdr *p = get_header (res);
// protect res across the eval_internal() calls
p -> flags |= gc_fixed;
{
uint16_t i;
for (i = 1; i <= argc; i += 1)
{
obj car;
decons (args, &car, &args);
car = eval_internal (car);
p -> u.array_val [i] = car;
}
}
p -> flags &= ~ gc_fixed;
return (res);
}
}
Boxed_Value eval(chaiscript::detail::Dispatch_Engine &t_e)
{
try {
return eval_internal(t_e);
} catch (exception::eval_error &ee) {
ee.call_stack.push_back(shared_from_this());
throw ee;
}
}
obj fn_eval (obj args)
{
obj *argv = get_header (args) -> u.array_val;
switch (*argv)
{
case 1:
return (eval_internal (argv [1]));
case 2:
{
bool unprotect = save_env ();
obj keep_env = current_environment;
current_environment = argv [2];
obj res = eval_internal (argv [1]);
current_environment = keep_env;
if (unprotect)
get_header (current_environment) -> flags &= ~gc_fixed;
return (res);
}
default:
throw_error (bad_argc);
return (obj_NIL);
}
}
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);
}
}
