commit 6e222811e7e4659a250446be56499d0446015d75
parent 144332b78fa12da6be5bee890787985c0ddc92da
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sun, 27 Nov 2011 19:05:17 -0300
Added bytevector->vector and vector->bytevector to the ground environment. Added some more tests.
Diffstat:
5 files changed, 117 insertions(+), 4 deletions(-)
diff --git a/TODO b/TODO
@@ -34,8 +34,6 @@
** vector-map (r7rs)
** bytevector-map (r7rs)
** string-map (r7rs)
-** vector->bytevector
-** bytevector->vector
** vector-copy! (r7rs)
** vector-copy-partial (r7rs)
** vector-copy-partial! (r7rs)
diff --git a/src/Makefile b/src/Makefile
@@ -246,7 +246,7 @@ kgsystem.o: kgsystem.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kgvectors.o: kgvectors.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
kpair.h kgc.h kvector.h kghelpers.h kenvironment.h ksymbol.h kstring.h \
- kgvectors.h kgnumbers.h
+ kgvectors.h kgnumbers.h kbytevector.h
kinteger.o: kinteger.c kinteger.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h imath.h kgc.h
klisp.o: klisp.c klimits.h klisp.h kobject.h klispconf.h kstate.h \
diff --git a/src/kgvectors.c b/src/kgvectors.c
@@ -19,6 +19,7 @@
#include "kerror.h"
#include "kvector.h"
#include "kpair.h"
+#include "kbytevector.h"
#include "kghelpers.h"
#include "kgvectors.h"
@@ -187,6 +188,71 @@ void vector_to_list(klisp_State *K)
kapply_cc(K, tail);
}
+/* 13.? bytevector->vector, vector->bytevector */
+void bytevector_to_vector(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_1tp(K, ptree, "bytevector", ttisbytevector, str);
+ TValue res;
+
+ if (kbytevector_emptyp(str)) {
+ res = K->empty_vector;
+ } else {
+ uint32_t size = kbytevector_size(str);
+
+ /* MAYBE add vector constructor without fill */
+ /* no need to root this */
+ res = kvector_new_sf(K, size, KINERT);
+ uint8_t *src = kbytevector_buf(str);
+ TValue *dst = kvector_buf(res);
+ while(size--) {
+ uint8_t u8 = *src++; /* not needed but just in case */
+ *dst++ = i2tv(u8);
+ }
+ }
+ kapply_cc(K, res);
+}
+
+/* TEMP Only ASCII for now */
+void vector_to_bytevector(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_1tp(K, ptree, "vector", ttisvector, vec);
+ TValue res;
+
+ if (kvector_emptyp(vec)) {
+ res = K->empty_bytevector;
+ } else {
+ uint32_t size = kvector_size(vec);
+
+ res = kbytevector_new_s(K, size); /* no need to root this */
+ TValue *src = kvector_buf(vec);
+ uint8_t *dst = kbytevector_buf(res);
+ while(size--) {
+ TValue tv = *src++;
+ if (!ttisu8(tv)) {
+ klispE_throw_simple_with_irritants(K, "Non u8 object found",
+ 1, tv);
+ return;
+ }
+ *dst++ = (uint8_t) ivalue(tv);
+ }
+ }
+ kapply_cc(K, res);
+}
+
/* ?.? vector-fill! */
void vector_fillB(klisp_State *K)
{
@@ -263,7 +329,15 @@ void kinit_vectors_ground_env(klisp_State *K)
/* ??.1.?? vector-copy */
add_applicative(K, ground_env, "vector-copy", vector_copy, 0);
- /* TODO: vector->string, string->vector */
+ /* 13.?? vector->bytevector, bytevector->vector */
+ add_applicative(K, ground_env, "vector->bytevector",
+ vector_to_bytevector, 0);
+ add_applicative(K, ground_env, "bytevector->vector",
+ bytevector_to_vector, 0);
+
+ /* vector->string, string->vector */
+ /* in kgstrings.c */
+
/* TODO: vector-copy! vector-copy-partial vector-copy-partial! */
add_applicative(K, ground_env, "vector-fill!", vector_fillB, 0);
diff --git a/src/tests/strings.k b/src/tests/strings.k
@@ -254,6 +254,10 @@
($check-predicate (mutable-string? (vector->string (vector #\a #\b))))
+;; errors
+($check-error (vector->string (vector 41)))
+($check-error (vector->string (vector "a")))
+
;; XXX string->bytevector
($check equal? (string->bytevector "") (bytevector))
@@ -292,6 +296,10 @@
(bytevector->string (bytevector (char->integer #\a)
(char->integer #\b)))))
+;; errors
+($check-error (bytevector->string (bytevector 128))) ;; only ASCII
+
+
;; 13.1.1 string->symbol
;; XXX symbol->string
;;
diff --git a/src/tests/vectors.k b/src/tests/vectors.k
@@ -95,6 +95,39 @@
(mutable-vector?
(vector-copy (vector->immutable-vector (vector 1 2 3)))))
+;; XXX bytevector->vector
+
+($check equal? (bytevector->vector (u8)) (vector))
+($check equal? (bytevector->vector (u8 0 1 2)) (vector 0 1 2))
+
+($check-not-predicate
+ ($let*
+ ((bb (u8 0 1 2))
+ (x (bytevector->vector bb))
+ (y (bytevector->vector bb)))
+ (eq? x y)))
+
+($check-predicate (mutable-vector? (bytevector->vector (u8 0 1 2))))
+
+;; XXX vector->bytevector
+
+($check equal? (vector->bytevector (vector)) (u8))
+($check equal? (vector->bytevector (vector 0 1 2)) (u8 0 1 2))
+
+($check-not-predicate
+ ($let*
+ ((cs (vector 0 1 2))
+ (x (vector->bytevector cs))
+ (y (vector->bytevector cs)))
+ (eq? x y)))
+
+($check-predicate (mutable-bytevector? (vector->bytevector (vector 0 1))))
+
+;; errors
+($check-error (vector->bytevector (vector -1)))
+($check-error (vector->bytevector (vector 256)))
+($check-error (vector->bytevector (vector (integer->char 41))))
+
;; XXX vector-fill!
($check-predicate (inert? (vector-fill! (vector 1 2) 0)))
($check equal? ($let ((v (vector 1 2 3)))
