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_env(obj_t *env)
{
if (!is_pair(env)) {
printf_unchecked("%O\n", env);
return;
}
const char *sep = "";
while (env) {
printf("%s", sep);
if (pair_cdr(env)) {
obj_t *f = pair_car(env);
printf("[");
sep = "";
while (f) {
obj_t *binding = pair_car(f);
printf_unchecked("%s%O: %O", sep,
binding_name(binding),
binding_value(binding));
f = pair_cdr(f);
sep = ", ";
}
printf("]");
} else
printf("[builtins]\n");
env = pair_cdr(env);
sep = " -> ";
}
}
static inline object *bindings_values(object *bindings)
{
return is_empty_list(bindings) ?
get_empty_list() :
cons (binding_value(car(bindings)),
bindings_values(cdr(bindings)));
}
void register_procs(void)
{
root_env = make_env(NIL);
while (proc_descs) {
proc_descriptor_t *desc = proc_descs;
obj_t *library = find_library_str(desc->pd_libdesc->ld_namespec);
(*desc->pd_binder)(desc->pd_proc, library, desc->pd_name);
proc_descs = desc->pd_next;
}
AUTO_ROOT(value, NIL);
AUTO_ROOT(new_env, NIL);
AUTO_ROOT(old_env, NIL);
while (alias_descs) {
alias_descriptor_t *desc = alias_descs;
const wchar_t *old_namespec = desc->ad_old_libdesc->ld_namespec;
obj_t *old_library = find_library_str(old_namespec);
old_env = library_env(old_library);
obj_t *old_sym = make_symbol_from_C_str(desc->ad_old_name);
obj_t *binding = env_lookup(old_env, old_sym);
value = binding_value(binding);
const wchar_t *new_namespec = desc->ad_new_libdesc->ld_namespec;
obj_t *new_library = find_library_str(new_namespec);
new_env = library_env(new_library);
obj_t *new_symbol = make_symbol_from_C_str(desc->ad_new_name);
env_bind(new_env, new_symbol, BT_LEXICAL, M_IMMUTABLE, value);
alias_descs = desc->ad_next;
}
POP_FUNCTION_ROOTS();
}
obj_t *env_lookup(env_t *env, obj_t *var)
{
/*
* for frame in env:
* for binding in frame:
* if binding.name == var:
* return binding
* assert False, 'unbound variable'
*/
assert(is_symbol(var));
#if ENV_TRACE
printf_unchecked("lookup(%ls, %O)\n", string_value(symbol_name(var)), env);
#endif
while (!is_null(env)) {
obj_t *frame = pair_car(env);
#if ENV_TRACE
if (pair_cdr(env)) {
printf(" FRAME");
obj_t *p = frame;
while (!is_null(p)) {
printf_unchecked(" %O: %O", binding_name(pair_car(p)),
binding_value(pair_car(p)));
p = pair_cdr(p);
}
printf("\n");
} else {
printf(" FRAME [builtins]\n");
}
#endif
while (!is_null(frame)) {
obj_t *binding = pair_car(frame);
assert(is_binding(binding));
if (binding_name(binding) == var) {
#if ENV_TRACE
printf(" found\n\n");
#endif
return binding;
}
frame = pair_cdr(frame);
}
env = pair_cdr(env);
}
fprintf(stderr, "unbound variable \"%ls\"\n",
string_value(symbol_name(var)));
assert(false && "unbound variable");
}
static obj_t *eval_symbol(void)
{
obj_t *binding = env_lookup(F_ENV, F_SUBJ);
return binding_value(binding);
}
