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;
}
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);
}
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;
}
static thing_th *identifyTypes(thing_th *args, thing_th *cur) {
while(args) {
cur=set_cdr(cur, Cons(String(debug_lbl(Car(args))), NULL));
args=Cdr(args);
}
return cur;
}
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);
}
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;
}
void append_in_place(pointer P, pointer V)
{
assert(is_type(P, DT_Pair));
if(cdr(P) == NIL)
set_cdr(P, V);
else
append_in_place(cdr(P), V);
}
static thing_th *safely_register_thing(thing_th *anon, thing_th *regMe) {
thing_th *attachMe;
if(!anon)
return NULL;
attachMe=Primordial_Cons(regMe, NULL, GC_SKIPREG);
set_cdr(anon, attachMe);
return attachMe;
}
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;
}
object_t parse_sexp2(char **in, object_t current) {
char *buf;
enum kind k = next_token(in, &buf);
object_t rest, s;
switch(k) {
case End:
return current;
case Left:
rest = parse_sexp2(in, NIL);
if(current == NULL)
return rest;
else if(current == NIL)
current = cons(rest, NIL);
else
storage_append(rest, current);
return parse_sexp2(in, current);
case Right:
return current;
case Period:
rest = parse_sexp2(in, NULL);
set_cdr(storage_last(current), rest);
return parse_sexp2(in, current);
case Single: /* following are reader-macros */
return wrap(in, current, "quote");
case Back:
return wrap(in, current, "quasiquote");
case Comma:
return wrap(in, current, "unquote");
case Symbol:
case String:
if(k == Symbol) {
if(all_digits(buf))
s = obj_new_number(atoi(buf));
else
s = obj_new_symbol(buf);
}
else if(k == String)
s = obj_new_string(buf);
if(current == NULL)
return s;
else if(current == NIL)
return parse_sexp2(in, cons(s, NIL));
else {
storage_append(s, current);
return parse_sexp2(in, current);
}
}
return NULL;
}
// in-place reverse.
API value_t list_ireverse(value_t list) {
value_t reversed = Nil;
while (list.type == PairType) {
pair_t pair = get_pair(list);
set_cdr(list, reversed);
reversed = list;
list = pair.right;
}
return reversed;
}
thing_th *insert(thing_th *left, thing_th *right) {
thing_th *tmp;
if(!left || !is_list(left))
return NULL;
if(!is_list(right))
right=Cons(right, NULL);
tmp=Cdr(left);
set_cdr(left, append(right, tmp));
return right;
}
// Same as non-recursive solution here:
// http://www.mytechinterviews.com/reverse-a-linked-list
object_t *reverse_list(object_t *list) {
object_t *temp, *previous = empty_list;
while(!isemptylist(list)) {
temp = cdr(list);
set_cdr(list, previous);
previous = list;
list = temp;
}
return previous;
}
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;
}
API value_t list_append(value_t list, value_t values) {
if (isNil(list)) return values;
value_t node = list;
while (node.type == PairType) {
value_t next = cdr(node);
if (isNil(next)) {
set_cdr(node, values);
return list;
}
node = next;
}
return Undefined;
}
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;
}
API value_t list_add(value_t list, value_t val) {
if (isNil(list)) return cons(val, Nil);
value_t node = list;
while (node.type == PairType) {
pair_t pair = get_pair(node);
if (eq(pair.left, val)) return list;
if (isNil(pair.right)) {
set_cdr(node, cons(val, Nil));
return list;
}
node = pair.right;
}
return TypeError;
}
Cons values2cons(Values vals)
{
Cons cur, head, pre;
values_t v;
pre = head = make_cons(lt_nil, lt_nil);
v = theVALUES(vals);
for (int i = 0; i < v->count; i++) {
cur = make_cons(v->objs[i], lt_nil);
set_cdr(pre, cur);
pre = cur;
}
return CDR(head);
}
API value_t list_remove(value_t list, value_t val) {
if (list.type != PairType) return Nil;
pair_t pair = get_pair(list);
if (eq(pair.left, val)) return pair.right;
value_t prev = list;
value_t node = pair.right;
while (node.type == PairType) {
pair = get_pair(node);
if (eq(pair.left, val)) {
set_cdr(prev, pair.right);
break;
}
node = pair.right;
}
return list;
}
Cons parse_cons(char *string, int *offset)
{
Cons cur, head, pre;
int step;
pre = head = make_cons(lt_nil, lt_nil);
for (int i = 0; string[i] != '\0'; i += step) {
switch (string[i]) {
case '(':
cur = make_cons(parse_cons(string + i + 1, &step), lt_nil);
break;
case ' ':
case '\n':
step = 1;
continue;
case ')':
*offset = i + 2;
pre = CDR(head);
free_cons(head);
return pre;
case '\'': {
/* Symbol quote; */
LispObject obj;
/* quote = S("QUOTE"); */
obj = parse_sexp(string + i + 1, &step);
/* cur = make_cons(make_cons(S("QUOTE"), make_cons(obj, lt_nil)), lt_nil); */
cur = make_cons(make_list(S("QUOTE"), obj), lt_nil);
step++;
break;
}
default :
cur = make_cons(parse_atom(string + i, &step), lt_nil);
}
set_cdr(pre, cur);
pre = cur;
}
pre = CDR(head);
free_cons(head);
return pre;
}
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;
}
object_t primitive_set_cdr(object_t argl) {
set_cdr(car(argl), car(cdr(argl)));
return obj_new_symbol("ok");
}
static obj_t parse_list(struct Parser *st)
{
struct location op = st->token.loc;
obj_t head = unspecific;
obj_t tail = unspecific;
struct token *t;
t = peek(st);
switch (t->type) {
case END:
reportlocf(st->rep, op, "unmatched parenthesis");
return unspecific;
case CPAREN:
/* empty list */
next(st);
return null_obj;
case DOT:
reportlocf(st->rep, t->loc, "cannot start list with dot");
tail = cons(unspecific, unspecific);
goto read_tail;
default:
head = tail = cons(parse_atom(st), unspecific);
goto read_tail;
}
read_tail:
t = peek(st);
switch (t->type) {
case END:
reportlocf(st->rep, op, "unmatched parenthesis");
return unspecific;
case CPAREN:
/* end of list */
next(st);
set_cdr(tail, null_obj);
return head;
case DOT:
next(st);
goto read_last;
default: {
obj_t cell = cons(parse_atom(st), unspecific);
set_cdr(tail, cell);
tail = cell;
goto read_tail;
}
}
read_last:
t = peek(st);
switch (t->type) {
case END:
reportlocf(st->rep, op, "unmatched parenthesis");
return unspecific;
case CPAREN:
reportlocf(st->rep, t->loc, "missing datum after dot");
next(st);
return unspecific;
case DOT:
reportlocf(st->rep, t->loc, "missing datum after dot");
goto read_close;
default:
set_cdr(tail, parse_atom(st));
goto read_close;
}
read_close:
t = peek(st);
switch (t->type) {
case END:
reportlocf(st->rep, op, "unmatched parenthesis");
return unspecific;
case CPAREN:
next(st);
return head;
case DOT:
reportlocf(st->rep, t->loc, "multiple dost in list");
next(st);
goto read_close;
default:
reportlocf(st->rep, t->loc, "extra datum after dot");
parse_atom(st);
goto read_close;
}
}
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 *set_cdr_proc(object *arguments) {
set_cdr(car(arguments), cadr(arguments));
return ok_symbol();
}
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)));
}
item base_set_cdr(item argl){
set_cdr(car(argl), car(cdr(argl)));
return make_item("ok");
}
Value * evaluate(Environment *env, Value *expr) {
EvaluationContext *ctx;
Value *temp, *result;
Value *operator;
Value *operand_val, *operand_cons;
Value *operands, *operands_end, *nil_value;
int num_operands;
/* Set up a new evaluation context and record our local variables, so that
* the garbage-collector can see any temporary values we use.
*/
ctx = push_new_evalctx(env, expr);
evalctx_register(&temp);
evalctx_register(&result);
evalctx_register(&operator);
evalctx_register(&operand_val);
evalctx_register(&operand_cons);
evalctx_register(&operands);
evalctx_register(&operands_end);
evalctx_register(&nil_value);
#ifdef VERBOSE_EVAL
printf("\nEvaluating expression: ");
print_value(stdout, expr);
printf("\n");
#endif
/* If this is a special form, evaluate it. Otherwise, this function will
* simply pass the input through to the result.
*/
result = eval_special_form(env, expr);
if (result != expr)
goto Done; /* It was a special form. */
/*
* If the input is an atom, we need to resolve it to a value, using the
* current environment.
*/
if (is_atom(expr)) {
/* Treat the atom as a name - resolve it to a value. */
result = resolve_binding(env, expr->string_val);
if (result == NULL) {
result = make_error("couldn't resolve name \"%s\" to a value!",
expr->string_val);
}
goto Done;
}
/*
* If the input isn't an atom and isn't a cons-pair, then assume it's a
* value that doesn't need evaluating, and just return it.
*/
if (!is_cons_pair(expr)) {
result = expr;
goto Done;
}
/*
* Evaluate operator into a lambda expression.
*/
temp = get_car(expr);
operator = evaluate(env, temp);
if (is_error(operator)) {
result = operator;
goto Done;
}
if (!is_lambda(operator)) {
result = make_error("operator is not a valid lambda expression");
goto Done;
}
#ifdef VERBOSE_EVAL
printf("Operator: ");
print_value(stdout, operator);
printf("\n");
#endif
/*
* Evaluate each operand into a value, and build a list up of the values.
*/
#ifdef VERBOSE_EVAL
printf("Starting evaluation of operands.\n");
#endif
num_operands = 0;
operands_end = NULL;
operands = nil_value = make_nil();
temp = get_cdr(expr);
while (is_cons_pair(temp)) {
Value *raw_operand;
num_operands++;
/* This is the raw unevaluated value. */
raw_operand = get_car(temp);
/* Evaluate the raw input into a value. */
operand_val = evaluate(env, raw_operand);
if (is_error(operand_val)) {
result = operand_val;
goto Done;
}
operand_cons = make_cons(operand_val, nil_value);
if (operands_end != NULL)
set_cdr(operands_end, operand_cons);
else
operands = operand_cons;
operands_end = operand_cons;
temp = get_cdr(temp);
}
/*
* Apply the operator to the operands, to generate a result.
*/
if (operator->lambda_val->native_impl) {
/* Native lambdas don't need an environment created for them. Rather,
* we just pass the list of arguments to the native function, and it
* processes the arguments as needed.
*/
result = operator->lambda_val->func(num_operands, operands);
}
else {
/* These don't need registered on the explicit stack. (I hope.) */
Environment *child_env;
Value *body_iter;
/* It's an interpreted lambda. Create a child environment, then
* populate it with values based on the lambda's argument-specification
* and the input operands.
*/
child_env = make_environment(operator->lambda_val->parent_env);
temp = bind_arguments(child_env, operator->lambda_val, operands);
if (is_error(temp)) {
result = temp;
goto Done;
}
/* Evaluate each expression in the lambda, using the child environment.
* The result of the last expression is the result of the lambda.
*/
body_iter = operator->lambda_val->body;
do {
result = evaluate(child_env, get_car(body_iter));
body_iter = get_cdr(body_iter);
}
while (!is_nil(body_iter));
}
Done:
#ifdef VERBOSE_EVAL
printf("Result: ");
print_value(stdout, result);
printf("\n\n");
#endif
/* Record the result and then perform garbage-collection. */
pop_evalctx(result);
collect_garbage();
return result;
}
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)));
}
