add vector

4 files changed, 163 insertions, 6 deletions

diff --git a/src/interp.c b/src/interp.c
index d092e1f..b1d43fa 100644
--- a/src/interp.c
+++ b/src/interp.c
@@ -12,6 +12,8 @@
 #include "parser.h"
 #include "prelude.h"
 
+#include "vector.h"
+
 #define BUFSIZE 1024
 
 bool SExpRef_eq(SExpRef a, SExpRef b) {
@@ -240,6 +242,9 @@ void Interp_init(Interp *self) {
     Interp_add_userfunc(self, "_gcstat", builtin_gcstat);
     Interp_add_userfunc(self, "_alwaysgc", builtin_alwaysgc);
 
+    // extentions
+    bamboo_lisp_init_vector(self);
+
     SExpRef ret = Interp_eval_string(self, bamboo_lisp_prelude);
     Interp *interp = self;
     if (VALTYPE(ret) == kErrSignal) {
@@ -326,6 +331,11 @@ void Interp_free(Interp *self) {
         if (obj->type == kStringSExp) {
             free((void*)obj->str);
         }
+        if (obj->type == kUserDataSExp) {
+            if (obj->userdata_meta && obj->userdata_meta->free) {
+                (*obj->userdata_meta->free)(obj->userdata);
+            }
+        }
     }
     for (String2IntHashTableIter iter = String2IntHashTable_begin(&self->symbols);
             iter != NULL;
@@ -416,6 +426,10 @@ void Interp_gc(Interp *interp, SExpRef tmproot) {
             if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child);
             child = REF(obj->tailcall.fn);
             if (child && !child->marked) SExpPtrVector_push_back(&gcstack, child);
+        } else if (obj->type == kUserDataSExp) {
+            if (obj->userdata_meta && obj->userdata_meta->gcmark) {
+                (*obj->userdata_meta->gcmark)(interp, &gcstack, obj->userdata);
+            }
         }
     }
     SExpPtrVector_free(&gcstack);
@@ -429,6 +443,11 @@ void Interp_gc(Interp *interp, SExpRef tmproot) {
         if (obj->type == kSymbolSExp) continue;
         if (obj->type == kEmptySExp) continue;
         if (obj->type == kStringSExp) free((void*)obj->str);
+        if (obj->type == kUserDataSExp) {
+            if (obj->userdata_meta && obj->userdata_meta->free) {
+                (*obj->userdata_meta->free)(obj->userdata);
+            }
+        }
         obj->type = kEmptySExp;
         IntVector_push_back(&interp->empty_space, i);
     }
@@ -528,6 +547,8 @@ void lisp_to_string_impl(str_builder_t *sb, Int2IntHashTable *visited, Interp *i
         str_builder_append(sb, "<CONTINUE>");
     } else if (pe->type == kTailcallSExp) {
         str_builder_append(sb, "<TAILCALL>");
+    } else if (pe->type == kUserDataSExp) {
+        str_builder_append(sb, "<USERDATA>");
     } else if (pe->type == kPairSExp) {
         if (Int2IntHashTable_find(visited, val.idx) != NULL) {
             str_builder_append(sb, "<%d>", val.idx);
diff --git a/src/sexp.h b/src/sexp.h
index 4aec76d..d8d2dc9 100644
--- a/src/sexp.h
+++ b/src/sexp.h
@@ -78,10 +78,13 @@ typedef enum {
 
 VECTOR_DEF(SExpRef);
 
+typedef SExp *SExpPtr;
+VECTOR_DEF(SExpPtr);
+
 typedef struct {
-    SExpRef type;
+    const char *type;
     void (*free)(void *self);
-    void (*gcmark)(SExpRefVector *gcstack, void *self);
+    void (*gcmark)(Interp *interp, SExpPtrVector *gcstack, void *self);
 } LispUserdataMeta;
 
 struct sexp {
@@ -94,7 +97,7 @@ struct sexp {
         char character;
         const char *str;
         struct {
-            const void *userdata;
+            void *userdata;
             LispUserdataMeta *userdata_meta;
         };
         SExpPair pair;
@@ -109,15 +112,12 @@ struct sexp {
     };
 };
 
-typedef SExp *SExpPtr;
-
 
 void SExp_show(SExp self, FILE* fp);
 void SExpRef_show(SExpRef self, FILE* fp);
 void SExpPtr_show(SExpPtr self, FILE* fp);
 
 VECTOR_DEF(SExp);
-VECTOR_DEF(SExpPtr);
 
 #endif
 
diff --git a/src/vector.c b/src/vector.c
new file mode 100644
index 0000000..453800b
--- /dev/null
+++ b/src/vector.c
@@ -0,0 +1,128 @@
+#include "vector.h"
+#include "interp.h"
+#include "sexp.h"
+
+LispUserdataMeta bamboo_lisp_array_meta;
+
+static bool is_vector_impl(Interp *interp, SExpRef vec) {
+    if (VALTYPE(vec) == kUserDataSExp && strcmp("vector", REF(vec)->userdata_meta->type) == 0) {
+        return true;
+    }
+    return false;
+}
+
+static SExpRef is_vector(Interp* interp, SExpRef args) {
+    if (LENGTH(args) != 1) return new_error(interp, "vector?: wrongs args num.\n");
+    return new_boolean(interp, is_vector_impl(interp, CAR(args)));
+}
+
+static SExpRef make_vector(Interp* interp, SExpRef args) {
+    SExpRef ret = new_sexp(interp);
+    REF(ret)->type = kUserDataSExp;
+    REF(ret)->userdata_meta = &bamboo_lisp_array_meta;
+    SExpRefVector *data = malloc(sizeof(SExpRefVector));
+    SExpRefVector_init(data);
+    REF(ret)->userdata = data;
+    return ret;
+}
+
+static SExpRef vector_ref(Interp* interp, SExpRef args) {
+    if (LENGTH(args) != 2) return new_error(interp, "vector-ref: wrong args num.\n");
+    if (!is_vector_impl(interp, CAR(args))
+            || REF(CADR(args))->type != kIntegerSExp) {
+        return new_error(interp, "vector-ref: wrong type.\n");
+    }
+    int n = REF(CADR(args))->integer;
+    SExpRefVector *vec = REF(CAR(args))->userdata;
+    if (n >= SExpRefVector_len(vec)) return new_error(interp, "vector-ref: out of bound.\n");
+    SExpRef ret = new_sexp(interp);
+    return *SExpRefVector_ref(vec, n);
+}
+
+static SExpRef vector_append(Interp* interp, SExpRef args) {
+    if (LENGTH(args) != 2) return new_error(interp, "vector-append: wrong args num.\n");
+    if (!is_vector_impl(interp, CAR(args))) return new_error(interp, "vector-append: first arg not a vector.\n");
+
+    SExpRefVector *vec = REF(CAR(args))->userdata;
+    SExpRef elem = CADR(args);
+    SExpRefVector_push_back(vec, elem);
+    return NIL;
+}
+
+static SExpRef vector_insert(Interp* interp, SExpRef args) {
+    if (LENGTH(args) != 3) return new_error(interp, "vector-insert: wrong args num.\n");
+    if (!is_vector_impl(interp, CAR(args)) || REF(CADR(args))->type != kIntegerSExp)
+        return new_error(interp, "vector-insert: wrong types.\n");
+
+    int pos = REF(CADR(args))->integer;
+    SExpRefVector *vec = REF(CAR(args))->userdata;
+    SExpRef elem = CADDR(args);
+    SExpRefVector_insert_before(vec, pos, elem);
+    return NIL;
+}
+
+static SExpRef vector_delete(Interp* interp, SExpRef args) {
+    if (LENGTH(args) != 2) return new_error(interp, "vector-remove: wrong args num.\n");
+    if (!is_vector_impl(interp, CAR(args)) || REF(CADR(args))->type != kIntegerSExp)
+        return new_error(interp, "vector-remove: wrong types.\n");
+
+    int pos = REF(CADR(args))->integer;
+    SExpRefVector *vec = REF(CAR(args))->userdata;
+    if (pos >= SExpRefVector_len(vec)) return new_error(interp, "vector-remove: out of bound.\n");
+    SExpRefVector_remove(vec, pos);
+    return NIL;
+}
+
+static SExpRef vector_length(Interp* interp, SExpRef args) {
+   if (LENGTH(args) != 1) return new_error(interp, "vector-length: wrong args num.\n");
+    if (!is_vector_impl(interp, CAR(args))) return new_error(interp, "vector-length: not a vector.\n");
+
+    SExpRefVector *vec = REF(CAR(args))->userdata;
+    return new_integer(interp, SExpRefVector_len(vec));
+}
+
+static SExpRef vector_set(Interp* interp, SExpRef args) {
+    if (LENGTH(args) != 3) return new_error(interp, "vector-set: wrong args num.\n");
+    if (!is_vector_impl(interp, CAR(args)) || REF(CADR(args))->type != kIntegerSExp)
+        return new_error(interp, "vector-set: wrong types.\n");
+
+    int pos = REF(CADR(args))->integer;
+    SExpRefVector *vec = REF(CAR(args))->userdata;
+    if (pos >= SExpRefVector_len(vec)) return new_error(interp, "vector-set: out of bound.\n");
+
+    *SExpRefVector_ref(vec, pos) = CADDR(args);
+    return NIL;
+}
+
+static void vector_free(void *vself) {
+    SExpRefVector *self = vself;
+    SExpRefVector_free(self);
+    free(self);
+}
+
+static void vector_gcmark(Interp *interp, SExpPtrVector *gcstack, void *vself) {
+    SExpRefVector *vec = (SExpRefVector *)vself;
+    int vecsize = SExpRefVector_len(vec);
+    for (int i = 0; i < vecsize; ++i) {
+        SExpPtr child = REF(*SExpRefVector_ref(vec, i));
+        if (child && !child->marked) {
+            SExpPtrVector_push_back(gcstack, child);
+        }
+    }
+}
+
+
+void bamboo_lisp_init_vector(Interp *interp) {
+    bamboo_lisp_array_meta.type = "vector";
+    bamboo_lisp_array_meta.free = &vector_free;
+    bamboo_lisp_array_meta.gcmark = &vector_gcmark;
+
+    Interp_add_userfunc(interp, "vector?", &is_vector);
+    Interp_add_userfunc(interp, "make-vector", &make_vector);
+    Interp_add_userfunc(interp, "vector-ref", &vector_ref);
+    Interp_add_userfunc(interp, "vector-append", &vector_append);
+    Interp_add_userfunc(interp, "vector-insert", &vector_insert);
+    Interp_add_userfunc(interp, "vector-remove", &vector_delete);
+    Interp_add_userfunc(interp, "vector-length", &vector_length);
+    Interp_add_userfunc(interp, "vector-set", &vector_set);
+}
diff --git a/src/vector.h b/src/vector.h
new file mode 100644
index 0000000..34113d1
--- /dev/null
+++ b/src/vector.h
@@ -0,0 +1,8 @@
+#ifndef BAMBOO_LISP_VECTOR_H_
+#define BAMBOO_LISP_VECTOR_H_
+
+#include "interp.h"
+
+void bamboo_lisp_init_vector(Interp *interp);
+
+#endif