// 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; }