klisp

commit 2f1bd9c3bbd1a8bb7eacd718b6572ba73d827e3e
parent 42e8a2aef70f3cec076dfb429951711f98a2ec0f
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Wed, 13 Jul 2011 14:39:51 -0300

Added blob-copy and blob->immutable-blob.

Diffstat:
M
src/kblob.h
 | 
3
+++
M
src/kgblobs.c
 | 
62
+++++++++++++++++++++++++++++++++++++++++++++++++++++---------
M
src/kgblobs.h
 | 
16
++++++++++++----
M
src/kgeqp.h
 | 
2
++

4 files changed, 70 insertions(+), 13 deletions(-)
diff --git a/src/kblob.h b/src/kblob.h
@@ -10,6 +10,9 @@
 #include "kobject.h"
 #include "kstate.h"
 
+/* TODO change blob constructors to string like constructors */
+/* TODO change names to lua-like (e.g. klispB_new, etc) */
+
 /* Constructors for blobs */
 TValue kblob_new_g(klisp_State *K, bool m, uint32_t size);
 TValue kblob_new_imm(klisp_State *K, uint32_t size);
diff --git a/src/kgblobs.c b/src/kgblobs.c
@@ -54,7 +54,7 @@ void make_blob(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
 /*    TValue new_blob = kblob_new_sf(K, ivalue(tv_s), fill); */
     TValue new_blob = kblob_new(K, ivalue(tv_s));
     if (fill != 0) {
-	int s = ivalue(tv_s);
+	int32_t s = ivalue(tv_s);
 	uint8_t *ptr = kblob_buf(new_blob);
 	while(s--)
 	    *ptr++ = fill;
@@ -75,8 +75,8 @@ void blob_length(klisp_State *K, TValue *xparams, TValue ptree,
     kapply_cc(K, res);
 }
 
-/* 13.1.4? blob-ref */
-void blob_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+/* 13.1.4? blob-u8-ref */
+void blob_u8_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
 {
     UNUSED(xparams);
     UNUSED(denv);
@@ -100,8 +100,8 @@ void blob_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     kapply_cc(K, res);
 }
 
-/* 13.1.5? blob-set! */
-void blob_setS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+/* 13.1.5? blob-u8-set! */
+void blob_u8_setS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
 {
     UNUSED(xparams);
     UNUSED(denv);
@@ -132,6 +132,45 @@ void blob_setS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     kapply_cc(K, KINERT);
 }
 
+/* TODO change blob constructors to string like constructors */
+
+/* 13.2.8? blob-copy */
+/* TEMP: at least for now this always returns mutable blobs */
+void blob_copy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+    UNUSED(xparams);
+    UNUSED(denv);
+    bind_1tp(K, ptree, "blob", ttisblob, blob);
+
+    TValue new_blob;
+    /* the if isn't strictly necessary but it's clearer this way */
+    if (tv_equal(blob, K->empty_blob)) {
+	new_blob = blob; 
+    } else {
+	new_blob = kblob_new(K, kblob_size(blob));
+	memcpy(kblob_buf(new_blob), kblob_buf(blob), kblob_size(blob));
+    }
+    kapply_cc(K, new_blob);
+}
+
+/* 13.2.9? blob->immutable-blob */
+void blob_to_immutable_blob(klisp_State *K, TValue *xparams, 
+				TValue ptree, TValue denv)
+{
+    UNUSED(xparams);
+    UNUSED(denv);
+    bind_1tp(K, ptree, "blob", ttisblob, blob);
+
+    TValue res_blob;
+    if (kblob_immutablep(blob)) {/* this includes the empty blob */
+	res_blob = blob;
+    } else {
+	res_blob = kblob_new_imm(K, kblob_size(blob));
+	memcpy(kblob_buf(res_blob), kblob_buf(blob), kblob_size(blob));
+    }
+    kapply_cc(K, res_blob);
+}
+
 /* init ground */
 void kinit_blobs_ground_env(klisp_State *K)
 {
@@ -152,10 +191,15 @@ void kinit_blobs_ground_env(klisp_State *K)
     /* ??.1.3? blob-length */
     add_applicative(K, ground_env, "blob-length", blob_length, 0);
 
-    /* ??.1.4? blob-ref */
-    add_applicative(K, ground_env, "blob-ref", blob_ref, 0);
-    /* ??.1.5? blob-set! */
-    add_applicative(K, ground_env, "blob-set!", blob_setS, 0);
+    /* ??.1.4? blob-u8-ref */
+    add_applicative(K, ground_env, "blob-u8-ref", blob_u8_ref, 0);
+    /* ??.1.5? blob-u8-set! */
+    add_applicative(K, ground_env, "blob-u8-set!", blob_u8_setS, 0);
+
+    /* ??.1.?? blob-copy */
+    add_applicative(K, ground_env, "blob-copy", blob_copy, 0);
+    /* ??.1.?? blob->immutable-blob */
+    add_applicative(K, ground_env, "blob->immutable-blob", blob_to_immutable_blob, 0);
 
 /* TODO put the blob equivalents here */
 #if 0
diff --git a/src/kgblobs.h b/src/kgblobs.h
@@ -28,11 +28,19 @@ void make_blob(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 void blob_length(klisp_State *K, TValue *xparams, TValue ptree, 
 		     TValue denv);
 
-/* ??.1.4? blob-ref */
-void blob_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+/* ??.1.4? blob-u8-ref */
+void blob_u8_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
-/* ??.1.5? blob-set! */
-void blob_setS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+/* ??.1.5? blob-u8-set! */
+void blob_u8_setS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* ??.2.?? blob-copy */
+void blob_copy(klisp_State *K, TValue *xparams, 
+				TValue ptree, TValue denv);
+
+/* ??.2.?? blob->immutable-blob */
+void blob_to_immutable_blob(klisp_State *K, TValue *xparams, 
+				TValue ptree, TValue denv);
 
 /* init ground */
 void kinit_blobs_ground_env(klisp_State *K);
diff --git a/src/kgeqp.h b/src/kgeqp.h
@@ -28,6 +28,8 @@ void eqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 /* Helper (also used in equal?) */
 inline bool eq2p(klisp_State *K, TValue obj1, TValue obj2)
 {
+    /* TODO/FIXME: immutable blobs aren't interned and so will compare
+       as un-eq? even if the contents are the same */
     bool res = (tv_equal(obj1, obj2));
     if (!res && (ttype(obj1) == ttype(obj2))) {
 	switch (ttype(obj1)) {