Value * bind_names_values(Environment *env, Value *names, Value *values) {
assert(env != NULL);
assert(names != NULL);
assert(values != NULL);
/* Bind each value under its specified name. */
while (is_cons_pair(names)) {
Value *argname = get_car(names);
if (is_nil(values))
return make_error("not enough values to complete bindings!");
assert(is_cons_pair(values));
create_binding(env, argname->string_val, get_car(values));
names = get_cdr(names);
values = get_cdr(values);
}
assert(is_nil(names));
if (!is_nil(values))
return make_error("too many values for the specified bindings!");
return NULL;
}
/* use *args_io to override *stdin* | *stdout* if not NIL */
static cell_t *new_frame_io(secd_t *secd, cell_t *args_io, cell_t *prevenv) {
cell_t *prev_io = get_car(prevenv)->as.frame.io;
if (is_nil(args_io))
return prev_io; /* share previous i/o */
if (is_nil(get_car(args_io)))
args_io->as.cons.car = share_cell(secd, get_car(prev_io));
if (is_nil(get_cdr(args_io)))
args_io->as.cons.cdr = share_cell(secd, get_cdr(prev_io));
return args_io; /* set a new i/o */
}
lisp_object* assoc(lisp_object* obj, lisp_object* env)
{
//env must be ((dummy . dummy) (a . 1) (b . 3) ...)
env = get_cdr(env);
for(env = get_cdr(env); null(env); env = get_cdr(env)){
if(get_car(get_car(env)) == obj){
return get_car(env);
}
}
return create_empty_list();
}
void dbg_print_cell(secd_t *secd, const cell_t *c) {
if (is_nil(c)) {
secd_printf(secd, "NIL\n");
return;
}
char buf[128];
if (c->nref > DONT_FREE_THIS - 100000) strncpy(buf, "-", 64);
else snprintf(buf, 128, "%ld", (long)c->nref);
printf("[%ld]^%s: ", cell_index(secd, c), buf);
switch (cell_type(c)) {
case CELL_CONS:
printf("CONS([%ld], [%ld])\n",
cell_index(secd, get_car(c)), cell_index(secd, get_cdr(c)));
break;
case CELL_FRAME:
printf("FRAME(syms: [%ld], vals: [%ld])\n",
cell_index(secd, get_car(c)), cell_index(secd, get_cdr(c)));
break;
case CELL_INT: printf("%d\n", c->as.num); break;
case CELL_CHAR:
if (isprint(c->as.num)) printf("#\\%c\n", (char)c->as.num);
else printf("#x%x\n", c->as.num);
break;
case CELL_OP:
sexp_print_opcode(secd, secd->output_port, c->as.op);
printf("\n");
break;
case CELL_FUNC: printf("*%p()\n", c->as.ptr); break;
case CELL_KONT: printf("KONT[%ld, %ld, %ld]\n",
cell_index(secd, c->as.kont.stack),
cell_index(secd, c->as.kont.env),
cell_index(secd, c->as.kont.ctrl)); break;
case CELL_ARRAY: printf("ARR[%ld]\n",
cell_index(secd, arr_val(c, 0))); break;
case CELL_STR: printf("STR[%ld\n",
cell_index(secd, (cell_t*)strval(c))); break;
case CELL_SYM: printf("SYM[%08x]='%s'\n",
symhash(c), symname(c)); break;
case CELL_BYTES: printf("BVECT[%ld]\n",
cell_index(secd, (cell_t*)strval(c))); break;
case CELL_REF: printf("REF[%ld]\n",
cell_index(secd, c->as.ref)); break;
case CELL_ERROR: printf("ERR[%s]\n", errmsg(c)); break;
case CELL_ARRMETA: printf("META[%ld, %ld]\n",
cell_index(secd, mcons_prev((cell_t*)c)),
cell_index(secd, mcons_next((cell_t*)c))); break;
case CELL_UNDEF: printf("#?\n"); break;
case CELL_FREE: printf("FREE\n"); break;
default: printf("unknown type: %d\n", cell_type(c));
}
}
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_eq(lisp_object* obj)
{
if(get_car(obj) == get_car(get_cdr(obj))){
return create_boolean(1);
}
return create_boolean(0);
}
/* check arity;
* possibly rewrite dot-lists into regular arguments;
* look for overriden *stdin*|*stdout* */
static cell_t *
walk_through_arguments(secd_t *secd, cell_t *frame, cell_t **args_io) {
cell_t *symlist = get_car(frame);
cell_t *vallist = get_cdr(frame);
size_t valcount = 0;
while (not_nil(symlist)) {
if (is_symbol(symlist)) {
break;
}
if (is_nil(vallist)) {
errorf(";; arity mismatch: %zd argument(s) is not enough\n", valcount);
return new_error(secd, SECD_NIL,
"arity mismatch: %zd argument(s) is not enough", valcount);
}
cell_t *sym = get_car(symlist);
check_io_args(secd, sym, get_car(vallist), args_io);
cell_t *nextsyms = list_next(secd, symlist);
cell_t *nextvals = list_next(secd, vallist);
++valcount;
symlist = nextsyms;
vallist = nextvals;
}
return SECD_NIL;
}
cell_t *pop_free(secd_t *secd) {
cell_t *cell;
if (not_nil(secd->free)) {
/* take a cell from the list */
cell = secd->free;
secd->free = get_cdr(secd->free);
if (secd->free)
secd->free->as.cons.car = SECD_NIL;
memdebugf("NEW [%ld]\n", cell_index(secd, cell));
-- secd->free_cells;
} else {
assert(secd->free_cells == 0,
"pop_free: free=NIL when nfree=%zd\n", secd->free_cells);
/* move fixedptr */
if (secd->fixedptr >= secd->arrayptr)
return &secd_out_of_memory;
cell = secd->fixedptr;
++ secd->fixedptr;
memdebugf("NEW [%ld] ++\n", cell_index(secd, cell));
}
cell->type = CELL_UNDEF;
cell->nref = 0;
return cell;
}
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;
}
void secd_print_env(secd_t *secd) {
cell_t *env = secd->env;
int i = 0;
secd_printf(secd, ";;Environment:\n");
while (not_nil(env)) {
secd_printf(secd, ";; Frame #%d:\n", i++);
cell_t *frame = get_car(env);
cell_t *symlist = get_car(frame);
cell_t *vallist = get_cdr(frame);
while (not_nil(symlist)) {
if (is_symbol(symlist)) {
secd_printf(secd, ";; . %s\t=>\t", symname(symlist));
dbg_print_cell(secd, vallist);
break;
}
cell_t *sym = get_car(symlist);
cell_t *val = get_car(vallist);
if (!is_symbol(sym)) {
errorf("print_env: not a symbol at *%p in symlist\n", sym);
dbg_printc(secd, sym);
}
secd_printf(secd, ";; %s\t=>\t", symname(sym));
dbg_print_cell(secd, val);
symlist = list_next(secd, symlist);
vallist = list_next(secd, vallist);
}
env = list_next(secd, env);
}
}
SE *get_cdr() {
SE *hd,*tl;
get_token();
if(token.type==TRPAR) return NIL;
hd=get_se();
tl=get_cdr();
return new_cons(hd,tl);
}
lisp_object* eval(lisp_object* obj, lisp_object* env)
{
data_type type = get_type_tag(obj);
lisp_object *opecode, *ret;
switch(type){
case TYPE_BOOLEAN:
case TYPE_NUMBER:
case TYPE_CHAR:
case TYPE_SUBR:
case TYPE_FSUBR:
case TYPE_EXPR:
case TYPE_FEXPR:
case TYPE_STRING:
case TYPE_PORT:
case TYPE_NULL:
case TYPE_VECTOR:
return obj;
case TYPE_SYMBOL:
ret = assoc(obj, env);
if(null(ret)){
fprintf(stderr, "eval:undefined variable\n");
return create_empty_list();// たぶん、toplevelに戻ったほうがいい
}
return ret;
case TYPE_CONS:
opecode = eval(get_car(obj), env);
type = get_type_tag(opecode);
switch(type){
case TYPE_SUBR:
case TYPE_EXPR:
return apply(opecode, evls(get_cdr(obj), env));
case TYPE_FSUBR:
case TYPE_FEXPR:
return apply(opecode, get_cdr(obj));
default:
fprintf(stderr, "eval:not function\n");
return create_empty_list();
}
default:
fprintf(stderr, "eval:undefined type\n");
return create_empty_list();
}
}
cell_t *lookup_env(secd_t *secd, const char *symbol, cell_t **symc) {
cell_t *env = secd->env;
assert(cell_type(env) == CELL_CONS,
"lookup_env: environment is not a list");
cell_t *res = lookup_fake_variables(secd, symbol);
if (not_nil(res))
return res;
hash_t symh = secd_strhash(symbol);
while (not_nil(env)) { // walk through frames
cell_t *frame = get_car(env);
if (is_nil(frame)) {
/* skip omega-frame */
env = list_next(secd, env);
continue;
}
cell_t *symlist = get_car(frame);
cell_t *vallist = get_cdr(frame);
while (not_nil(symlist)) { // walk through symbols
if (is_symbol(symlist)) {
if (symh == symhash(symlist) && str_eq(symbol, symname(symlist))) {
if (symc != NULL) *symc = symlist;
return vallist;
}
break;
}
cell_t *curc = get_car(symlist);
assert(is_symbol(curc),
"lookup_env: variable at [%ld] is not a symbol\n",
cell_index(secd, curc));
if (symh == symhash(curc) && str_eq(symbol, symname(curc))) {
if (symc != NULL) *symc = curc;
return get_car(vallist);
}
symlist = list_next(secd, symlist);
vallist = list_next(secd, vallist);
}
env = list_next(secd, env);
}
//errorf(";; error in lookup_env(): %s not found\n", symbol);
return new_error(secd, SECD_NIL, "Lookup failed for: '%s'", symbol);
}
/* Deallocation */
cell_t *drop_dependencies(secd_t *secd, cell_t *c) {
enum cell_type t = cell_type(c);
switch (t) {
case CELL_SYM:
if (c->as.sym.size != DONT_FREE_THIS)
free((char *)c->as.sym.data);
/* TODO: this silently ignores symbol memory corruption */
c->as.sym.size = DONT_FREE_THIS;
break;
case CELL_FRAME:
drop_cell(secd, c->as.frame.io);
// fall through
case CELL_CONS:
if (not_nil(c)) {
drop_cell(secd, get_car(c));
drop_cell(secd, get_cdr(c));
}
break;
case CELL_STR:
case CELL_ARRAY:
drop_array(secd, arr_mem(c));
break;
case CELL_REF:
drop_cell(secd, c->as.ref);
break;
case CELL_PORT:
secd_pclose(secd, c);
break;
case CELL_ARRMETA:
if (c->as.mcons.cells) {
size_t size = arrmeta_size(secd, c);
size_t i;
/* free the items */
for (i = 0; i < size; ++i) {
/* don't free uninitialized */
cell_t *ith = meta_mem(c) + i;
if (cell_type(ith) != CELL_UNDEF)
drop_dependencies(secd, ith);
}
}
break;
case CELL_INT: case CELL_FUNC: case CELL_OP:
case CELL_ERROR: case CELL_UNDEF:
return c;
default:
return new_error(secd, "drop_dependencies: unknown cell_type 0x%x", t);
}
return c;
}
cell_t *secd_insert_in_frame(secd_t *secd, cell_t *frame, cell_t *sym, cell_t *val) {
cell_t *old_syms = get_car(frame);
cell_t *old_vals = get_cdr(frame);
// an interesting side effect: since there's no check for
// re-binding an existing symbol, we can create multiple
// copies of it on the frame, the last added is found
// during value lookup, but the old ones are persistent
frame->as.cons.car = share_cell(secd, new_cons(secd, sym, old_syms));
frame->as.cons.cdr = share_cell(secd, new_cons(secd, val, old_vals));
drop_cell(secd, old_syms); drop_cell(secd, old_vals);
return frame;
}
SE *get_se()
{
switch(token.type)
{
case TEOF: return new_sym(strdup("#eof"));
case TNUM: return new_num(atoi(token.buf));
case TSYM: return new_sym(strdup(token.buf));
case TQUOTE: get_token(); /* ! */
return new_cons(new_sym(strdup("quote")),
new_cons(get_se(),NIL));
case TLPAR: return get_cdr();
default: break; /* err! */
}
return NIL; /* notreached */
}
cell_t *setup_frame(secd_t *secd, cell_t *argnames, cell_t *argvals, cell_t *env) {
cell_t *args_io = SECD_NIL;
/* setup the new frame */
cell_t *frame = new_frame(secd, argnames, argvals);
cell_t *ret = walk_through_arguments(secd, frame, &args_io);
assert_cell(ret, "setup_frame: argument check failed");
cell_t *new_io = new_frame_io(secd, args_io, env);
assert_cell(new_io, "setup_frame: failed to set new frame I/O\n");
frame->as.frame.io = share_cell(secd, new_io);
secd->input_port = get_car(new_io);
secd->output_port = get_cdr(new_io);
return frame;
}
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;
}
cell_t *serialize_cell(secd_t *secd, cell_t *cell) {
cell_t *opt = SECD_NIL;
switch (cell_type(cell)) {
case CELL_CONS: {
cell_t *cdrc = chain_index(secd, get_cdr(cell), SECD_NIL);
opt = chain_index(secd, get_car(cell), cdrc);
}
break;
case CELL_PORT:
opt = secd_pserialize(secd, cell);
break;
case CELL_SYM:
opt = new_cons(secd, cell, SECD_NIL);
break;
case CELL_INT:
case CELL_CHAR:
opt = new_cons(secd, cell, SECD_NIL);
break;
case CELL_OP: {
cell_t *namec = new_symbol(secd, opcode_table[ cell->as.op ].name);
opt = new_cons(secd, namec, SECD_NIL);
}
break;
case CELL_FUNC:
opt = new_cons(secd, new_number(secd, (long)cell->as.ptr), SECD_NIL);
break;
case CELL_ARRMETA: {
cell_t *typec = chain_sym(secd,
(cell->as.mcons.cells ? "cell" : "byte"),
SECD_NIL);
cell_t *nextc = chain_index(secd, mcons_next(cell), typec);
opt = chain_index(secd, mcons_prev(cell), nextc);
}
break;
case CELL_FRAME: {
cell_t *ioc = chain_index(secd, cell->as.frame.io, SECD_NIL);
cell_t *nextc = chain_index(secd, cell->as.frame.cons.cdr, ioc);
opt = chain_index(secd, cell->as.frame.cons.car, nextc);
}
break;
case CELL_KONT: {
cell_t *kctrl = chain_index(secd, cell->as.kont.ctrl, SECD_NIL);
cell_t *kenv = chain_index(secd, cell->as.kont.env, kctrl);
opt = chain_index(secd, cell->as.kont.stack, kenv);
}
break;
case CELL_FREE: {
cell_t *nextc = chain_index(secd, get_cdr(cell), SECD_NIL);
opt = chain_index(secd, get_car(cell), nextc);
}
break;
case CELL_REF:
opt = chain_index(secd, cell->as.ref, SECD_NIL);
break;
case CELL_ERROR:
opt = chain_string(secd, errmsg(cell), SECD_NIL);
break;
case CELL_UNDEF:
opt = SECD_NIL;
break;
case CELL_ARRAY:
opt = chain_index(secd, arr_val(cell, -1), SECD_NIL);
break;
case CELL_STR:
case CELL_BYTES:
opt = chain_index(secd, arr_meta((cell_t *)strmem(cell)), SECD_NIL);
break;
}
opt = new_cons(secd, secd_type_sym(secd, cell), opt);
cell_t *refc = new_cons(secd, new_number(secd, cell->nref), opt);
return new_cons(secd, new_number(secd, cell - secd->begin), refc);
}
/*!
* This helper function takes an interpreted lambda expression, a list of
* evaluated operands for the lambda, and the environment that the lambda will
* be run in, and binds each operand into the environment with the argument name
* specified in the lambda's argument list.
*
* The function returns NULL on success, or a Value* of type T_Error if
* something horrible happens along the way. For example, the function may
* receive too many or too few arguments, or the interpreter may not have enough
* memory to construct a specific binding.
*/
Value * bind_arguments(Environment *child_env, Lambda *lambda, Value *operands) {
Value *argname_iter, *argval_iter;
assert(child_env != NULL);
assert(lambda != NULL);
assert(!lambda->native_impl);
assert(operands != NULL);
/* Populate the child environment with values based on the lambda's
* argument-specification, and the input operands.
*/
argname_iter = lambda->arg_spec;
argval_iter = operands;
if (is_atom(argname_iter)) {
/* Entire operand list gets bound under a single name. */
create_binding(child_env, argname_iter->string_val, operands);
}
else {
/* Bind each operand under its specified name.
*
* TODO: Find a way to use bind_names_values(), one day...
*/
assert(is_cons_pair(argname_iter));
do {
Value *argname = get_car(argname_iter);
if (is_nil(argval_iter))
return make_error("not enough arguments for lambda!");
assert(is_cons_pair(operands));
create_binding(child_env, argname->string_val,
get_car(argval_iter));
argname_iter = get_cdr(argname_iter);
argval_iter = get_cdr(argval_iter);
}
while (is_cons_pair(argname_iter));
if (is_nil(argname_iter) && !is_nil(argval_iter))
return make_error("too many arguments for lambda!");
/* If argname_iter is an atom then the argument-list was an improper
* list, and the remainder of the operands get bound under this name.
*/
if (is_atom(argname_iter)) {
create_binding(child_env, argname_iter->string_val, argval_iter);
}
else {
/* The lambda special-form should have constructed the argument
* specification properly, so this assertion should never fail.
*/
assert(is_nil(argname_iter));
}
}
/* NULL just means "success" here. The only other thing this function might
* return is a Value of type T_Error, if something awful happened...
*/
return NULL;
}
lisp_object* LF_cdr(lisp_object* obj)
{
return get_car(get_cdr(obj));
}
