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;
}
}
/* 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;
}
sexp definition_value(sexp form) {
if (is_symbol(pair_cadr(form)))
return pair_caddr(form);
else
return make_lambda_form(pair_cdr(pair_cadr(form)), pair_cddr(form));
}
