void bind_transformer(C_procedure_t *form, obj_t *library, const wchar_t *name)
{
AUTO_ROOT(env, library_env(library));
AUTO_ROOT(code, make_C_xformer_proc(form, NIL, env));
obj_t *sym = make_symbol_from_C_str(name);
POP_FUNCTION_ROOTS();
env_bind(env, sym, BT_LEXICAL, M_IMMUTABLE, code);
env_bind(root_env, sym, BT_LEXICAL, M_IMMUTABLE, code);
}
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();
}
void load_core(env *e) {
atom *a;
struct core_fn *fp = fns;
for (int i = 0; i < sizeof(fns)/sizeof(struct core_fn); fp++, i++) {
a = atom_make(A_FN, fp->name);
a->fn = fp->fn;
env_bind(e, fp->name, a);
}
}
atom *fn_define(env *e, atom *args) {
if (atom_len(args) != 2)
return atom_make(A_ERROR, "wrong number of args passed to define");
if (car(args)->typ != A_SYMBOL)
return atom_make(A_ERROR, "first arg must be symbol");
env_bind(e, car(args)->val, eval(e, car(cdr(args))));
return car(args);
}
// TODO: defun not acting same as (define x (lambda ...))
atom *fn_defun(env *e, atom *args) {
atom *name = car(args);
atom *fn = fn_lambda(e, cdr(args));
if (atom_len(args) != 3)
return atom_make(A_ERROR, "wrong number of args passed to defun");
if (car(args)->typ != A_SYMBOL)
return atom_make(A_ERROR, "first arg must be symbol");
env_bind(e, name->val, fn);
return name;
}
static cv_t c_continue_define(obj_t cont, obj_t values)
{
assert(is_cont5(cont));
EVAL_LOG("var=%O values=%O", cont5_arg1(cont), values);
/* N.B., allocate new values before mutating environment. */
obj_t new_values = CONS(make_unspecified(), cont5_arg2(cont));
obj_t ret = cont_cont(cont);
env_bind(cont_env(cont),
cont5_arg1(cont),
BT_LEXICAL,
M_MUTABLE,
CAR(values));
return cv(ret, new_values);
}
static void init_rec(rec_descriptor_t *desc)
{
/* Count the fields. */
const field_descriptor_t *fields = desc->rd_fields;
size_t i;
for (i = 0; ; i++) {
field_mutability_t m = fields[i].fd_mutability;
if (m == FM_END)
break;
assert(m == FM_MUTABLE || m == FM_IMMUTABLE);
}
size_t field_count = i;
obj_t field_vec = make_vector_uninitialized(field_count);
for (i = 0; i < field_count; i++) {
field_mutability_t m = fields[i].fd_mutability;
obj_t msym = make_symbol_from_C_str(m == FM_MUTABLE ? L"mutable"
: L"immutable");
obj_t nsym = make_symbol_from_C_str(fields[i].fd_name);
vector_set(field_vec, i, CONS(msym, CONS(nsym, EMPTY_LIST)));
}
/* Construct the rtd. */
obj_t nsym = make_symbol_from_C_str(desc->rd_name);
obj_t parent = desc->rd_parent ? *desc->rd_parent : FALSE_OBJ;
obj_t rtd = make_rtd(desc->rd_flags,
nsym,
parent,
FALSE_OBJ,
FALSE_OBJ,
field_vec);
*desc->rd_root = rtd;
if (desc->rd_flags & RF_OPAQUE) {
/* Do not create bindings for an opaque record type. */
return;
}
/* Bind the rtd to name. */
obj_t env = root_environment();
env_bind(env, nsym, BT_LEXICAL, M_IMMUTABLE, rtd);
/* Construct the constructor descriptor, constructor, predicate,
* field accessors, and field mutators.
*/
// XXX implement me. Maybe the rest should be in Scheme.
}
obj_t *apply_procedure(obj_t *proc, obj_t *args)
{
PUSH_ROOT(proc);
PUSH_ROOT(args);
AUTO_ROOT(body, procedure_body(proc));
if (procedure_is_C(proc)) {
obj_t *env = F_ENV;
if (!procedure_is_special_form(proc))
env = procedure_env(proc);
GOTO_FRAME(make_short_frame, (C_procedure_t *)body, args, env);
}
AUTO_ROOT(new_env, make_env(procedure_env(proc)));
AUTO_ROOT(formals, procedure_args(proc));
AUTO_ROOT(actuals, args);
while (!is_null(formals) || !is_null(actuals)) {
if (is_null(formals)) {
printf_unchecked("calling %O\n", proc);
RAISE("too many args");
}
obj_t *formal, *actual;
if (is_pair(formals)) {
if (is_null(actuals)) {
printf_unchecked("proc=%O\n", proc);
RAISE("not enough args");
}
formal = pair_car(formals);
formals = pair_cdr(formals);
actual = pair_car(actuals);
actuals = pair_cdr(actuals);
} else {
formal = formals;
actual = actuals;
formals = actuals = NIL;
}
env_bind(new_env, formal, BT_LEXICAL, M_MUTABLE, actual);
}
GOTO(b_eval_sequence, body, new_env);
}