scheme.vtc

Unix下的MUD客户端程序

		return s + ")";
	else
		return s + " . " + pformat(cdr(data)) + ")";
}
func pformat_dist(data) {
	if (data == false)
		return "#f";
	if (data == nil)
		return "()";
	if (data == undefined)
		return "#[undefined value]";
}

pfmtfuncs ?:= table(.pformat_int, .pformat_str, .pformat_sym, \
		    .pformat_simproc, .pformat_comproc, .pformat_pair, \
		    .pformat_dist);

func pformat(data) --> (*pfmtfuncs[data->type])(data)

// The evaluator is (you guessed it) recursive.  The evaluation procedure is
// fairly simple; only the special forms require a significant amount of
// code.
func eval_scheme(data) {
	if (data->type == ST_PAIR)
		return eval_scheme_list(data);
	if (data->type == ST_SYM)
		return eval_scheme_symbol(data);
	return data;
}

// We keep special forms in a tree indexed by the symbols that start them.
func eval_scheme_list(data) [form] {
	if (!is_list(data))
		scheme_error("Pair is not a list");
	if (car(data)->type == ST_SYM) {
		form = find_tree(special_forms, car(data)->val);
		if (form)
			return (*form)(cdr(data));
	}
	return eval_scheme_compound(data);
}

// Evaluate subexpressions and apply the first subexpression to the rest.
// We keep the evaluated subexpressions in an array rather than a Scheme
// list, as VTC is equipped to handle arrays more efficiently.  If we were
// to add support for variable-argument lambda expressions, we would have
// to convert part of the array into a list.
func eval_scheme_compound(data) [exparray, proc] {
	proc = eval_scheme(car(data));
	exparray = new_array();
	for (data = cdr(data); data != nil; data = cdr(data))
		add_array(exparray, eval_scheme(car(data)));
	if (proc->type == ST_SIMPROC)
		return (*proc->val)(exparray);
	if (proc->type == ST_COMPROC)
		return apply_compound(proc->val, exparray);
	scheme_error("%s is not applicable", pformat(proc));
}

// To apply a compound procedure, we create a new environment, assign the
// parameter bindings, and evaluate the body.
func apply_compound(proc, exparray) [d] {
	if (*proc->params != *exparray)
		scheme_error("Procedure needs %d args, called with %d",
			*proc->params, *exparray);
	env = make_env(proc->parent);
	for (i = 1; i <= *proc->params; i++)
		env_add_sym(env, proc->params[i], exparray[i]);
	push_env(env);
	d = eval_scheme(proc->body);
	pop_env();
	return d;
}

func eval_scheme_symbol(data) {
	return env_find_sym(cur_env, data->val) ? :
	       scheme_error("Unbound symbol %s", data->val);
}

// Special forms receive the remainder of the list after the symbol that
// began the form.

// Evaluate each expression in the list and return the last one.
func eval_begin(data) [r] {
	for (; data->type == ST_PAIR; data = cdr(data))
		r = eval_scheme(car(data));
	return r ? : undefined;
}

// Construct a procedure from the parameters and return it.
func eval_lambda(data) [p, params, body] {
	params = new_array();
	if (length_list(data) < 2 || !is_list(car(data)))
		scheme_error("Invalid lambda");
	for (p = car(data); p->type == ST_PAIR; p = cdr(p)) {
		if (car(p)->type != ST_SYM)
			scheme_error("Invalid lambda");
		add_array(params, car(p)->val);
	}
	body = cdr(data);
	if (cdr(body)->type == ST_PAIR) {
		body = make_data(ST_PAIR, make_pair(symbol("begin"), body));
	} else
		body = car(body);
	return make_data(ST_COMPROC, make_proc(params, body, cur_env));
}

// Create a new binding.  The syntactic abbreviation (define (foo bar) baz)
// should be evaluated (define foo (lambda (bar) baz)).  So we create a
// new list in several successive steps, and evaluate that.
func eval_define(data) [d] {
	if (length_list(data) < 2)
		scheme_error("Invalid define %s", pformat(data));
	if (car(data)->type == ST_SYM)
		env_add_sym(cur_env, car(data)->val, eval_scheme(cadr(data)));
	else if (is_list(data->val->car)) {
		d = cdr(car(data));
		d = cons(symbol("lambda"), cons(d, cdr(data)));
		d = make_list(car(car(data)), d);
		d = cons(symbol("define"), d);
		return eval_scheme(d);
	} else
		scheme_error("Invalid define %s", pformat(data));
	return undefined;
}

// (quote x) --> x
func eval_quote(data) {
	if (length_list(data) != 1)
		scheme_error("Invalid quote");
	return car(data);
}

// The set! form mutates a binding.
func eval_set(data) {
	if (length_list(data) != 2 || car(data)->type != ST_SYM)
		scheme_error("Invalid set!");
	env_mutate_sym(cur_env, car(data)->val, eval_scheme(cadr(data)));
	return undefined;
}

func eval_if(data) {
	if (length_list(data) != 3)
		scheme_error("Invalid if");
	if (data_true(eval_scheme(car(data))))
		return eval_scheme(cadr(data));
	else
		return eval_scheme(car(cdr(cdr(data))));
}

// Note that we don't define 'else' anywhere, so we have to do this
// manually at some point.
func eval_cond(data) [case] {
	for (; data->type == ST_PAIR; data = cdr(data)) {
		if (!is_list(case) || case == nil)
			scheme_error("Invalid cond");
		if (data_true(eval_scheme(car(data))))
			return eval_begin(cdr(data));
	}
	return false;
}

// The three types of let expressions vary only in regard to how they handle
// environments.  let evaluates each binding in the current environment.
// letrec evaluates each binding in the same environment in which it will
// evaluate the body, so that lambda expressions can refer to other bindings
// in the letrec.  let* evaluates each binding in a successively deeper
// environment.
func eval_let(data) [b, belem, env, d] {
	if (length_list(data) < 2 || !is_list(car(data)))
		scheme_error("Invalid let");
	env = make_env(cur_env);
	for (b = car(data); b != nil; b = cdr(b)) {
		belem = car(b);
		if (!is_list_len(belem, 2) || car(belem)->type != ST_SYM)
			scheme_error("Invalid let");
		env_add_sym(env, car(belem)->val, eval_scheme(cadr(belem)));
	}
	push_env(env);
	d = eval_begin(cdr(data));
	pop_env();
	return d;
}

func eval_letrec(data) [b, belem, env, d] {
	if (length_list(data) < 2 || !is_list(car(data)))
		scheme_error("Invalid let");
	env = make_env(cur_env);
	push_env(env);
	for (b = car(data); b != nil; b = cdr(b)) {
		belem = car(b);
		if (!is_list_len(belem, 2) || car(belem)->type != ST_SYM)
			scheme_error("Invalid let");
		env_add_sym(env, car(belem)->val, eval_scheme(cadr(belem)));
	}
	d = eval_begin(cdr(data));
	pop_env();
	return d;
}

func eval_letstar(data) [b, belem, env, d, epos] {
	if (length_list(data) < 2 || !is_list(car(data)))
		scheme_error("Invalid let");
	epos = env_stack;
	for (b = car(data); b != nil; b = cdr(b)) {
		env = make_env(cur_env);
		belem = car(b);
		if (!is_list_len(belem, 2) || car(belem)->type != ST_SYM)
			scheme_error("Invalid let");
		env_add_sym(env, car(belem)->val, eval_scheme(cadr(belem)));
		push_env(env);
	}
	d = eval_begin(cdr(data));
	env_stack = epos;
	cur_env = *env_stack;
	return d;
}

// And finally, we insert all these functions into the special_forms tree.
special_forms = make_tree(.stricmp);
insert_tree(special_forms, "begin", .eval_begin);
insert_tree(special_forms, "lambda", .eval_lambda);
insert_tree(special_forms, "define", .eval_define);
insert_tree(special_forms, "quote", .eval_quote);
insert_tree(special_forms, "set!", .eval_set);
insert_tree(special_forms, "if", .eval_if);
insert_tree(special_forms, "cond", .eval_cond);
insert_tree(special_forms, "let", .eval_let);
insert_tree(special_forms, "letrec", .eval_letrec);
insert_tree(special_forms, "let*", .eval_letstar);

// Now for some primitives.  First, some shortcuts to add primitives to the
// global environment and to handle exceptions.

func add_prmt(name, fn) {
	sys_env_add_sym(global_env, name, make_data(ST_SIMPROC, fn));
}

func fixed_args(name, explist, n) {
	if (*explist != n)
		scheme_error("%s received %d arguments, requires %d", name,
			     *explist, n);
}

func fixed_type(name, arg, type) {
	if (arg->type != type)
		scheme_error("%s passed <%s>, requires <%s>", name,
			     stypenames[arg->type], stypenames[type]);
}

func fixed_typed_args(name, explist) [i] {
	fixed_args(name, explist, argc - 2);
	for (i = 1; i < *explist; i++)
		fixed_type(name, explist[i], argv[i + 1]);
}

// Now for the primitives.  They receive a VTC array (in distribution list
// format) containing the subexpression values as an argument.

func pr_cons(explist) {
	fixed_args("cons", explist, 2);
	return cons(explist[1], explist[2]);
}

func pr_car(explist) {
	fixed_typed_args("car", explist, ST_PAIR);
	return car(explist[1]);
}

func pr_cdr(explist) {
	fixed_typed_args("cdr", explist, ST_PAIR);
	return cdr(explist[1]);
}

func pr_add(explist) [sum, i] {
	for (sum = 0, i = 1; i <= *explist; i++) {
		fixed_type("+", explist[i], ST_INT);
		sum += explist[i]->val;
	}
	return make_data(ST_INT, sum);
}

func pr_sub(explist) [sum, i] {
	if (!*explist)
		scheme_error("- requires at least one arg");
	fixed_type("-", explist[1], ST_INT);
	if (*explist == 1)
		return make_data(ST_INT, -explist[1]->val);
	for (sum = explist[1]->val, i = 2; i <= *explist; i++) {
		fixed_type("-", explist[i], ST_INT);
		sum -= explist[i]->val;
	}
	return make_data(ST_INT, sum);
}

func pr_mul(explist) [prod, i] {
	for (prod = 1, i = 1; i <= *explist; i++) {
		fixed_type("*", explist[i], ST_INT);
		prod *= explist[i]->val;
	}
	return make_data(ST_INT, prod);
}

func pr_div(explist) {
	fixed_typed_args("/", explist, ST_INT, ST_INT);
	return make_data(ST_INT, explist[1]->val / explist[2]->val);
}

func pr_inc(explist) {
	fixed_typed_args("inc", explist, ST_INT);
	return make_data(ST_INT, explist[1]->val + 1);
}

add_prmt("cons", .pr_cons);
add_prmt("car", .pr_car);
add_prmt("cdr", .pr_cdr);
add_prmt("+", .pr_add);
add_prmt("-", .pr_sub);
add_prmt("*", .pr_mul);
add_prmt("/", .pr_div);
add_prmt("1+", .pr_inc);

// A note on Church numerals:
//
// Church numerals are useful for testing Scheme interpreters because they
// require no primitives for the most part, and involve a great deal of
// nesting of environments.
//
// It is possible to represent the nonnegative integers without any built-in
// support for them.  We can represent the nonnegative integers as two-
// argument procedures that apply their first argument to their second
// argument <n> times, where <n> is the number that the function is intended
// to represent.  Church numerals are similar to this, except rather than
// taking two arguments directly, they are "Curried"--that is, they accept
// one argument, a procedure <f>, and return another procedure which accepts
// an arbitrary argument <x> and returns the result of applying <f> to <x>
// <n> times.  Zero returns the result of apply <f> to <x> zero times, or
// just <x>:
//
// (define zero (lambda (f) (lambda (x) x)))
//
// So ((zero f) x) is x.  In general, ((n f) x) is the result of applying
// <f> to <x> <n> times, if we interpret n as a number.  We can define the
// increment function as follows:
//
// 	(define (inc n) (lambda (f) (lambda (x) (f ((n f) x)))))
//
// That is, a "Curried" two argument function which applies f to ((n f) x).
//
// Addition, multiplication, and exponentiation are also possible.  If a and
// b are Church numerals and we apply (a f) to ((b f) x), we apply <f> to <x>
// a total of <a> + <b> times.  Thus:
//
// 	(define (add a b) (lambda (f) (lambda (x) ((a f) ((b f) x)))))
//
// (a (b f)) returns a procedure which applies (b f) to its argument <a>
// times.  This results in a total of <a> * <b> applications of <f>.  So
// we can define:
//
//	(define (mul a b) (lambda (f) (a (b f))))
//
// Finally, (b a) return a function which applies <a> to its argument <b>
// times.  ((three two) f) evaluates to (two (two (two f))), for instance.
// Each (two ...) returns a function that evaluates its argument twice,
// multiplying the number of applications of <f> by two.  So the total
// number of applications of f is 2^3 = 8.  We can define exponentiation
// simply by:
//
//	(define (exp a b) (b a))
//
// To be able to see our results, we need to be able to convert a Church
// numeral into a real number.  Therefore:
//
//	(define (cnum n) ((n 1+) 0))
//
// This applies 1+ to 0 <n> times, producing <n> as an integer.  In order
// to play around with these functions, it is helpful to have:
//
//	(define one (inc zero))
//	(define two (inc one))
//	(define three (inc two))