static pobject gt(pobject env, pobject params)
{
pobject o1 = eval(env, cons_car(params));
pobject o2 = eval(env, cons_car(cons_cdr(params)));
return object_bool(is_number(o1)
&& is_number(o2)
&& number_value(o1) > number_value(o2));
}
static pobject builtin_macro_expand(pobject env, pobject params)
{
pobject p = cons_car(params);
if (is_cons(p)) {
pobject macro = eval(env, cons_car(p));
if (is_macro(macro))
return macro_expand(env, macro, cons_cdr(p));
}
return NIL;
}
static pobject defmacro(pobject env, pobject params)
{
pobject p = cons_car(params);
if (is_cons(p)) {
return env_define(env,
cons_car(p),
gc_add(macro_new(env, cons_cdr(p), cons_cdr(params))));
}
return NIL;
}
static pobject cond(pobject env, pobject params)
{
while (is_cons(params)) {
pobject entry = cons_car(params);
if (is_cons(entry)) {
if (eval(env, cons_car(entry)))
return eval(env, object_prepend_begin( cons_cdr( entry ) ) );
} else {
return eval(env, entry);
}
params = cons_cdr(params);
}
return NIL;
}
static void gc_traverse(pobject env)
{
pobject object;
while (is_cons(env)) {
gc_flag_set(env, GC_FLAG_ON);
object = cons_car(env);
if (object && (gc_flag_get(object) == 0)) {
/*
printf("%p\n", object);
*/
gc_flag_set(object, GC_FLAG_ON);
/* XXX: dotted list support??? */
if (is_cons(object)) {
gc_traverse(object);
} else if (is_closure(object)) {
gc_traverse(object->data.closure.env);
gc_traverse(object->data.closure.code);
} else if (is_macro(object)) {
gc_traverse(object->data.macro.env);
gc_traverse(object->data.macro.code);
}
}
env = cons_cdr(env);
}
}
pobject moe_read(char *code)
{
int type, start, end = 0, dot_next = 0;
pobject stack = NIL;
while ((type = next_token(code, &start, &end))) {
switch (type) {
case TK_SYMBOL:
moe_read_stack_macro(stack, symbol_intern_by_slice(code, start, end));
break;
case TK_NUMBER:
moe_read_stack_macro(stack, gc_add( number_new_by_slice(code, start, end) ));
break;
case TK_PAREN_OPEN:
cons_stack_push(&stack, NIL, 1);
break;
case TK_PAREN_CLOSE:
moe_read_stack_macro(stack, cons_stack_pop(&stack));
break;
case TK_DOT:
dot_next = 1;
break;
}
};
return is_nil(stack) ? NIL : cons_car(cons_list_last(stack));
}
static pobject define(pobject env, pobject params)
{
pobject p = cons_car(params);
if (is_symbol(p)) {
return env_define(env,
cons_car(params),
eval(env, cons_car(cons_cdr(params))));
} else if (is_cons(p)) {
return env_define(env,
cons_car(p),
gc_add(closure_new(env, cons_cdr(p), cons_cdr(params))));
}
return NIL;
}
void gc_collect(pobject env)
{
int collected = 0;
/*
int old_count = gc_objects;
*/
pobject prev, cur, object;
/* set gc flag of all gc_list objects to 0 */
cur = gc_list;
while (cur) {
gc_flag_set(cons_car(cur), 0);
cur = cons_cdr(cur);
}
/* traverse environment and set gc flag of all objects to 1 */
gc_traverse(env);
/* go through gc_list a second time and free all all objects
* with flag 0 */
prev = NIL;
cur = gc_list;
while (cur) {
object = cons_car(cur);
if (gc_flag_get(object) == 0) {
gc_free(object);
collected++;
if (prev) {
cons_cdr_set(prev, cons_cdr(cur));
object_free(cur);
cur = cons_cdr(prev);
} else {
gc_list = cons_cdr(cur);
object_free(cur);
cur = gc_list;
}
} else {
prev = cur;
cur = cons_cdr(cur);
}
}
/*
printf("\ngc_collect: %d of %d objects collected\n", collected, old_count);
*/
}
static pobject div(pobject env, pobject params)
{
float result = 0;
pobject o = eval(env, cons_car(params));
if (is_number(o)) {
result = number_value(o);
params = cons_cdr(params);
if (is_cons(params)) {
while (is_cons(params)) {
pobject o = eval(env, cons_car(params));
if (is_number(o))
result /= number_value(o); /* TODO: division by zero error handling */
params = cons_cdr(params);
}
}
}
return gc_add(number_new(result));
}
static pobject begin(pobject env, pobject params)
{
pobject result = NIL;
while (is_cons(params)) {
result = eval(env, cons_car(params));
params = cons_cdr(params);
}
return result;
}
static pobject minus(pobject env, pobject params)
{
float result = 0;
pobject o = eval(env, cons_car(params));
if (is_number(o)) {
result = number_value(o);
params = cons_cdr(params);
if (is_cons(params)) {
while (is_cons(params)) {
pobject o = eval(env, cons_car(params));
if (is_number(o))
result -= number_value(o);
params = cons_cdr(params);
}
} else {
result = -result;
}
}
return gc_add(number_new(result));
}
static pobject mult(pobject env, pobject params)
{
float result = 1;
while (is_cons(params)) {
pobject o = eval(env, cons_car(params));
if (is_number(o))
result *= number_value(o);
params = cons_cdr(params);
}
return gc_add(number_new(result));
}
static pobject set(pobject env, pobject params)
{
pobject symbol = cons_car(params);
if (is_symbol(symbol)) {
pobject value = eval(env, cons_nth(params, 2));
pobject cons = env_lookup(env, symbol);
if (is_cons(cons)) {
cons_car_set(cons, value);
return value;
}
}
return NIL;
}
void gc_free(pobject object)
{
pobject prev = NIL, cur;
/* look for the cons cell in gc_list for object */
cur = gc_list;
while (cur) {
if (cons_car(cur) == object)
break;
prev = cur;
cur = cons_cdr(cur);
}
/* set new gc_list connections and free the cur cons cell */
if (cur) {
if (prev)
cons_cdr_set(prev, cons_cdr(cur));
else
gc_list = cons_cdr(cur);
object_free(cur);
}
object_free(object);
}
static pobject cons(pobject env, pobject params)
{
pobject o1 = eval(env, cons_car(params));
pobject o2 = eval(env, cons_car(cons_cdr(params)));
return gc_add(cons_new(o1, o2));
}
static pobject quote(pobject env, pobject params)
{
return cons_car(params);
}
static pobject equal(pobject env, pobject params)
{
pobject o1 = eval(env, cons_car(params));
pobject o2 = eval(env, cons_car(cons_cdr(params)));
return object_bool(object_equal(o1, o2));
}
static pobject builtin_println(pobject env, pobject params)
{
pobject o = eval(env, cons_car(params));
println(o);
return NIL;
}
static pobject cdr(pobject env, pobject params)
{
return cons_cdr(eval(env, cons_car(params)));
}
static pobject apply(pobject env, pobject params)
{
/* XXX: apply needs more work */
return eval_apply(env, eval(env, cons_car(params)),
eval(env, cons_nth(params, 2)));
}
static pobject macro(pobject env, pobject params)
{
return gc_add(macro_new(env, cons_car(params), cons_cdr(params)));
}
static pobject lambda(pobject env, pobject params)
{
return gc_add(closure_new(env, cons_car(params), cons_cdr(params)));
}
