static cv_t c_eval_operator(obj_t cont, obj_t values)
{
assert(is_cont4(cont));
obj_t appl = cont4_arg(cont);
obj_t operator = CAR(values);
EVAL_LOG("appl=%O operator=%O", appl, operator);
COULD_RETRY();
if (!is_procedure(operator))
SYNTAX_ERROR(operator, operator, "must be procedure");
if (!procedure_args_evaluated(operator)) {
assert(procedure_is_C(operator) && "implement Scheme special forms");
if (procedure_is_raw(operator)) {
return ((cont_proc_t)procedure_code(operator))(cont, values);
} else {
// N.B., call proc after all other allocations.
obj_t arg_list = application_operands(appl);
obj_t new_values = CONS(make_uninitialized(), CDR(values));
pair_set_car(new_values, apply_proc(operator, arg_list));
return cv(cont_cont(cont), new_values);
}
}
obj_t arg_list = reverse_list(application_operands(appl));
cont = make_cont5(c_apply_proc,
cont_cont(cont),
cont_env(cont),
operator,
CDR(values));
while (!is_null(arg_list)) {
cont = make_cont4(c_eval, cont, cont_env(cont), CAR(arg_list));
arg_list = CDR(arg_list);
}
return cv(cont, EMPTY_LIST);
}
void env_bind(env_t *env,
obj_t *name,
binding_type_t type,
mutability_t mutability,
obj_t *value)
{
assert(!is_null(env));
assert(is_symbol(name));
PUSH_ROOT(env);
AUTO_ROOT(binding, make_binding(name, type, mutability, value));
obj_t *frame = pair_car(env);
frame = make_pair(binding, frame);
pair_set_car(env, frame);
POP_FUNCTION_ROOTS();
}
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);
}
}
