static obj_t *
lang_define(obj_t **frame, obj_t **tailp)
{
obj_t *expr = *frame_ref(frame, 0);
obj_t *first, *name, *result;
*tailp = NULL;
first = pair_car(expr);
if (symbolp(first)) {
// Binding an expression
// XXX: check for expr length?
obj_t *to_eval = pair_car(pair_cdr(expr));
// Get the value of the expression before binding.
obj_t **expr_frame = frame_extend(
frame, 1, FR_CONTINUE_ENV | FR_SAVE_PREV);
*frame_ref(expr_frame, 0) = to_eval;
result = eval_frame(expr_frame);
name = first;
}
else if (pairp(first)) {
// short hand for (define name (lambda ...))
// x: the formals, v: the body
obj_t *formals, *body;
name = pair_car(first);
formals = pair_cdr(first);
body = pair_cdr(expr);
result = closure_wrap(frame, frame_env(frame), formals, body);
}
else {
fatal_error("define -- first argument is neither a "
"symbol nor a pair", frame);
}
environ_def(frame, frame_env(frame), name, result);
return unspec_wrap();
}
static obj_t *
lang_if(obj_t **frame, obj_t **tailp)
{
obj_t *expr = *frame_ref(frame, 0);
obj_t *pred, *todo, *otherwise;
*tailp = tail_token;
pred = pair_car(expr);
todo = pair_cadr(expr);
otherwise = pair_cddr(expr);
if (nullp(otherwise)) {
otherwise = unspec_wrap();
}
else if (!nullp(pair_cdr(otherwise))) {
fatal_error("if -- too many arguments", frame);
}
else {
otherwise = pair_car(otherwise);
}
{
// start to evaluate the predicate.
obj_t **pred_frame = frame_extend(
frame, 1, FR_CONTINUE_ENV | FR_SAVE_PREV);
*frame_ref(pred_frame, 0) = pred;
pred = eval_frame(pred_frame);
}
if (to_boolean(pred)) {
return todo;
}
else {
return otherwise;
}
}
static obj_t *
lang_begin(obj_t **frame, obj_t **tailp)
{
obj_t *expr = *frame_ref(frame, 0);
*tailp = tail_token;
obj_t *iter;
for (iter = expr; pairp(iter); iter = pair_cdr(iter)) {
// Eval each expression except the last.
if (!pairp(pair_cdr(iter))) {
break;
}
obj_t **expr_frame = frame_extend(frame, 1,
FR_SAVE_PREV | FR_CONTINUE_ENV);
*frame_ref(expr_frame, 0) = pair_car(iter);
eval_frame(expr_frame);
}
if (nullp(iter)) {
// Empty (begin) expression
return unspec_wrap();
}
else if (!nullp(pair_cdr(iter))) {
fatal_error("begin -- not a well-formed list", frame);
}
return pair_car(iter);
}
PyObject *
PyEval_EvalCodeEx(PyCodeObject *co, PyObject *globals, PyObject *locals,
PyObject **args, int argcount, PyObject **kws, int kwcount,
PyObject **defs, int defcount, PyObject *closure)
{
register PyFrameObject *f;
register PyObject *retval = NULL;
PyThreadState *tstate = PyThreadState_GET();
if (globals == NULL) {
/* ERROR */
printf("PyEval_EvalCodeEx: NULL globals\n");
return NULL;
}
f = PyFrame_New(tstate, co, globals, locals);
if (f == NULL) {
return NULL;
}
retval = eval_frame(f);
++tstate->recursion_depth;
Py_DECREF(f);
--tstate->recursion_depth;
return retval;
}
static obj_t *expand(obj_t *expr, env_t *env)
{
PUSH_ROOT(expr);
PUSH_ROOT(env);
AUTO_ROOT(proc, expander());
AUTO_ROOT(args, make_pair(env, NIL));
args = make_pair(expr, args);
//printf_unchecked("proc = %O\n", proc);
//printf_unchecked("args = %O\n", args);
FRAME = NIL;
FRAME = MAKE_CALL(b_eval, make_boolean(false), env);
apply_procedure(proc, args);
POP_FUNCTION_ROOTS();
return eval_frame(FRAME);
}
static PyObject *
fast_function(PyObject *func, PyObject ***pp_stack, int n, int na, int nk)
{
PyCodeObject *co = (PyCodeObject *)PyFunction_GET_CODE(func);
PyObject *globals = PyFunction_GET_GLOBALS(func);
PyObject *argdefs = PyFunction_GET_DEFAULTS(func);
PyObject **d = NULL;
int nd = 0;
if (argdefs == NULL && co->co_argcount == n && nk==0 &&
co->co_flags == (CO_OPTIMIZED | CO_NEWLOCALS | CO_NOFREE)) {
PyFrameObject *f;
PyObject *retval = NULL;
PyThreadState *tstate = PyThreadState_GET();
PyObject **fastlocals, **stack;
int i;
/* XXX Perhaps we should create a specialized
PyFrame_New() that doesn't take locals, but does
take builtins without sanity checking them.
*/
f = PyFrame_New(tstate, co, globals, NULL);
if (f == NULL)
return NULL;
fastlocals = f->f_localsplus;
stack = (*pp_stack) - n;
for (i = 0; i < n; i++) {
Py_INCREF(*stack);
fastlocals[i] = *stack++;
}
retval = eval_frame(f);
++tstate->recursion_depth;
Py_DECREF(f);
--tstate->recursion_depth;
return retval;
}
if (argdefs != NULL) {
d = &PyTuple_GET_ITEM(argdefs, 0);
nd = ((PyTupleObject *)argdefs)->ob_size;
}
return PyEval_EvalCodeEx(co, globals,
(PyObject *)NULL, (*pp_stack)-n, na,
(*pp_stack)-2*nk, nk, d, nd,
PyFunction_GET_CLOSURE(func));
}
static obj_t *
lang_set(obj_t **frame, obj_t **tailp)
{
obj_t *expr = *frame_ref(frame, 0);
obj_t *first, *name, *result;
*tailp = NULL;
first = pair_car(expr);
if (symbolp(first)) {
// Binding an expression
// XXX: check for expr length?
obj_t *to_eval = pair_car(pair_cdr(expr));
// Get the value of the expression before binding.
obj_t **expr_frame = frame_extend(
frame, 1, FR_CONTINUE_ENV | FR_SAVE_PREV);
*frame_ref(expr_frame, 0) = to_eval;
result = eval_frame(expr_frame);
name = first;
}
else {
fatal_error("set! -- first argument is not a symbol", frame);
}
environ_set(frame_env(frame), name, result);
return unspec_wrap();
}
static obj_t *
expand_quasiquote(obj_t **frame, obj_t *content,
enum quasiquote_return_flag *flag)
{
if (!pairp(content)) {
return content;
}
// Manually compare each item with unquote/unquote-splicing
obj_t *qq = symbol_quasiquote;
obj_t *uq = symbol_unquote;
obj_t *spl = symbol_unquote_splicing;
if (pair_car(content) == qq) {
if (flag)
flag = QQ_DEFAULT;
return content;
// XXX: NESTED QQ...
/*
obj_t *body = pair_cadr(content);
frame = frame_extend(frame, 1, FR_SAVE_PREV | FR_CONTINUE_ENV);
*frame_ref(frame, 0) = content;
obj_t *res = expand_quasiquote(frame, body, NULL); // nested QQ
obj_t *wrap = pair_wrap(frame, res, nil_wrap());
return pair_wrap(frame, qq, wrap);
*/
}
else if (pair_car(content) == uq) {
obj_t *uq_body = pair_cadr(content);
frame = frame_extend(frame, 1, FR_SAVE_PREV | FR_CONTINUE_ENV);
*frame_ref(frame, 0) = uq_body;
if (flag)
*flag = QQ_UNQUOTE;
return eval_frame(frame);
}
else if (pair_car(content) == spl) {
obj_t *spl_body = pair_cadr(content);
obj_t *retval;
frame = frame_extend(frame, 1, FR_SAVE_PREV | FR_CONTINUE_ENV);
*frame_ref(frame, 0) = spl_body;
retval = eval_frame(frame);
if (flag)
*flag = QQ_SPLICING;
return retval;
}
else {
// Copy the pair content.
content = pair_copy_list(frame, content);
// Append a dummy header for unquote-splicing to use.
content = pair_wrap(frame, nil_wrap(), content);
// Mark the content.
frame = frame_extend(frame, 1, FR_SAVE_PREV | FR_CONTINUE_ENV);
*frame_ref(frame, 0) = content;
// For linking unquote-splicing, we look at the next item of
// the iterator. That's why we need a dummy header here.
obj_t *iter, *next, *got;
enum quasiquote_return_flag ret_flag;
for (iter = content; pairp(iter); iter = pair_cdr(iter)) {
// `next` will always be null or pair, since `content` is a list.
loop_begin:
next = pair_cdr(iter);
if (nullp(next)) // we are done.
break;
// XXX: this is strange. why do we need to initialize it?
ret_flag = QQ_DEFAULT;
got = expand_quasiquote(frame, pair_car(next), &ret_flag);
if (ret_flag & QQ_SPLICING) {
// Special handling for unquote-splicing
// WARNING: messy code below!
got = pair_copy_list(frame, got);
if (nullp(got)) {
pair_set_cdr(iter, pair_cdr(next));
}
else {
pair_set_cdr(iter, got); // iter -> got
while (pairp(pair_cdr(got))) {
got = pair_cdr(got);
}
pair_set_cdr(got, pair_cdr(next)); // got -> (next->next)
iter = got; // make sure the next iteration is correct
goto loop_begin; // And this...
}
}
else {
// Not unquote-splicing, easy...
pair_set_car(next, got);
}
}
if (flag)
*flag = QQ_DEFAULT;
return pair_cdr(content);
}
}
obj_t *eval_expanded(obj_t *expr, env_t *env)
{
FRAME = NIL;
FRAME = MAKE_CALL(b_eval, expr, env);
return eval_frame(FRAME);
}
