diff --git a/include/heap.h b/include/heap.h index 8e51ff29..c595ff27 100644 --- a/include/heap.h +++ b/include/heap.h @@ -308,6 +308,13 @@ lbm_value lbm_heap_allocate_cell(lbm_type type); * \return A list of heap-cells of Memory error if unable to allocate. */ lbm_value lbm_heap_allocate_list(unsigned int n); +/** Allocate a list of n heap-cells and initialize the values. + * \pram ls The result list is passed through this ptr. + * \param m The length of list to allocate. + * \param ... The values to initialize the list with. + * \return True of False depending on success of allocation. + */ +bool lbm_heap_allocate_list_init(lbm_value *ls, unsigned int n, ...); /** Decode an lbm_value representing a string into a C string * * \param val Value diff --git a/src/eval_cps.c b/src/eval_cps.c index 6dd5defa..3dd19a4a 100644 --- a/src/eval_cps.c +++ b/src/eval_cps.c @@ -1264,25 +1264,34 @@ static void eval_define(eval_context_t *ctx) { } // (closure params body env) -static bool mk_closure(lbm_value *res, lbm_value env, lbm_value body, lbm_value params) { - if (lbm_heap_num_free() < 4) { - lbm_gc_mark_phase(3, env, body, params); - gc(); +static bool mk_closure(lbm_value *closure, lbm_value env, lbm_value body, lbm_value params) { + + bool ret = lbm_heap_allocate_list_init(closure, + 4, + ENC_SYM_CLOSURE, + params, + body, + env); + if (!ret) { + lbm_gc_mark_phase(3, env, body, params); + gc(); + ret = lbm_heap_allocate_list_init(closure, + 4, + ENC_SYM_CLOSURE, + params, + body, + env); } - if (lbm_heap_num_free() >= 4) { - lbm_value env_end = lbm_cons(env, ENC_SYM_NIL); - lbm_value exp = lbm_cons(body, env_end); - lbm_value par = lbm_cons(params, exp); - lbm_value clo = lbm_cons(ENC_SYM_CLOSURE, par); - *res = clo; - return true; - } - return false; + return ret; } static void eval_lambda(eval_context_t *ctx) { lbm_value closure; - if (mk_closure(&closure, ctx->curr_env, lbm_cadr(lbm_cdr(ctx->curr_exp)), lbm_cadr(ctx->curr_exp))) { + + if (mk_closure(&closure, + ctx->curr_env, + lbm_cadr(lbm_cdr(ctx->curr_exp)), + lbm_cadr(ctx->curr_exp))) { ctx->app_cont = true; ctx->r = closure; } else { @@ -1867,7 +1876,7 @@ static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { WITH_GC_RMBR(body_1, lbm_cons(args[1], body_0), 1, body_0); lbm_value body; WITH_GC_RMBR(body, lbm_cons(args[0], body_1), 1, body_0); - lbm_value closure; + lbm_value closure; ; if (mk_closure(&closure, ENC_SYM_NIL, body, params)) { ctx->r = closure; lbm_stack_drop(&ctx->K, 2); diff --git a/src/heap.c b/src/heap.c index 981ab6b1..2866130e 100644 --- a/src/heap.c +++ b/src/heap.c @@ -566,6 +566,35 @@ lbm_value lbm_heap_allocate_list(unsigned int n) { } } +bool lbm_heap_allocate_list_init(lbm_value *ls, unsigned int n, ...) { + if (n == 0) { + *ls = ENC_SYM_NIL; + return true; + } + if (lbm_heap_num_free() < n) return false; + + lbm_value res = lbm_heap_state.freelist; + if (lbm_type_of(res) == LBM_TYPE_CONS) { + va_list valist; + va_start(valist, n); + lbm_value curr = res; + unsigned int count = 1; + while (lbm_type_of(curr) == LBM_TYPE_CONS && count < n) { + lbm_ref_cell(curr)->car = va_arg(valist, lbm_value); + curr = lbm_cdr(curr); + count ++; + } + lbm_set_car(curr, va_arg(valist, lbm_value)); + lbm_heap_state.freelist = lbm_cdr(curr); + lbm_set_cdr(curr, ENC_SYM_NIL); + lbm_heap_state.num_alloc+=count; + va_end(valist); + *ls = res; + return true; + } + return false; +} + lbm_uint lbm_heap_num_allocated(void) { return lbm_heap_state.num_alloc; }