uptr_t eval(uptr_t *env, uptr_t form) {
if (IS_INT(form) || IS_NIL(form))
return form;
if (IS_SYM(form))
return get(*env, form);
if (IS_CONS(form)) {
uptr_t *form_p = refer(form),
*fn_p = refer(eval(env, CAR(*form_p))),
rval;
if (IS_SYM(*fn_p)) {
rval = exec_special(env, *form_p);
} else if (IS_CONS(*fn_p) && SVAL(CAR(*fn_p)) == S_FN) {
rval = _fn(env, *fn_p, eval_list(env, CDR(*form_p)));
} else {
printf_P(PSTR("ERROR: "));
print_form(CAR(*form_p));
printf_P(PSTR(" cannot be in function position.\n"));
rval = NIL;
}
release(2); // form_p, fn_p
return rval;
}
return NIL;
}
struct atom *builtin_define(struct atom *expr, struct env *env)
{
struct list *list = expr->list;
struct atom *op = LIST_FIRST(list);
struct atom *expr_name = CDR(op);
struct atom *expr_value = CDR(expr_name);
if (!expr_name || !expr_value)
{
printf("error: define takes two arguments\n");
return &nil_atom;
}
if (!IS_SYM(expr_name))
{
printf("error: define: first arg must be symbol\n");
return &nil_atom;
}
expr_value = eval(expr_value, env);
if (!env_set(env, expr_name->str.str, expr_value))
{
printf("error: cannot redefine %s\n", expr_name->str.str);
return &nil_atom;
}
return expr_value;
}
// Init class pointers and fix array layout
void vm_init_const_table_elems(void) {
uint8_t * ptr = const_table_g;
class_t * str_cls = vm_find_class("String");
class_t * arr_cls = vm_find_class("Array");
constant_array_t * c_arr;
int i;
kek_obj_t ** elems;
while (ptr != const_table_g + const_table_cnt_g) {
kek_obj_t * obj = (kek_obj_t*) ptr;
switch (obj->h.t) {
case KEK_NIL:
ptr += sizeof(kek_nil_t);
break;
case KEK_INT:
ptr += sizeof(kek_int_t);
break;
case KEK_STR:
obj->h.cls = str_cls;
ptr += sizeof(kek_string_t) + obj->k_str.length;
break;
case KEK_SYM:
if (obj->h.cls != NULL) {
// Parent class name index stored in cls pointer
assert(IS_SYM((kek_obj_t*) CONST((ptruint_t)obj->h.cls)));
obj->h.cls = vm_find_class(CONST((ptruint_t)obj->h.cls)->k_sym.symbol);
}
else {
obj->h.cls = vm_find_class(obj->k_sym.symbol);
}
ptr += sizeof(kek_symbol_t) + obj->k_sym.length;
break;
case KEK_ARR:
obj->h.cls = arr_cls;
c_arr = (constant_array_t*) obj;
elems = alloc_const_arr_elems(obj->k_arr.length);
//obj->k_arr.alloc_size = obj->k_arr.length;
for (i = 0; i < c_arr->length; ++i) {
elems[i] = CONST(c_arr->elems[i]);
}
obj->k_arr.elems = elems;
arr_set_alloc_size(&obj->k_arr, obj->k_arr.length);
assert(obj->k_arr.alloc_size > 0);
add_carray_to_gc_rootset(&obj->k_arr);
ptr += sizeof(constant_array_t)
+ (obj->k_arr.length - 1) * sizeof(uint32_t);
break;
case KEK_EXINFO:
ptr += sizeof(kek_exinfo_t)
+ (obj->k_exi.length - 1) * sizeof(try_range_t);
break;
default:
;
}
}
}
void print_form(uptr_t form) {
if (IS_NIL(form)) {
printf_P(PSTR("()"));
} else if (IS_REG(form)) {
printf_P(PSTR("R:%p"), TO_PTR(form));
} else if (IS_INT(form)) {
printf_P(PSTR("%d"), TO_INT(form));
} else if (IS_SYM(form)) {
char buf[7];
memset(buf, 0, 7);
unhash_sym(buf, form);
printf_P(PSTR("%s"), buf);
} else {
printf_P(PSTR("("));
print_list(form);
printf_P(PSTR(")"));
}
}
uptr_t loop(uptr_t *env, uptr_t form) {
uptr_t *bindings_p = refer(CAR(form)),
*body_p = refer(CDR(form)),
*form_p = refer(form),
*local_env = refer(*env);
while (*bindings_p) {
assoc(local_env, CAR(*bindings_p), eval(local_env, CADR(*bindings_p)));
*bindings_p = CDDR(*bindings_p);
}
// print_env(local_env);
uptr_t rval = NIL,
*new_env = refer(NIL),
*new_vals = refer(NIL);
while (*body_p) {
rval = eval(local_env, CAR(*body_p));
*body_p = CDR(*body_p);
if (IS_CONS(rval) && IS_SYM(CAR(rval)) && SVAL(CAR(rval)) == S_RECUR) {
*new_env = *env;
*new_vals = CDR(rval);
*bindings_p = CAR(*form_p);
while (*new_vals && *bindings_p) {
assoc(new_env, CAR(*bindings_p), eval(local_env, CAR(*new_vals)));
*bindings_p = CDDR(*bindings_p);
*new_vals = CDR(*new_vals);
}
*body_p = CDR(*form_p);
*local_env = *new_env;
}
}
release(6); // bindings_p, body_p, form_p, local_env, new_env, new_vals
return rval;
}
struct atom *eval(struct atom *expr, struct env *env)
{
// symbols and not-a-lists are evaluated or returned directly
if (IS_SYM(expr))
{
struct atom *atom = env_lookup(env, expr->str.str);
if (atom)
{
return atom;
}
else
{
printf("error: undefined variable: %s\n",
expr->str.str);
return &nil_atom;
}
}
if (!IS_LIST(expr))
return expr;
struct list *list = expr->list;
struct atom *op = LIST_FIRST(list);
// Check if the first elem is not a symbol or a closure. If it's
// not, then we'll evaluate it (it could be a lambda form).
if (!IS_SYM(op) && !IS_CLOSURE(op))
{
struct atom *evaluated_op = eval(op, env);
// Replace the evaluated one to the list!
LIST_REMOVE(op, entries);
LIST_INSERT_HEAD(list, evaluated_op, entries);
op = evaluated_op;
}
// If the first elem is a symbol, it should be a name for a builtin
// function or a closure bound to that name by the user. If the
// first argument is directly a closure, eval that with the args.
if (IS_SYM(op))
{
struct builtin_function_def *def = builtin_function_defs;
while (def->name && def->fn)
{
if (strcmp(op->str.str, def->name) == 0)
{
return def->fn(expr, env);
}
++def;
}
struct atom *closure = env_lookup(env, op->str.str);
if (closure)
{
return eval_closure(closure, CDR(op), env);
}
printf("error: unknown function %s\n", op->str.str);
}
else if (IS_CLOSURE(op))
{
return eval_closure(op, CDR(op), env);
}
printf("error: cannot evaluate\n");
return &nil_atom;
}