static thing_th *expand_bacros_in_this_level(thing_th *bacroSrc, thing_th *trace, thing_th *cur, thing_th *prev) { thing_th *bacr=NULL; thing_th *subs=NULL; while(cur) { subs=Cdr(cur); set_car(trace, cur); if(th_kind(Car(cur))==cons_k) return Cons(Car(cur), trace); if((bacr=Get(bacroSrc, sym(Car(cur))))) { if(!prev) { fprintf(stderr, "Can't expand bacro onto nothing.\n"); return NULL; } rejigger_cells(prev, Car(subs), bacr); subs=Cdr(subs); set_cdr(prev, subs); set_car(trace, subs); } else { prev=cur; } cur=subs; } return Cdr(trace); }
void add_bind_to_env(lisp_object* env, lisp_object* sym, lisp_object* obj) { lisp_object* tmp = create_cons(); //env must be ((dummy . dummy) (a . 1) (b . 3) ...) set_cdr(tmp, get_cdr(env)); set_cdr(get_cdr(env), tmp); set_car(tmp, create_cons()); set_car(get_car(tmp), sym); set_cdr(get_car(tmp), obj); return; }
static data_t *scan_assignment(data_t *env, const data_t *vars, data_t *vals, data_t *var, const data_t *val) { if(vars == NULL) return set_variable_value(var, val, get_enclosing_env(env)); if(is_equal(var, car(vars))) return set_car(vals, val); return scan_assignment(env, cdr(vars), cdr(vals), var, val); }
//speed from -50 to 50; angle from -90 to 90 void smart_car_set(int speed, int angle) { static unsigned int dir_FB, dir_LR; //dir_FB = 0, forward. dir_LR = 0, right static unsigned long pwm_fast, pwm_slow; if (speed){ if (speed < 0) { dir_FB = 1; speed = -1 * speed; } else { dir_FB = 0; } if (angle < 0) { dir_LR = 1; angle = -1 * angle; } else { dir_LR = 0; } pwm_fast = 6000 + speed * 80; pwm_slow = 6000 + speed * (80 - angle); } else { pwm_fast = 0; pwm_slow = 0; } set_car(dir_FB, dir_LR, pwm_fast, pwm_slow); }
lisp_object* LF_cons(lisp_object* obj) { lisp_object* cons = create_cons(); set_car(cons, get_car(obj)); set_cdr(cons, get_car(get_cdr(obj))); return cons; }
int test_cell() { cell *c[3]; symbol *x = new_symbol("x"); symbol *y = new_symbol("y"); integer *i = new_integer(10); integer *j = new_integer(20); c[0] = cons(x, i); c[1] = cons(x, i); c[2] = cons(y, j); assert(equal_symbol(car(c[0]), car(c[1]))); assert(!equal_symbol(car(c[0]), car(c[2]))); assert(equal_integer(cdr(c[0]), cdr(c[1]))); assert(!equal_integer(cdr(c[0]), cdr(c[2]))); set_car(c[1], y); assert(!equal_symbol(car(c[0]), car(c[1]))); assert(equal_symbol(car(c[1]), car(c[2]))); set_cdr(c[1], j); assert(!equal_integer(cdr(c[0]), cdr(c[1]))); assert(equal_integer(cdr(c[1]), cdr(c[2]))); assert(!equal_cell(c[0], c[1])); assert(equal_cell(c[1], c[2])); return 1; }
static thing_th *rejigger_with_left_as_cons(thing_th *left, thing_th *right, thing_th *bacro) { thing_th *arg1=Cons(Car(left), Cdr(left)); set_car(left, Atom(sym(bacro))); set_cdr(left, Cons(arg1, Cons(right, NULL))); return left; }
static thing_th *rejigger_with_left_as_atom(thing_th *left, thing_th *right, thing_th *bacro) { thing_th *bcall=Cons(Atom(sym(bacro)), Cons(Car(left), Cons(right, NULL))); set_car(left, bcall); return left; }
API value_t list_set(value_t list, int index, value_t value) { if (index < 0) return list; value_t node = list; while (index--) { node = cdr(node); } set_car(node, value); return list; }
static data_t *scan_define(data_t *vars, data_t *vals, data_t *var, const data_t *val, data_t *frame) { if(vars == NULL) { return add_binding_to_frame(var, val, frame); } if(is_equal(var, car(vars))) { set_car(vals, val); return (data_t*)val; } return scan_define(cdr(vars), cdr(vals), var, val, frame); }
static thing_th *inner_expand_bacros(thing_th *bacroSrc, thing_th *head) { thing_th *trace=Cons(head, NULL); thing_th *prev=NULL; while(trace) { trace=expand_bacros_in_this_level(bacroSrc, trace, Car(trace), prev); prev=Car(trace); set_car(trace, Cdr(Car(trace))); } return head; }
Cell define(Cell var, Cell val, Cell env) { Cell l = lookup(var, env); if (is_atom(l) && !is_eq(l, atom("#<unbound>"))) { fprintf(stderr, "can't redefine\n"); } //Cell binding = cons(var, val); Cell frame = car(env); set_car(frame, cons(var, car(frame))); set_cdr(frame, cons(val, cdr(frame))); return atom("#<void>"); }
static thing_th *inner_dup(thing_th *head) { if(!head) return NULL; if(Car(head)) set_car(head, dup_cell(Car(head))); if(Cdr(head)) set_cdr(head, dup_cell(Cdr(head))); inner_dup(Car(head)); inner_dup(Cdr(head)); return head; }
void create_env() { //env must be ((dummy . dummy) (a . 1) (b . 3) ...) env = create_cons(); set_car(env, create_cons()); set_cdr(env, create_empty_list()); add_bind_to_env(env, create_symbol("car"), create_subr(LF_car)); add_bind_to_env(env, create_symbol("cdr"), create_subr(LF_cdr)); add_bind_to_env(env, create_symbol("atom?"), create_subr(LF_cons)); add_bind_to_env(env, create_symbol("eq?"), create_subr(LF_eq)); add_bind_to_env(env, create_symbol("quote"), create_fsubr(LF_quote)); return; }
lisp_object* evls(lisp_object* arg, lisp_object* env) { lisp_object *op, *tmp, *ret; tmp = ret = create_cons(); add_protect(ret); for(op = arg; !null(op); op = get_cdr(op)){ set_cdr(tmp, create_cons()); tmp = get_cdr(tmp); add_protect(tmp); set_car(tmp,eval(op, env)); } set_cdr(tmp, create_empty_list()); return get_cdr(ret); }
static object_t *define_var(object_t *env, object_t *var, object_t *val) { object_t *frame = current_frame(env); object_t *vars = frame_vars(frame); object_t *vals = frame_vals(frame); while(!isemptylist(vars)) { if(var == car(vars)) { set_car(vals, eval(val, env)); return ok_symbol; } vars = cdr(vars); vals = cdr(vals); } frame_bind_var(current_frame(env), var, eval(val, env)); return ok_symbol; }
Cell set(Cell var, Cell val, Cell env) { while (!is_null(env)) { Cell frame = car(env); Cell vars = car(frame); Cell vals = cdr(frame); while (!is_null(vars)) { if (is_eq(car(vars), var)) { set_car(vals, val); return atom("#<void>"); } vars = cdr(vars); vals = cdr(vals); } env = cdr(env); } fprintf(stderr, "unbound variable\n"); }
void define_variable(item unev, item val, item env){ item frame = first_frame(env); item vars, vals; vars = frame_variables(frame); vals = frame_value(frame); while (1){ if (is_null(vars)){ add_binding_to_frame(unev, val, frame); break; } else if (eq(unev, car(vars))){ set_car(vals, val); break; } else{ vars = cdr(vars); vals = cdr(vals); } } }
void set_variable_value(item unev, item val, item env){ item vars, vals; while (!eq(env, the_empty_environment())){ vars = frame_variables(first_frame(env)); vals = frame_value(first_frame(env)); while (1){ if (is_null(vars)){ env = enclosing_environment(env); break; } else if (eq(unev, car(vars))){ set_car(vals, val); } else { vars = cdr(vars); vals = cdr(vals); } } } }
static action_t cont_fn() { ref_t formals = car(expr), body = cdr(expr); size_t arity = 0; bool rest = NO; if (!islist(formals)) error("invalid function: formals must be a list"); for(; !isnil(formals); arity++, formals = cdr(formals)) { ref_t sym = car(formals); if (sym == sym_amp) { if (length(cdr(formals)) != 1) error("invalid function: must have exactly one symbol after &"); rest = YES; set_car(formals, cadr(formals)); set_cdr(formals, NIL); break; } } formals = car(expr); pop_cont(); expr = lambda(formals, body, C(cont)->closure, arity, rest); return ACTION_APPLY_CONT; }
static data_t *add_binding_to_frame(data_t *var, const data_t *val, data_t *frame) { set_car(frame, (cons(var, car(frame)))); set_cdr(frame, (cons(val, cdr(frame)))); return (data_t*)val; }
Cell set_car_primitive(Cell arguments) { set_car(car(arguments), car(cdr(arguments))); return atom("#<void>"); }
void add_binding_to_frame(object *var, object *val, object *frame) { set_car(frame, cons(var, car(frame))); set_cdr(frame, cons(val, cdr(frame))); }
void frame_bind_var(object_t *frame, object_t *var, object_t *val) { set_car(frame, cons(var, car(frame))); set_cdr(frame, cons(val, cdr(frame))); }
void set_variable_value(object *var, object *val, object *env) { object *frame; object *vars; object *vals; object *prevals; while (!is_the_empty_list(env)) { frame = first_frame(env); vars = frame_variables(frame); vals = frame_values(frame); if (debug) { printf("\n---env\n"); write(stdout, env); printf("\n---frame\n"); write(stdout, frame); printf("\n---vars\n"); write(stdout, vars); printf("\n---vals\n"); write(stdout, vals); printf("\n---\n"); } while (!is_the_empty_list(vars)) { /* if (var == car(vars)) { */ /* set_car(vals, val); */ /* return; */ /* } */ if (is_pair(vars)) { // printf("ispair\n"); if (var == car(vars)) { if (debug) { printf("found match\n"); printf("\n---vals\n"); write(stdout, vals); } if (is_pair(vals)) { set_car(vals, val); return; } else /* TODO */ { set_cdr(prevals, cons(val, the_empty_list)); return; } } } else if(is_symbol(vars)) { if (debug) { printf("symbol\n"); fprintf(stderr, "2 searched symbol %s\n", var->data.symbol.value); fprintf(stderr, "last cdr symbol %s\n", vars->data.symbol.value); } if (var == vars) { if (debug) { printf("\n---vals\n"); write(stdout, vals); printf("\n---prevals\n"); write(stdout, prevals); } // assert(0); set_cdr(prevals, val); // return vals; return; } else { if (debug) { printf("\nx yes\n"); } // assert(0); break; } } vars = cdr(vars); prevals = vals; vals = cdr(vals); } env = enclosing_environment(env); } fprintf(stderr, "unbound variable, %s\n", var->data.symbol.value); exit(1); }
item base_set_car(item argl){ set_car(car(argl), car(cdr(argl))); return make_item("ok"); }
void add_binding_to_frame(item var, item val, item frame){ set_car(frame, cons(var, car(frame))); set_cdr(frame, cons(val, cdr(frame))); }
void define_variable(object *var, object *val, object *env) { object *frame; object *vars; object *vals; object *prevals; frame = first_frame(env); vars = frame_variables(frame); vals = frame_values(frame); while (!is_the_empty_list(vars)) { /* if (var == car(vars)) { */ /* set_car(vals, val); */ /* return; */ /* } */ if (is_pair(vars)) { // printf("ispair\n"); if (var == car(vars)) { if (debug) { printf("found match\n"); printf("\n---vals\n"); write(stdout, vals); } if (is_pair(vals)) { set_car(vals, val); return; } else { assert(0); } } } else if(is_symbol(vars)) { if (debug) { printf("symbol\n"); fprintf(stderr, "2 searched symbol %s\n", var->data.symbol.value); fprintf(stderr, "last cdr symbol %s\n", vars->data.symbol.value); } if (var == vars) { if (debug) { printf("\n---vals\n"); write(stdout, vals); printf("\n---prevals\n"); write(stdout, prevals); } // assert(0); set_cdr(prevals, val); // return vals; return; } else { printf("\nx yes\n"); // assert(0); break; } } vars = cdr(vars); prevals = vals; vals = cdr(vals); } add_binding_to_frame(var, val, frame); }
object_t primitive_set_car(object_t argl) { set_car(car(argl), car(cdr(argl))); return obj_new_symbol("ok"); }
object *set_car_proc(object *arguments) { set_car(car(arguments), cadr(arguments)); return ok_symbol(); }