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);
}
static const wchar_t *block_name(C_procedure_t *block, obj_t *env)
{
if (block == b_eval)
return L"b_eval";
if (block == b_accum_operator)
return L"b_accum_operator";
if (block == b_accum_arg)
return L"b_accum_arg";
if (block == b_eval_sequence)
return L"b_eval_sequence";
if (block == NULL)
return L"NULL";
/* XXX Move this code into env.c. */
if (!env)
env = library_env(r6rs_library());
if (is_pair(env)) {
obj_t *frame = pair_car(env);
while (frame) {
obj_t *binding = pair_car(frame);
obj_t *value = binding_value(binding);
if (is_procedure(value) && procedure_is_C(value)) {
C_procedure_t *body;
body = (C_procedure_t *)procedure_body(value);
if (body == block) {
obj_t *name = symbol_name(binding_name(binding));
return string_value(name);
}
}
frame = pair_cdr(frame);
}
}
return L"<some-proc>";
}
void print(Value x)
{
if (is_nil(x))
prints("nil");
else if (is_eof(x))
printf("#eof");
else if (is_fixnum(x))
printf("%d", as_fixnum(x));
else if (is_bool(x))
printf("%s", as_bool(x) ? "true" : "false");
else if (is_char(x))
printf("'%c'", as_char(x));
else if (is_pair(x))
print_list(x);
else if (is_symbol(x))
prints(as_symbol(x)->value);
else if (is_string(x))
print_string(as_string(x));
else if (is_procedure(x))
printf("#<procedure %s>", as_procedure(x)->name->value);
else if (is_module(x))
printf("#<module>");
else if (is_type(x))
printf("#<type %s>", as_type(x)->name->value);
else if (is_ptr(x))
printf("#<object %p>", as_ptr(x));
else if (is_undefined(x))
printf("#undefined");
else
printf("#ufo");
}
object* environment::define(object* var, object* val)
{
symbol* sym = dynamic_cast<symbol*>(var);
if (!sym)
{
return error("attempt to set a non-symbol: " + stringify(var));
}
if (is_procedure(val, "anonymous procedure"))
{
procedure* proc = dynamic_cast<procedure*>(val);
proc->set_name(sym->to_s());
}
m_map[sym] = val;
return sym;
}
Cell eval(Cell exp, Cell env) {
if (is_self_evaluating(exp)) {
return exp;
} else if (is_atom(exp)) {
return lookup(exp, env);
} else if (is_tagged(exp, atom("define"))) {
return define(car(cdr(exp)), eval(car(cdr(cdr(exp))), env), env);
} else if (is_tagged(exp, atom("set!"))) {
return set(car(cdr(exp)), eval(car(cdr(cdr(exp))), env), env);
} else if (is_tagged(exp, atom("if"))) {
Cell cond = eval(car(cdr(exp)), env);
if (is_atom(cond) && is_eq(cond, atom("#f"))) {
exp = car(cdr(cdr(cdr(exp))));
} else {
exp = car(cdr(cdr(exp)));
}
return eval(exp, env);
} else if (is_tagged(exp, atom("vau"))) {
return procedure(exp, env);
} else if (is_pair(exp)) {
Cell proc = eval(car(exp), env);
if (is_primitive(proc)) {
return (proc->primitive)(eval_operands(cdr(exp), env));
} else if (is_procedure(proc)) {
Cell src = car(proc);
Cell e = car(cdr(cdr(src)));
Cell para = cons(e, cons(car(cdr(src)), null));
Cell args = cons(env, cons(cdr(exp), null));
Cell body = car(cdr(cdr(cdr(src))));
return eval(body, extend_env(para, args, cdr(proc)));
}
}
fprintf(stderr, "eval illegal state\n");
return atom("#<void>");
}
void check_arg_type(char *func, char* loc, cellpoint arg, int type)
{
switch (type){
case BOOLEAN_T:
if (is_false(is_boolean(arg))){
printf("Error: procedure \"%s\" expects the %s argument is a boolean, but given: ", func, loc);
write(arg);
newline();
error_handler();
}
break;
case CHARACTER_T:
if (is_false(is_char(arg))){
printf("Errror: procedure \"%s\" expects the %s argument is a character, but given: ", func, loc);
write(arg);
newline();
error_handler();
}
break;
case INTEGER_T:
if (is_false(is_integer(arg))){
printf("Error: procedure \"%s\" expects the %s argument is a integer, but given: ", func, loc);
write(arg);
newline();
error_handler();
}
break;
case NUMBER_T:
if (is_false(is_number(arg))){
printf("Error: procedure \"%s\" expects the %s argument is a number, but given: ", func, loc);
write(arg);
newline();
error_handler();
}
break;
case SYMBOL_T:
if (is_false(is_symbol(arg))){
printf("Error: procedure \"%s\" expects the %s argument is a symbol, but given: ", func, loc);
write(arg);
newline();
error_handler();
}
break;
case STRING_T:
if (is_false(is_string(arg))){
printf("Error: procedure \"%s\" expects the %s argument is a string, but given: ", func, loc);
write(arg);
newline();
error_handler();
}
break;
case VECTOR_T:
if (is_false(is_vector(arg))){
printf("Error: procedure \"%s\" expects the %s argument is a vector, but given: ", func, loc);
write(arg);
newline();
error_handler();
}
break;
case PAIR_T:
if (is_false(is_pair(arg))){
printf("Error: procedure \"%s\" expects the %s argument is a pair, but given: ", func, loc);
write(arg);
newline();
error_handler();
}
break;
case LIST_T:
if (is_false(is_list(arg))){
printf("Error: procedure \"%s\" expects the %s argument is a list, but given: ", func, loc);
write(arg);
newline();
error_handler();
}
break;
case PROCEDURE_T:
if (is_false(is_procedure(arg))){
printf("Error: procedure \"%s\" expects the %s argument is a procedure, but given: ", func, loc);
write(arg);
newline();
error_handler();
}
break;
default:
printf("Error: unknown check arg type. -- CHECK_ARG_TYPE.\n");
error_handler();
}
}
/* 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;
}
//procedure?
cellpoint proc_pred_proc(cellpoint arglst)
{
check_arglst_len_eq("procedure?", 1, arglst);
return is_procedure(car(arglst));
}
