// Finds the length of a cons cell
// Returns 0 if list is empty
// -1 if list is circular
// n if list's length is n
// -2-n if list's length is n and is dotted
int32_t cons_len(value_t val) {
int32_t len = 0;
// Uses Floyd's cycle finding algorithm
value_t fast, slow;
fast = slow = val;
while (true) {
if (IS_NIL(fast)) {
return len;
}
if (IS_CONS(fast) && !IS_NIL(AS_CONS(fast)->cdr) &&
!IS_CONS(AS_CONS(fast)->cdr)) {
return -2 - len;
}
fast = AS_CONS(fast)->cdr;
++len;
if (IS_NIL(fast)) {
return len;
}
if (IS_CONS(fast) && !IS_NIL(AS_CONS(fast)->cdr) &&
!IS_CONS(AS_CONS(fast)->cdr)) {
return -2 - len;
}
fast = AS_CONS(fast)->cdr;
slow = AS_CONS(slow)->cdr;
++len;
if (IS_EQ(fast, slow)) {
return -1;
}
}
}
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;
}
void print_list(uptr_t list) {
print_form(CAR(list));
if (CDR(list) != NIL) {
printf_P(PSTR(" "));
if (IS_CONS(CDR(list))) {
print_list(CDR(list));
} else {
printf_P(PSTR(". "));
print_form(CDR(list));
}
}
}
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;
}
