Ejemplo n.º 1
0
Archivo: proc.c Proyecto: kbob/kbscheme
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);
}
Ejemplo n.º 2
0
Archivo: proc.c Proyecto: kbob/kbscheme
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();
}
Ejemplo n.º 3
0
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);
  }
}
Ejemplo n.º 4
0
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); 
}
Ejemplo n.º 5
0
// 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; 
}
Ejemplo n.º 6
0
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);
}
Ejemplo n.º 7
0
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.
}
Ejemplo n.º 8
0
Archivo: eval.c Proyecto: kbob/kbscheme
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);
}