Merge commit '1e2b53cbbc3026128fc2b4a1a2c4aaf16b048dd8'

lispBM/lispBM/doc/lbmref.md

@@ -875,6 +875,47 @@ Example that creates the list (1 2 3 4).
 
 ---
 
+### length
+
+Computes the length of a list. The `length` function takes
+one argument and is of the form `(length expr)`.
+
+Example that evaluates to 4
+```clj
+
+(length (list 1 2 3 4))
+```
+
+---
+
+### range
+
+The `range` function computes a list with integer values from a
+range specified by its endpoints. The form of a range expression
+is `(range start-expr end-expr)`. The end point in the range is excluded.
+
+Example that generates the list (4 5 6 7).
+```clj
+(range 4 8)
+```
+
+A range specified with the end-point being smaller than the
+starting point is in descending order.
+
+Example that generates the list (7 6 5 4).
+```clj
+(range 8 4)
+```
+
+Negative number can be used to specify a range
+
+Example that generates the list (-10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 7 8 9)
+```clj
+(range -10 10)
+```
+
+---
+
 ### append
 
 The `append` function combines two lists into a longer list.

lispBM/lispBM/include/lbm_defines.h

@@ -261,7 +261,9 @@
 #define SYM_BITWISE_NOT         0x234
 #define SYM_CUSTOM_DESTRUCT     0x235 /* run the destructor of a custom type */
 #define SYM_TYPE_OF             0x236
-#define FUNDAMENTALS_END        0x236
+#define SYM_LIST_LENGTH         0x237
+#define SYM_RANGE               0x238
+#define FUNDAMENTALS_END        0x238
 
 #define SPECIAL_SYMBOLS_START    0
 #define SPECIAL_SYMBOLS_END      0xFFFF

lispBM/lispBM/repl/repl.c

@@ -271,11 +271,7 @@ bool dyn_load(const char *str, const char **code) {
             "(revacc nil xs))))";
     res = true;
   } else if (strlen(str) == 4 && strncmp(str, "iota", 4) == 0) {
-    *code = "(define iota (lambda (n)"
-            "(let ((iacc (lambda (acc i)"
-            "(if (< i 0) acc"
-            "(iacc (cons i acc) (- i 1))))))"
-            "(iacc nil (- n 1)))))";
+    *code = "(define iota (lambda (n) (range 0 n)))";
     res = true;
   } else if (strlen(str) == 6 && strncmp(str, "length", 6) == 0) {
     *code = "(define length (lambda (xs)"

lispBM/lispBM/src/eval_cps.c

@@ -1483,7 +1483,7 @@ static void eval_match(eval_context_t *ctx) {
     ctx->r = ENC_SYM_NIL;
     return;
   } else {
-    CHECK_STACK(lbm_push_2(&ctx->K, lbm_cdr(rest), MATCH));
+    CHECK_STACK(lbm_push_3(&ctx->K, lbm_cdr(rest), ctx->curr_env, MATCH));
     ctx->curr_exp = lbm_car(rest); /* Evaluate e next*/
   }
 }
@@ -2173,10 +2173,11 @@ static void cont_match_many(eval_context_t *ctx) {
 static void cont_match(eval_context_t *ctx) {
   lbm_value e = ctx->r;
   lbm_value patterns;
-  lbm_value new_env = ctx->curr_env;
+  lbm_value new_env;
   bool  do_gc = false;
-
+  lbm_pop(&ctx->K, &new_env); // restore enclosing environment
   lbm_pop(&ctx->K, &patterns);
+  ctx->curr_env = new_env;
 
   if (lbm_is_symbol_nil(patterns)) {
     /* no more patterns */
@@ -2205,7 +2206,7 @@ static void cont_match(eval_context_t *ctx) {
       ctx->curr_exp = body;
     } else {
       /* set up for checking of next pattern */
-      CHECK_STACK(lbm_push_2(&ctx->K, lbm_cdr(patterns), MATCH));
+      CHECK_STACK(lbm_push_3(&ctx->K, lbm_cdr(patterns),ctx->curr_env, MATCH));
       /* leave r unaltered */
       ctx->app_cont = true;
     }

lispBM/lispBM/src/fundamental.c

@@ -518,8 +518,15 @@ static int elt_size(lbm_type t) {
   }
 }
 
-static lbm_value index_list(lbm_value l, unsigned int n) {
+static lbm_value index_list(lbm_value l, int32_t n) {
   lbm_value curr = l;
+
+  if (n < 0) {
+    int32_t len = (int32_t)lbm_list_length(l);
+    n = len + n;
+    if (n < 0) return ENC_SYM_NIL;
+  }
+
   while ( lbm_type_of(curr) == LBM_TYPE_CONS &&
           n > 0) {
     curr = lbm_cdr(curr);
@@ -893,7 +900,7 @@ static lbm_value fundamental_append(lbm_value *args, lbm_uint nargs, eval_contex
   }
 
   for (int i = n-1; i >= 0; i --) {
-    result = lbm_cons(index_list(a,(unsigned int)i), result);
+    result = lbm_cons(index_list(a,i), result);
     if (lbm_type_of(result) == LBM_TYPE_SYMBOL)
       break;
   }
@@ -1162,7 +1169,7 @@ static lbm_value fundamental_ix(lbm_value *args, lbm_uint nargs, eval_context_t
   (void) ctx;
   lbm_value result = ENC_SYM_EERROR;
   if (nargs == 2 && lbm_is_number(args[1])) {
-    result = index_list(args[0], lbm_dec_as_u32(args[1]));
+    result = index_list(args[0], lbm_dec_as_i32(args[1]));
   }
   return result;
 }
@@ -1404,6 +1411,57 @@ static lbm_value fundamental_type_of(lbm_value *args, lbm_uint nargs, eval_conte
   return ENC_SYM_TERROR;
 }
 
+static lbm_value fundamental_list_length(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
+  (void) ctx;
+  lbm_value result = ENC_SYM_EERROR;
+  if (nargs == 1 && lbm_is_list(args[0])) {
+    int32_t len = (int32_t)lbm_list_length(args[0]);
+    result = lbm_enc_i(len);
+  }
+  return result;
+}
+
+static lbm_value fundamental_range(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
+  (void) ctx;
+  lbm_value result = ENC_SYM_EERROR;
+
+  int32_t start;
+  int32_t end;
+  bool rev = false;
+
+  if (nargs == 1 && lbm_is_number(args[0])) {
+    start = 0;
+    end = lbm_dec_as_i32(args[0]);
+  } else if (nargs == 2 &&
+             lbm_is_number(args[0]) &&
+             lbm_is_number(args[1])) {
+    start = lbm_dec_as_i32(args[0]);
+    end = lbm_dec_as_i32(args[1]);
+  } else {
+    return result;
+  }
+
+  if (end == start) return ENC_SYM_NIL;
+  else if (end < start) {
+    int32_t tmp = end;
+    end = start;
+    start = tmp;
+    rev = true;
+  }
+
+  int num = end - start;
+
+  if ((unsigned int)num > lbm_heap_num_free()) {
+    return ENC_SYM_MERROR;
+  }
+
+  lbm_value r_list = ENC_SYM_NIL;
+  for (int i = end - 1; i >= start; i --) {
+    r_list = lbm_cons(lbm_enc_i(i), r_list);
+  }
+  return rev ? lbm_list_destructive_reverse(r_list) : r_list;
+}
+
 const fundamental_fun fundamental_table[] =
   { fundamental_add,
     fundamental_sub,
@@ -1459,5 +1517,7 @@ const fundamental_fun fundamental_table[] =
     fundamental_bitwise_xor,
     fundamental_bitwise_not,
     fundamental_custom_destruct,
-    fundamental_type_of
+    fundamental_type_of,
+    fundamental_list_length,
+    fundamental_range
   };

lispBM/lispBM/src/symrepr.c

@@ -172,6 +172,8 @@ special_sym const special_symbols[] =  {
   {"setcar"           , SYM_SET_CAR},
   {"setcdr"           , SYM_SET_CDR},
   {"setix"            , SYM_SET_IX},
+  {"length"           , SYM_LIST_LENGTH},
+  {"range"            , SYM_RANGE},
 
   {"assoc"          , SYM_ASSOC}, // lookup an association
   {"cossa"          , SYM_COSSA}, // lookup an association "backwards"

lispBM/lispBM/tests/test_callcc_0.lisp

@@ -12,3 +12,4 @@
 
 (and (= (g 1 0) 1001)
      (= (g 1 1) 2))
+

lispBM/lispBM/tests/test_ix_3.lisp

@@ -0,0 +1,7 @@
+(define apa '(1 2 3 4 5 6 7 8 9 10))
+
+
+(and (= (ix apa -10) 1)
+     (= (ix apa 0) 1)
+     (= (ix apa -9) 2)
+     (= (ix apa 1) 2))

lispBM/lispBM/tests/test_ix_4.lisp

@@ -0,0 +1,7 @@
+(define apa '(1 2 3 4 5 6 7 8 9 10))
+
+
+(and (= (ix apa -6) 5)
+     (= (ix apa 4) 5)
+     (= (ix apa -4) 7)
+     (= (ix apa 6) 7))

lispBM/lispBM/tests/test_lisp_code_cps.c

@@ -115,17 +115,7 @@ bool dyn_load(const char *str, const char **code) {
     res = true;
   } else if (strlen(str) == 4 && strncmp(str, "iota", 4) == 0) {
     *code = "(define iota (lambda (n)"
-            "(let ((iacc (lambda (acc i)"
-            "(if (< i 0) acc"
-            "(iacc (cons i acc) (- i 1))))))"
-            "(iacc nil n))))";
-    res = true;
-  } else if (strlen(str) == 6 && strncmp(str, "length", 6) == 0) {
-    *code = "(define length (lambda (xs)"
-            "(let ((len (lambda (l xs)"
-            "(if (eq xs nil) l"
-            "(len (+ l 1) (cdr xs))))))"
-            "(len 0 xs))))";
+            "(range 0 n)))";
     res = true;
   } else if (strlen(str) == 4 && strncmp(str, "take", 4) == 0) {
     *code = "(define take (lambda (n xs)"

lispBM/lispBM/tests/test_list_2.lisp

@@ -0,0 +1,4 @@
+
+(define l '(1 2 3 4 5 6 7 8))
+
+(= (length l) 8)

lispBM/lispBM/tests/test_list_3.lisp

@@ -0,0 +1,2 @@
+
+(= (length (iota 101)) 101)

lispBM/lispBM/tests/test_list_4.lisp

@@ -0,0 +1,2 @@
+
+(= (length 'nil) 0)

lispBM/lispBM/tests/test_match_7.lisp

@@ -0,0 +1,5 @@
+
+(eq (match (+ 1 2)
+          ( 3  't)
+          ( _  'nil))
+   't)

lispBM/lispBM/tests/test_match_8.lisp

@@ -0,0 +1,7 @@
+
+(define f (lambda (x) (+ x 2)))
+
+(eq (match (f 1)
+          ( 3  't)
+          ( _  'nil))
+   't)

lispBM/lispBM/tests/test_match_9.lisp

@@ -0,0 +1,10 @@
+(defun test (x) x)
+
+( = (let ((a 1))
+      (match (test 75)
+             (75  a)))
+    1)
+
+;; (= (let ( (a 1) )
+;;      (test a))
+;;    1)

lispBM/lispBM/tests/test_range_0.lisp

@@ -0,0 +1,3 @@
+
+
+(eq (range 5) '(0 1 2 3 4))

lispBM/lispBM/tests/test_range_1.lisp

@@ -0,0 +1,3 @@
+
+
+(eq (range 2 5) '(2 3 4))

lispBM/lispBM/tests/test_range_2.lisp

@@ -0,0 +1,4 @@
+
+(eq (let (( a 10))
+      (range a (+ a 5)))
+    '(10 11 12 13 14))

lispBM/lispBM/tests/test_range_3.lisp

@@ -0,0 +1,2 @@
+
+(eq (range 10 4) '(9 8 7 6 5 4))

lispBM/lispBM/tests/test_range_4.lisp

@@ -0,0 +1,3 @@
+
+
+(eq (range 10 4) (reverse (range 4 10)))

lispBM/lispBM/tests/test_take_iota_0.lisp

@@ -1,2 +1,2 @@
 
-(eq (take 100 (iota 1000)) (iota 99))
+(eq (take 100 (iota 1000)) (iota 100))