Merge commit '378490e865c4576654e5cee14f7901cd68bfa367'

lispBM/lispBM/README.md

@@ -23,7 +23,7 @@ LispBM runtime system.
 1. Are you interested in microcontrollers and programming languages?
 2. You find it fun to mess around in C code with close to zero comments?
 3. Then join in the fun. Lots to do, so little time!
-4. Poke me by mail bo(dot)joel(dot)svensson(whirly-a)gmail(dot)com
+4. Poke me by mail bo(dot)joel(dot)svensson(whirly-a)gmail(dot)com.
 
 ## Documentation
  - Work in progress [LispBM language reference](./doc/lbmref.md).

lispBM/lispBM/include/heap.h

@@ -303,7 +303,14 @@ lbm_uint lbm_heap_size_bytes(void);
  * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
  */
 lbm_value lbm_heap_allocate_cell(lbm_type type);
-
+/** allocate a number of heap cells from the heap.
+ *  The return value is a list of cons-cells. The car fields are uninitialized
+ *  and must be set by the caller of this function.
+ *
+ * \param len The number of cells to allocate.
+ * \return a list of cells.
+ */
+lbm_value lbm_heap_allocate_list(lbm_uint len);
 /** Decode an lbm_value representing a string into a C string
  *
  * \param val Value
@@ -396,6 +403,14 @@ lbm_value lbm_cadr(lbm_value c);
  * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
  */
 lbm_value lbm_cdr(lbm_value cons);
+/** Accesses the cdr of an cdr field of an lbm_cons_t.
+ *
+ * \param cons Value
+ * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
+ * If cons is nil, the return value is nil. If the value
+ * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
+ */
+lbm_value lbm_cddr(lbm_value c);
 /** Update the value stored in the car field of a heap cell.
  *
  * \param c Value referring to a heap cell.

lispBM/lispBM/src/eval_cps.c

@@ -41,35 +41,34 @@
 #define BIND_TO_KEY_REST      ((2 << LBM_VAL_SHIFT) | LBM_TYPE_U)
 #define IF                    ((3 << LBM_VAL_SHIFT) | LBM_TYPE_U)
 #define PROGN_REST            ((4 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define APPLICATION           ((5 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define APPLICATION_ARGS      ((5 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define APPLICATION_ARGS      ((6 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define AND                   ((6 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define AND                   ((7 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define OR                    ((7 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define OR                    ((8 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define WAIT                  ((8 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define WAIT                  ((9 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define MATCH                 ((9 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define MATCH                 ((10 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define MATCH_MANY            ((10 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define MATCH_MANY            ((11 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define READ                  ((11 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define READ                  ((12 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define APPLICATION_START     ((12 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define APPLICATION_START     ((13 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define EVAL_R                ((13 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define EVAL_R                ((14 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define SET_VARIABLE          ((14 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define SET_VARIABLE          ((15 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define RESUME                ((15 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define RESUME                ((16 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define CLOSURE_ARGS          ((16 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define CLOSURE_ARGS          ((17 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define EXIT_ATOMIC           ((17 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define EXIT_ATOMIC           ((18 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define READ_NEXT_TOKEN       ((18 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define READ_NEXT_TOKEN       ((19 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define READ_APPEND_CONTINUE  ((19 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define READ_APPEND_CONTINUE  ((20 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define READ_EXPECT_CLOSEPAR  ((20 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define READ_EXPECT_CLOSEPAR  ((21 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define READ_DOT_TERMINATE    ((21 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define READ_DOT_TERMINATE    ((22 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define READ_DONE             ((22 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define READ_DONE             ((23 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define READ_QUOTE_RESULT     ((23 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define READ_QUOTE_RESULT     ((24 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define READ_BACKQUOTE_RESULT ((24 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define READ_BACKQUOTE_RESULT ((25 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define READ_COMMAAT_RESULT   ((25 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define READ_COMMAAT_RESULT   ((26 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define READ_COMMA_RESULT     ((26 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define READ_COMMA_RESULT     ((27 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define READ_START_ARRAY      ((27 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define READ_START_ARRAY      ((28 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define READ_APPEND_ARRAY     ((28 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define READ_APPEND_ARRAY     ((29 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define MAP_FIRST             ((29 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define MAP_FIRST             ((30 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define MAP_REST              ((30 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define MAP_REST              ((31 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define MATCH_GUARD           ((31 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define MATCH_GUARD           ((32 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define NUM_CONTINUATIONS     32
-#define NUM_CONTINUATIONS     33
 
 #define FM_NEED_GC       -1
 #define FM_NO_MATCH      -2
@@ -1265,33 +1264,44 @@ static void eval_define(eval_context_t *ctx) {
 }
 
 // (closure params body env)
-static lbm_value mk_closure(lbm_value env, lbm_value body, lbm_value params) {
+static bool mk_closure(lbm_value *res, lbm_value env, lbm_value body, lbm_value params) {
-  if (lbm_heap_num_free() < 4) {
+  lbm_value clo;
+  clo = lbm_heap_allocate_list(4);
+  if (lbm_is_symbol_merror(clo)) {
     lbm_gc_mark_phase(env);
     lbm_gc_mark_phase(body);
     lbm_gc_mark_phase(params);
     gc();
+    clo = lbm_heap_allocate_list(4);
+    if (lbm_is_symbol_merror(clo)) {
+      return false;
+    }
   }
-  if (lbm_heap_num_free() >= 4) {
+
-    lbm_value env_end = lbm_cons(env, ENC_SYM_NIL);
+  lbm_value clo1 = lbm_cdr(clo);
-    lbm_value exp = lbm_cons(body, env_end);
+  lbm_value clo2 = lbm_cdr(clo1);
-    lbm_value par = lbm_cons(params, exp);
+  lbm_value clo3 = lbm_cdr(clo2);
-    lbm_value clo = lbm_cons(ENC_SYM_CLOSURE, par);
+  lbm_set_car(clo, ENC_SYM_CLOSURE);
-    return clo;
+  lbm_set_car(clo1, params);
-  }
+  lbm_set_car(clo2, body);
-  return ENC_SYM_MERROR;
+  lbm_set_car(clo3, env);
+  *res = clo;
+  return true;
 }
 
 static void eval_lambda(eval_context_t *ctx) {
-  lbm_value closure = mk_closure(ctx->curr_env, lbm_cadr(lbm_cdr(ctx->curr_exp)),  lbm_cadr(ctx->curr_exp));
+  lbm_value closure;
-  ctx->app_cont = true;
+  if (mk_closure(&closure, ctx->curr_env, lbm_cadr(lbm_cdr(ctx->curr_exp)),  lbm_cadr(ctx->curr_exp))) {
-  ctx->r = closure;
+    ctx->app_cont = true;
-  return;
+    ctx->r = closure;
+  } else {
+    error_ctx(ENC_SYM_MERROR);
+  }
 }
 
 static void eval_if(eval_context_t *ctx) {
 
-  lbm_value cddr = lbm_cdr(lbm_cdr(ctx->curr_exp));
+  lbm_value cddr = lbm_cddr(ctx->curr_exp);
   lbm_value then_branch = lbm_car(cddr);
   lbm_value else_branch = lbm_cadr(cddr);
 
@@ -1493,7 +1503,8 @@ static void cont_set_global_env(eval_context_t *ctx){
 
   lbm_pop(&ctx->K, &key);
   lbm_value new_env;
-  WITH_GC_1(new_env, lbm_env_set(*lbm_get_env_ptr(),key,val), key);
+  // A key is a symbol and should not need to be remembered.
+  WITH_GC(new_env, lbm_env_set(*lbm_get_env_ptr(),key,val));
 
   *lbm_get_env_ptr() = new_env;
   ctx->r = key;
@@ -1735,8 +1746,14 @@ static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
 }
 
 static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
-  ctx->curr_exp = args[1];
+  if (nargs == 0) {
-  lbm_stack_drop(&ctx->K, nargs+1);
+    lbm_stack_drop(&ctx->K, 1);
+    ctx->r = ENC_SYM_NIL;
+    ctx->app_cont = true;
+  } else {
+    ctx->curr_exp = args[1];
+    lbm_stack_drop(&ctx->K, nargs+1);
+  }
 }
 
 static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
@@ -1849,9 +1866,14 @@ static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
       WITH_GC_1(body_1, lbm_cons(args[1], body_0),body_0);
       lbm_value body;
       WITH_GC_1(body, lbm_cons(args[0], body_1), body_0);
-      ctx->r = mk_closure(ENC_SYM_NIL,body, params);
+      lbm_value closure;
-      lbm_stack_drop(&ctx->K, 2);
+      if (mk_closure(&closure, ENC_SYM_NIL, body, params)) {
-      ctx->app_cont = true;
+        ctx->r = closure;
+        lbm_stack_drop(&ctx->K, 2);
+        ctx->app_cont = true;
+      } else {
+        error_ctx(ENC_SYM_MERROR);
+      }
     } else {
       error_ctx(ENC_SYM_FATAL_ERROR);
     }
@@ -1882,35 +1904,6 @@ static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx)
   }
 }
 
-static void apply_extension(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
-  extension_fptr f = lbm_get_extension(lbm_dec_sym(args[0]));
-  if (f == NULL) {
-    error_ctx(ENC_SYM_EERROR);
-    return;
-  }
-
-  lbm_value ext_res;
-  WITH_GC(ext_res, f(&args[1] , nargs));
-  if (lbm_is_error(ext_res)) {
-    error_ctx(ext_res);
-    return;
-  }
-  lbm_stack_drop(&ctx->K, nargs + 1);
-
-  if (blocking_extension) {
-    blocking_extension = false;
-    ctx->timestamp = timestamp_us_callback();
-    ctx->sleep_us = 0;
-    ctx->app_cont = true;
-    enqueue_ctx(&blocked,ctx);
-    ctx_running = NULL;
-  } else {
-    ctx->app_cont = true;
-    ctx->r = ext_res;
-  }
-}
-
-
 /***************************************************/
 /* Application lookup table                        */
 
@@ -1933,19 +1926,11 @@ static const apply_fun fun_table[] =
    apply_reverse
   };
 
+/***************************************************/
+/* Application of function that takes arguments    */
+/* passed over the stack.                          */
 
-static void cont_application(eval_context_t *ctx) {
+static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
-  lbm_value count;
-  lbm_pop(&ctx->K, &count);
-
-  lbm_uint arg_count = lbm_dec_u(count);
-
-  lbm_uint *fun_args = lbm_get_stack_ptr(&ctx->K, arg_count+1);
-
-  if (fun_args == NULL) {
-    error_ctx(ENC_SYM_FATAL_ERROR);
-    return;
-  }
   lbm_value fun = fun_args[0];
   if (lbm_is_continuation(fun)) {
 
@@ -1977,25 +1962,48 @@ static void cont_application(eval_context_t *ctx) {
   } else if (lbm_type_of(fun) == LBM_TYPE_SYMBOL) {
     /* eval_cps specific operations */
     lbm_uint sym_val = lbm_dec_sym(fun) - APPLY_FUNS_START;
-    lbm_uint num_args = lbm_dec_u(count);
 
     if (sym_val <= APPLY_FUNS_END) {
-      fun_table[sym_val](fun_args, num_args, ctx);
+      fun_table[sym_val](fun_args, arg_count, ctx);
     } else if (lbm_is_fundamental(fun)) {
       lbm_uint fund_ix = lbm_dec_sym(fun) -  FUNDAMENTALS_START;
 
       lbm_value res;
-      WITH_GC(res, fundamental_table[fund_ix](&fun_args[1], num_args, ctx));
+      WITH_GC(res, fundamental_table[fund_ix](&fun_args[1], arg_count, ctx));
       if (lbm_is_error(res)) {
         error_ctx(res);
         return;
       }
-      lbm_stack_drop(&ctx->K, num_args+1);
+      lbm_stack_drop(&ctx->K, arg_count+1);
       ctx->app_cont = true;
       ctx->r = res;
     } else {
       // It may be an extension
-      apply_extension(fun_args, num_args, ctx);
+      extension_fptr f = lbm_get_extension(lbm_dec_sym(fun));
+      if (f == NULL) {
+        error_ctx(ENC_SYM_EERROR);
+        return;
+      }
+
+      lbm_value ext_res;
+      WITH_GC(ext_res, f(&fun_args[1], arg_count));
+      if (lbm_is_error(ext_res)) {
+        error_ctx(ext_res);
+        return;
+      }
+      lbm_stack_drop(&ctx->K, arg_count + 1);
+
+      if (blocking_extension) {
+        blocking_extension = false;
+        ctx->timestamp = timestamp_us_callback();
+        ctx->sleep_us = 0;
+        ctx->app_cont = true;
+        enqueue_ctx(&blocked,ctx);
+        ctx_running = NULL;
+      } else {
+        ctx->app_cont = true;
+        ctx->r = ext_res;
+      }
     }
   } else {
     error_ctx(ENC_SYM_EERROR);
@@ -2039,10 +2047,14 @@ static void cont_closure_application_args(eval_context_t *ctx) {
     error_ctx(ENC_SYM_EERROR);
   } else if (a_nil && !p_nil) {
     lbm_value new_env = lbm_list_append(arg_env,clo_env);
-    lbm_value closure = mk_closure(new_env, exp, lbm_cdr(params));
+    lbm_value closure;
-    lbm_stack_drop(&ctx->K, 5);
+    if (mk_closure(&closure, new_env, exp, lbm_cdr(params))) {
-    ctx->app_cont = true;
+      lbm_stack_drop(&ctx->K, 5);
-    ctx->r = closure;
+      ctx->app_cont = true;
+      ctx->r = closure;
+    } else {
+      error_ctx(ENC_SYM_MERROR);
+    }
   } else {
    sptr[2] = clo_env;
    sptr[3] = lbm_cdr(params);
@@ -2070,9 +2082,16 @@ static void cont_application_args(eval_context_t *ctx) {
   ctx->curr_env = env;
   sptr[0] = arg;
   if (lbm_is_symbol_nil(rest)) {
-    // no arguments
+    // No more arguments
-    lbm_stack_drop(&ctx->K, 1);
+    lbm_stack_drop(&ctx->K, 2);
-    cont_application(ctx);
+    lbm_uint nargs = lbm_dec_u(count);
+    lbm_value *args = lbm_get_stack_ptr(&ctx->K, nargs + 1);
+    if (args) {
+      application(ctx,args, nargs);
+    } else {
+      error_ctx(ENC_SYM_FATAL_ERROR);
+      return;
+    }
   } else if (lbm_is_cons(rest)) {
     sptr[1] = env;
     sptr[2] = lbm_enc_u(lbm_dec_u(count) + 1);
@@ -2920,7 +2939,6 @@ static const cont_fun continuations[NUM_CONTINUATIONS] =
     cont_bind_to_key_rest,
     cont_if,
     cont_progn_rest,
-    cont_application,
     cont_application_args,
     cont_and,
     cont_or,

lispBM/lispBM/src/heap.c

@@ -550,6 +550,41 @@ lbm_value lbm_heap_allocate_cell(lbm_type ptr_type) {
   return res;
 }
 
+lbm_value lbm_heap_allocate_list(lbm_uint len) {
+  lbm_value res;
+
+  if (lbm_heap_num_free() < len) {
+    return ENC_SYM_MERROR;
+  }
+
+  res = lbm_heap_state.freelist;
+
+  lbm_value curr = lbm_heap_state.freelist;
+  lbm_uint i = 0;
+  while (lbm_type_of(curr) == LBM_TYPE_CONS) {
+
+    if (i == len) {
+      lbm_heap_state.freelist = curr;
+      break;
+    }
+    if (i == len - 1) {
+      lbm_set_cdr(curr, ENC_SYM_NIL);
+      if (lbm_type_of(lbm_cdr(curr)) == LBM_TYPE_SYMBOL) {
+        lbm_heap_state.freelist = ENC_SYM_NIL;
+        break;
+      }
+    }
+    curr = lbm_cdr(curr);
+    i++;
+  }
+
+  if (i == len || i == len - 1) {
+    return res;
+  }
+  return ENC_SYM_MERROR;
+
+}
+
 lbm_uint lbm_heap_num_allocated(void) {
   return lbm_heap_state.num_alloc;
 }
@@ -778,6 +813,20 @@ lbm_value lbm_cdr(lbm_value c){
   return ENC_SYM_TERROR;
 }
 
+lbm_value lbm_cddr(lbm_value c) {
+
+  lbm_value tmp = ENC_SYM_NIL;
+  if (lbm_is_ptr(c)) {
+    tmp = lbm_ref_cell(c)->cdr;
+    if (lbm_is_ptr(tmp)) {
+      return lbm_ref_cell(tmp)->cdr;
+    }
+  }
+  if (lbm_is_symbol(c) && lbm_dec_sym(c) == SYM_NIL) {
+    return ENC_SYM_NIL;
+  }
+  return ENC_SYM_TERROR;
+}
 
 int lbm_set_car(lbm_value c, lbm_value v) {
   int r = 0;

lispBM/lispBM/src/lbm_memory.c

@@ -298,27 +298,32 @@ lbm_uint *lbm_memory_allocate(lbm_uint num_words) {
 
 int lbm_memory_free(lbm_uint *ptr) {
 
-  mutex_lock(&lbm_mem_mutex);
+  int r = 0;
-  lbm_uint ix = address_to_bitmap_ix(ptr);
+  if (lbm_memory_ptr_inside(ptr)) {
+    mutex_lock(&lbm_mem_mutex);
+    lbm_uint ix = address_to_bitmap_ix(ptr);
 
-  switch(status(ix)) {
+    switch(status(ix)) {
-  case START:
+    case START:
-    set_status(ix, FREE_OR_USED);
+      set_status(ix, FREE_OR_USED);
-    for (lbm_uint i = ix; i < (bitmap_size << BITMAP_SIZE_SHIFT); i ++) {
+      for (lbm_uint i = ix; i < (bitmap_size << BITMAP_SIZE_SHIFT); i ++) {
-      if (status(i) == END) {
+        if (status(i) == END) {
-        set_status(i, FREE_OR_USED);
+          set_status(i, FREE_OR_USED);
-        mutex_unlock(&lbm_mem_mutex);
+          r = 1;
-        return 1;
+          break;
+        }
       }
+      break;
+    case START_END:
+      set_status(ix, FREE_OR_USED);
+      r = 1;
+      break;
+    default:
+      break;
     }
-    return 0;
-  case START_END:
-    set_status(ix, FREE_OR_USED);
     mutex_unlock(&lbm_mem_mutex);
-    return 1;
   }
-  mutex_unlock(&lbm_mem_mutex);
+  return r;
-  return 0;
 }
 
 int lbm_memory_shrink(lbm_uint *ptr, lbm_uint n) {
@@ -382,10 +387,6 @@ int lbm_memory_shrink(lbm_uint *ptr, lbm_uint n) {
 }
 
 int lbm_memory_ptr_inside(lbm_uint *ptr) {
-  int r = 0;
+  return ((lbm_uint)ptr >= (lbm_uint)memory &&
-
+          (lbm_uint)ptr < (lbm_uint)memory + (memory_size * sizeof(lbm_uint)));
-  if ((lbm_uint)ptr >= (lbm_uint)memory &&
-      (lbm_uint)ptr < (lbm_uint)memory + (memory_size * sizeof(lbm_uint)))
-    r = 1;
-  return r;
 }