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();
}
