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 *
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);
}
}
/* Build a Scheme expression from an action stack. */
static bool build(bool init, obj_t *actions, obj_t **obj_out)
{
if (init) {
ACTION_BEGIN_LIST = make_C_procedure(&&begin_list, NIL, NIL);
ACTION_BEGIN_VECTOR = make_C_procedure(&&begin_vector, NIL, NIL);
ACTION_BEGIN_BYTEVEC = make_C_procedure(&&begin_bytevector, NIL, NIL);
ACTION_ABBREV = make_C_procedure(&&abbrev, NIL, NIL);
ACTION_END_SEQUENCE = make_C_procedure(&&end_sequence, NIL, NIL);
ACTION_DOT_END = make_C_procedure(&&dot_end, NIL, NIL);
ACTION_DISCARD = make_C_procedure(&&discard, NIL, NIL);
return false;
}
PUSH_ROOT(actions);
AUTO_ROOT(vstack, NIL);
AUTO_ROOT(reg, NIL);
AUTO_ROOT(tmp, NIL);
while (!stack_is_empty(actions)) {
obj_t *op = stack_pop(&actions);
if (is_procedure(op) && procedure_is_C(op))
goto *procedure_body(op);
/* default: */
reg = make_pair(op, reg);
continue;
begin_list:
reg = make_pair(reg, stack_pop(&vstack));
continue;
begin_vector:
reg = build_vector(reg);
reg = make_pair(reg, stack_pop(&vstack));
continue;
begin_bytevector:
reg = build_bytevec(reg);
reg = make_pair(reg, stack_pop(&vstack));
continue;
abbrev:
tmp = make_pair(pair_cadr(reg), NIL);
tmp = make_pair(pair_car(reg), tmp);
reg = make_pair(tmp, pair_cddr(reg));
continue;
end_sequence:
stack_push(&vstack, reg);
reg = NIL;
continue;
dot_end:
stack_push(&vstack, pair_cdr(reg));
reg = pair_car(reg);
continue;
discard:
reg = pair_cdr(reg);
continue;
}
assert(stack_is_empty(vstack));
bool success = false;
if (!is_null(reg)) {
assert(is_null(pair_cdr(reg)));
*obj_out = pair_car(reg);
success = true;
}
POP_FUNCTION_ROOTS();
return success;
}
