Squashed 'lispBM/lispBM/' changes from 86722c10..2d281d94

2d281d94 added a allocate_list_init function and implemented mk_closure using it

git-subtree-dir: lispBM/lispBM
git-subtree-split: 2d281d94325a6e5b95833ecf0d5a370424cc09b7

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

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);

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;
 }