add list function

14 files changed, 167 insertions, 62 deletions

diff --git a/Readme.md b/Readme.md
index 7f54db2..beabd47 100644
--- a/Readme.md
+++ b/Readme.md
@@ -2,7 +2,7 @@
 
 Embeddable & Hackable Lisp-2 Interpreter
 
-## Features & Drawbacks
+## Features
 
 - Lisp-2 (more like Common Lisp or Emacs Lisp)
 - Lexical scoping
@@ -10,7 +10,6 @@ Embeddable & Hackable Lisp-2 Interpreter
 - Tail call optimization
 - Any C99 compiler should work
 - Depends only on C standard library
-- SLOW (trade-off for simplicity)
 - A simple mark-sweep GC
 - Writing macro is easy with quasiquote, unquote, and slicing-unquote
 - No global state, you can run multiple interpreters in multiple threads
@@ -19,6 +18,10 @@ Embeddable & Hackable Lisp-2 Interpreter
     - break
     - continue
 
+## Drawbacks
+
+Bamboo Lisp is VERY SLOW tree-walking interpreter. The performance is only 1/5 to 1/10 that of Python, similar to other small interpreters like TinyScheme or very early Emacs Lisp.
+
 ## Build
 
 Init submodule:
diff --git a/src/builtins.c b/src/builtins.c
index 48cb4f0..04afbcb 100644
--- a/src/builtins.c
+++ b/src/builtins.c
@@ -6,6 +6,84 @@
 #include <float.h>
 #include <math.h>
 
+SExpRef builtin_set_car(Interp *interp, SExpRef args) {
+    if (LENGTH(args) != 2) {
+        return new_error(interp, "set-car: args num error.\n");
+    }
+    SExpRef lst = CAR(args), elem = CADR(args);
+    if (VALTYPE(lst) != kPairSExp) {
+        return new_error(interp, "set-car: type error.");
+    }
+    REF(lst)->pair.car = elem;
+    return NIL;
+}
+
+SExpRef builtin_set_cdr(Interp *interp, SExpRef args) {
+    if (LENGTH(args) != 2) {
+        return new_error(interp, "set-cdr: args num error.\n");
+    }
+    SExpRef lst = CAR(args), elem = CADR(args);
+    if (VALTYPE(lst) != kPairSExp) {
+        return new_error(interp, "set-cdr: type error.");
+    }
+    REF(lst)->pair.cdr = elem;
+    return NIL;
+}
+
+SExpRef builtin_length(Interp *interp, SExpRef args) {
+    if (LENGTH(args) != 1) {
+        return new_error(interp, "length: args num error.\n");
+    }
+    int len = LENGTH(CAR(args));
+    if (len < 0) {
+        return new_error(interp, "length: type error.\n");
+    }
+    return new_integer(interp, len);
+}
+
+SExpRef builtin_nth(Interp *interp, SExpRef args) {
+    if (LENGTH(args) != 2) {
+        return new_error(interp, "nth: args num error.\n");
+    }
+    SExpRef n = CAR(args), lst = CADR(args);
+    if (VALTYPE(n) != kIntegerSExp) return new_error(interp, "nth: type error.\n");
+    if (VALTYPE(lst) == kPairSExp) {
+        if (REF(n)->integer >= LENGTH(lst)) {
+            return new_error(interp, "nth: out of bound.\n");
+        }
+        for (int i = 0; i < REF(n)->integer; i++) {
+            lst = CDR(lst);
+        }
+        return CAR(lst);
+    } else if (VALTYPE(lst) == kStringSExp) {
+        if (REF(n)->integer >= strlen(REF(lst)->str)) {
+            return new_error(interp, "nth: out of bound\n");
+        }
+        return new_char(interp, REF(lst)->str[REF(n)->integer]);
+    } else {
+        return new_error(interp, "nth: type error.\n");
+    }
+}
+
+SExpRef builtin_nthcdr(Interp *interp, SExpRef args) {
+    if (LENGTH(args) != 2) {
+        return new_error(interp, "nth: args num error.\n");
+    }
+    SExpRef n = CAR(args), lst = CADR(args);
+    if (VALTYPE(n) != kIntegerSExp) return new_error(interp, "nth: type error.\n");
+    if (VALTYPE(lst) == kPairSExp) {
+        if (REF(n)->integer >= LENGTH(lst)) {
+            return new_error(interp, "nth: out of bound.\n");
+        }
+        for (int i = 0; i < REF(n)->integer; i++) {
+            lst = CDR(lst);
+        }
+        return CDR(lst);
+    } else {
+        return new_error(interp, "nth: type error.\n");
+    }
+}
+
 SExpRef builtin_string(Interp *interp, SExpRef args) {
     for (SExpRef i = args; !NILP(i); i = CDR(i)) {
         SExpRef x = CAR(i);
diff --git a/src/builtins.h b/src/builtins.h
index 608df98..3832afb 100644
--- a/src/builtins.h
+++ b/src/builtins.h
@@ -3,15 +3,11 @@
 
 #include "interp.h"
 
-// - char=
-// - char>
-// - char<
-// - char>=
-// - char<=
-// - char/=
-// - ord
-// - chr
-
+SExpRef builtin_set_car(Interp *interp, SExpRef args);
+SExpRef builtin_set_cdr(Interp *interp, SExpRef args);
+SExpRef builtin_length(Interp *interp, SExpRef args);
+SExpRef builtin_nth(Interp *interp, SExpRef args);
+SExpRef builtin_nthcdr(Interp *interp, SExpRef args);
 SExpRef builtin_string(Interp *interp, SExpRef args);
 SExpRef builtin_string_eq(Interp *interp, SExpRef args);
 SExpRef builtin_string_gt(Interp *interp, SExpRef args);
diff --git a/src/interp.c b/src/interp.c
index 15aabdb..80ddfed 100644
--- a/src/interp.c
+++ b/src/interp.c
@@ -102,7 +102,7 @@ void Interp_init(Interp *self) {
     Interp_add_userfunc(self, "sqrt", builtin_sqrt);
     Interp_add_userfunc(self, "cbrt", builtin_cbrt);
     Interp_add_userfunc(self, "log10", builtin_log10);
-    Interp_add_userfunc(self, "eq", builtin_eq);
+    Interp_add_userfunc(self, "eq?", builtin_eq);
     Interp_add_userfunc(self, "ln", builtin_ln);
     Interp_add_userfunc(self, "=", builtin_num_equal);
     Interp_add_userfunc(self, "/=", builtin_num_neq);
@@ -138,7 +138,7 @@ void Interp_init(Interp *self) {
     Interp_add_userfunc(self, "not", builtin_not);
     Interp_add_userfunc(self, "cos", builtin_cos);
     Interp_add_userfunc(self, "princ", builtin_princ);
-    Interp_add_userfunc(self, "equal", builtin_equal);
+    Interp_add_userfunc(self, "equal?", builtin_equal);
     Interp_add_userfunc(self, "atan", builtin_atan);
     Interp_add_userfunc(self, "cons", builtin_cons);
     Interp_add_userfunc(self, "cdr", builtin_cdr);
@@ -147,7 +147,11 @@ void Interp_init(Interp *self) {
     Interp_add_userfunc(self, "floor", builtin_floor);
     Interp_add_userfunc(self, "min", builtin_min);
     Interp_add_userfunc(self, "error", builtin_error);
-
+    Interp_add_userfunc(self, "set-car", builtin_set_car);
+    Interp_add_userfunc(self, "set-cdr", builtin_set_cdr);
+    Interp_add_userfunc(self, "length", builtin_length);
+    Interp_add_userfunc(self, "nth", builtin_nth);
+    Interp_add_userfunc(self, "nthcdr", builtin_nthcdr);
 
     Interp_add_userfunc(self, "_gcstat", builtin_gcstat);
     Interp_add_userfunc(self, "_alwaysgc", builtin_alwaysgc);
@@ -399,7 +403,7 @@ void lisp_to_string_impl(str_builder_t *sb, Int2IntHashTable *visited, Interp *i
     } else if (pe->type == kRealSExp) {
         str_builder_append(sb, "%lg", pe->real);
     } else if (pe->type == kCharSExp) {
-        str_builder_append(sb, "#\%c", pe->character);
+        str_builder_append(sb, "#\\%c", pe->character);
     } else if (pe->type == kBooleanSExp) {
         if (pe->boolean) str_builder_append(sb, "#t");
         else str_builder_append(sb, "#f");
diff --git a/src/prelude.c b/src/prelude.c
index ca9109d..8baca6b 100644
--- a/src/prelude.c
+++ b/src/prelude.c
@@ -1,6 +1,6 @@
 
 #include "prelude.h"
 
-const char *bamboo_lisp_prelude = "(defvar nil \'())\n\n(defvar pi 3.1415926)\n(defvar e 2.718281828)\n\n(defmacro incq (i)\n  `(setq ,i (+ ,i 1)))\n\n(defmacro decq (i)\n  `(setq ,i (- ,i 1)))\n\n(defun zerop (x) (= x 0))\n(defun plusp (x) (> x 0))\n(defun minusp (x) (< x 0))\n\n(defmacro when (pred . body)\n  `(if ,pred\n     (progn ,@body)\n     nil))\n\n(defmacro unless (pred . body)\n  `(if ,pred\n     nil\n     (progn ,@body)))\n";
+const char *bamboo_lisp_prelude = "(defvar nil \'())\n\n(defvar pi 3.1415926)\n(defvar e 2.718281828)\n\n(defmacro incq (i)\n  `(setq ,i (+ ,i 1)))\n\n(defmacro decq (i)\n  `(setq ,i (- ,i 1)))\n\n(defun zero? (x) (= x 0))\n(defun plus? (x) (> x 0))\n(defun minus? (x) (< x 0))\n\n(defmacro when (pred . body)\n  `(if ,pred\n     (progn ,@body)\n     nil))\n\n(defmacro unless (pred . body)\n  `(if ,pred\n     nil\n     (progn ,@body)))\n";
 
 
diff --git a/src/prelude.lisp b/src/prelude.lisp
index 7e9992b..c65380a 100644
--- a/src/prelude.lisp
+++ b/src/prelude.lisp
@@ -9,9 +9,9 @@
 (defmacro decq (i)
   `(setq ,i (- ,i 1)))
 
-(defun zerop (x) (= x 0))
-(defun plusp (x) (> x 0))
-(defun minusp (x) (< x 0))
+(defun zero? (x) (= x 0))
+(defun plus? (x) (> x 0))
+(defun minus? (x) (< x 0))
 
 (defmacro when (pred . body)
   `(if ,pred
diff --git a/src/primitives.c b/src/primitives.c
index 899cbdd..5f70f09 100644
--- a/src/primitives.c
+++ b/src/primitives.c
@@ -64,7 +64,7 @@ SExpRef primitive_assert(Interp *interp, SExpRef args, bool istail) {
     if (LENGTH(args) != 1) {
         return new_error(interp, "assert: expect 1 arg.\n");
     }
-    if (TRUEP(CAR(eargs))) {
+    if (TRUEP(CAR(eargs)) && !CTL_FL(CAR(eargs))) {
         return interp->t;
     } else {
         const char *expstr = lisp_to_string(interp, CAR(args));
diff --git a/tests/arithmetic.lisp b/tests/arithmetic.lisp
index 1942a1d..38b1185 100644
--- a/tests/arithmetic.lisp
+++ b/tests/arithmetic.lisp
@@ -5,18 +5,18 @@
 (assert (= 2 (i/ 11 5)))
 (assert (= 1 (mod 11 5)))
 
-(assert (zerop 0))
-(assert (not (zerop 1)))
-(assert (not (zerop -1)))
+(assert (zero? 0))
+(assert (not (zero? 1)))
+(assert (not (zero? -1)))
 
-(assert (plusp 1))
-(assert (plusp 1.0))
-(assert (not (plusp 0)))
-(assert (not (plusp -1)))
+(assert (plus? 1))
+(assert (plus? 1.0))
+(assert (not (plus? 0)))
+(assert (not (plus? -1)))
 
-(assert (minusp -1))
-(assert (not (minusp 0)))
-(assert (not (minusp 1)))
+(assert (minus? -1))
+(assert (not (minus? 0)))
+(assert (not (minus? 1)))
 
 (assert (< 1 2))
 (assert (< 1.0 2))
diff --git a/tests/control-flow.lisp b/tests/control-flow.lisp
index 321aae0..965213e 100644
--- a/tests/control-flow.lisp
+++ b/tests/control-flow.lisp
@@ -1,6 +1,6 @@
 (assert-error (if (error "") 1 2))
 
-(defmacro inmacro x (progn ,@x))
+(defmacro inmacro x `(progn ,@x))
 
 (let ((i 0))
   (while #t
diff --git a/tests/eq.lisp b/tests/eq.lisp
index 4db31ce..a7758bb 100644
--- a/tests/eq.lisp
+++ b/tests/eq.lisp
@@ -1,27 +1,27 @@
-(assert-error (eq 1 2 3))
-(assert-error (equal 1 2 3))
+(assert-error (eq?1 2 3))
+(assert-error (equal?1 2 3))
 
-(assert (eq 1 1))
-(assert (eq 'a 'a))
-(assert (eq 1.0 1.0))
-(assert (eq #\a #\a))
-(assert (eq #f #f))
-(assert (eq nil nil))
-(assert (eq #t #t))
-(assert (not (eq 1 2)))
-(assert (not (eq "a" "a")))
-(assert (not (eq 'a 'b)))
-(assert (not (eq '(1 2) '(1 2))))
+(assert (eq? 1 1))
+(assert (eq? 'a 'a))
+(assert (eq? 1.0 1.0))
+(assert (eq? #\a #\a))
+(assert (eq? #f #f))
+(assert (eq? nil nil))
+(assert (eq? #t #t))
+(assert (not (eq? 1 2)))
+(assert (not (eq? "a" "a")))
+(assert (not (eq? 'a 'b)))
+(assert (not (eq? '(1 2) '(1 2))))
 
-(assert (equal 1 1))
-(assert (equal 'a 'a))
-(assert (equal "a" "a"))
-(assert (equal 1.0 1.0))
-(assert (equal #\a #\a))
-(assert (equal #f #f))
-(assert (equal '(1 2) '(1 2)))
+(assert (equal? 1 1))
+(assert (equal? 'a 'a))
+(assert (equal? "a" "a"))
+(assert (equal? 1.0 1.0))
+(assert (equal? #\a #\a))
+(assert (equal? #f #f))
+(assert (equal? '(1 2) '(1 2)))
 
-(assert (not (equal 1 2)))
-(assert (not (equal 'a 'b)))
-(assert (not (equal "a" "b")))
-(assert (not (equal '(1 2 3) '(1 2))))
+(assert (not (equal? 1 2)))
+(assert (not (equal? 'a 'b)))
+(assert (not (equal? "a" "b")))
+(assert (not (equal? '(1 2 3) '(1 2))))
diff --git a/tests/list.lisp b/tests/list.lisp
new file mode 100644
index 0000000..168ccf2
--- /dev/null
+++ b/tests/list.lisp
@@ -0,0 +1,23 @@
+(let ((l (list 1 2 3)))
+  (set-cdr l 4)
+  (assert (equal? l (cons 1 4))))
+
+(let ((l (list 1 2 3)))
+  (set-car l 4)
+  (assert (equal? l (list 4 2 3))))
+
+(assert-error (set-car 1))
+(assert-error (set-car))
+(assert-error (set-car (list 1) (list 2) (list 3)))
+(assert-error (set-car ""))
+(assert-error (set-cdr 1))
+(assert-error (set-cdr))
+(assert-error (set-cdr (list 1) (list 2) (list 3)))
+(assert-error (set-cdr ""))
+
+(assert (= 3 (length (list 1 2 3))))
+(assert (= 0 (length nil)))
+
+(assert (= 3 (nth 2 (list 1 2 3))))
+(assert (equal? nil (nthcdr 2 (list 1 2 3))))
+(assert (equal? (list 3) (nthcdr 1 (list 1 2 3))))
diff --git a/tests/string.lisp b/tests/string.lisp
index a55e558..a323c96 100644
--- a/tests/string.lisp
+++ b/tests/string.lisp
@@ -1,5 +1,5 @@
-(assert (equal "abc" (string #\a #\b #\c)))
-(assert (equal "ABC" (string 65 66 67)))
+(assert (equal? "abc" (string #\a #\b #\c)))
+(assert (equal? "ABC" (string 65 66 67)))
 
 (assert (string= "abc" (string #\a #\b #\c)))
 (assert (string= "ABC" (string 65 66 67)))
@@ -25,5 +25,5 @@
 (assert (not (string> s1 s2)))
 
 (assert (string= "abc" (strip-string "\n\tabc \t\n")))
-(assert (equal ("a" "b" "c") (split-string "a,b,c" #\,)))
+(assert (equal? (list "a" "b" "c") (split-string "a,b,c" #\,)))
 
diff --git a/tests/symbol.lisp b/tests/symbol.lisp
index f771272..e19c514 100644
--- a/tests/symbol.lisp
+++ b/tests/symbol.lisp
@@ -1,4 +1,4 @@
-(assert (eq 'a (intern "a")))
-(assert (eq (intern "ab") (intern (concat "a" "b"))))
-(assert (equal "abc" (symbol->string 'abc)))
-(assert (not (eq (gensym) (gensym))))
+(assert (eq? 'a (intern "a")))
+(assert (eq? (intern "ab") (intern (concat "a" "b"))))
+(assert (equal? "abc" (symbol->string 'abc)))
+(assert (not (eq? (gensym) (gensym))))
diff --git a/tests/test.lisp b/tests/test.lisp
index a303ed3..59f91fb 100644
--- a/tests/test.lisp
+++ b/tests/test.lisp
@@ -18,6 +18,7 @@
 (test-module macro)
 (test-module let-binding)
 (test-module string)
+(test-module list)
 
 (princ "\n\nTest with intensive GC:\n\n")
 (_alwaysgc #t)