commit 144332b78fa12da6be5bee890787985c0ddc92da
parent e5fb6339f72557e07b5e5be366014e6391938901
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sun, 27 Nov 2011 18:49:40 -0300
Added string->bytevector and bytevector->string to the ground environment.
Diffstat:
4 files changed, 127 insertions(+), 15 deletions(-)
diff --git a/TODO b/TODO
@@ -36,8 +36,6 @@
** string-map (r7rs)
** vector->bytevector
** bytevector->vector
-** string->bytevector
-** bytevector->string
** vector-copy! (r7rs)
** vector-copy-partial (r7rs)
** vector-copy-partial! (r7rs)
diff --git a/src/Makefile b/src/Makefile
@@ -234,7 +234,7 @@ kground.o: kground.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kgstrings.o: kgstrings.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 ksymbol.h kstring.h kghelpers.h kenvironment.h kvector.h \
- kgstrings.h kgnumbers.h
+ kbytevector.h kgstrings.h kgnumbers.h
kgsymbols.o: kgsymbols.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kcontinuation.h kpair.h kgc.h kstring.h ksymbol.h \
kerror.h kghelpers.h kapplicative.h koperative.h kenvironment.h \
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -22,6 +22,7 @@
#include "kchar.h"
#include "kstring.h"
#include "kvector.h"
+#include "kbytevector.h"
#include "kghelpers.h"
#include "kgstrings.h"
@@ -501,19 +502,89 @@ void vector_to_string(klisp_State *K)
UNUSED(denv);
bind_1tp(K, ptree, "vector", ttisvector, vec);
- uint32_t size = kvector_size(vec);
-
- TValue res = kstring_new_s(K, size); /* no need to root this */
- TValue *src = kvector_buf(vec);
- char *dst = kstring_buf(res);
- while(size--) {
- TValue tv = *src++;
- if (!ttischar(tv)) {
- klispE_throw_simple_with_irritants(K, "Non char object found",
- 1, tv);
- return;
+ TValue res;
+
+ if (kvector_emptyp(vec)) {
+ res = K->empty_string;
+ } else {
+ uint32_t size = kvector_size(vec);
+
+ res = kstring_new_s(K, size); /* no need to root this */
+ TValue *src = kvector_buf(vec);
+ char *dst = kstring_buf(res);
+ while(size--) {
+ TValue tv = *src++;
+ if (!ttischar(tv)) {
+ klispE_throw_simple_with_irritants(K, "Non char object found",
+ 1, tv);
+ return;
+ }
+ *dst++ = chvalue(tv);
+ }
+ }
+ kapply_cc(K, res);
+}
+
+/* 13.? string->bytevector, bytevector->string */
+void string_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, "string", ttisstring, str);
+ TValue res;
+
+ if (kstring_emptyp(str)) {
+ res = K->empty_bytevector;
+ } else {
+ uint32_t size = kstring_size(str);
+
+ /* MAYBE add bytevector constructor without fill */
+ /* no need to root this */
+ res = kbytevector_new_s(K, size);
+ char *src = kstring_buf(str);
+ uint8_t *dst = kbytevector_buf(res);
+
+ while(size--) {
+ *dst++ = (uint8_t)*src++;
+ }
+ }
+ kapply_cc(K, res);
+}
+
+/* TEMP Only ASCII for now */
+void bytevector_to_string(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, bb);
+ TValue res;
+
+ if (kbytevector_emptyp(bb)) {
+ res = K->empty_string;
+ } else {
+ uint32_t size = kbytevector_size(bb);
+ res = kstring_new_s(K, size); /* no need to root this */
+ uint8_t *src = kbytevector_buf(bb);
+ char *dst = kstring_buf(res);
+ while(size--) {
+ uint8_t u8 = *src++;
+ if (u8 >= 128) {
+ klispE_throw_simple_with_irritants(K, "Char out of range",
+ 1, i2tv(u8));
+ return;
+ }
+ *dst++ = (char) u8;
}
- *dst++ = chvalue(tv);
}
kapply_cc(K, res);
}
@@ -654,6 +725,11 @@ void kinit_strings_ground_env(klisp_State *K)
/* 13.?? string->vector, vector->string */
add_applicative(K, ground_env, "string->vector", string_to_vector, 0);
add_applicative(K, ground_env, "vector->string", vector_to_string, 0);
+ /* 13.?? string->bytevector, bytevector->string */
+ add_applicative(K, ground_env, "string->bytevector",
+ string_to_bytevector, 0);
+ add_applicative(K, ground_env, "bytevector->string",
+ bytevector_to_string, 0);
/* 13.2.8? string-copy */
add_applicative(K, ground_env, "string-copy", string_copy, 0);
/* 13.2.9? string->immutable-string */
diff --git a/src/tests/strings.k b/src/tests/strings.k
@@ -254,6 +254,44 @@
($check-predicate (mutable-string? (vector->string (vector #\a #\b))))
+;; XXX string->bytevector
+
+($check equal? (string->bytevector "") (bytevector))
+($check equal? (string->bytevector "aBc")
+ (bytevector (char->integer #\a)
+ (char->integer #\B)
+ (char->integer #\c)))
+
+($check-not-predicate
+ ($let*
+ ( (str "abc")
+ (x (string->bytevector str))
+ (y (string->bytevector str)))
+ (eq? x y)))
+
+($check-predicate (mutable-bytevector? (string->bytevector "abc")))
+
+;; XXX bytevector->string
+
+($check equal? (bytevector->string (bytevector)) "")
+($check equal? (bytevector->string (bytevector (char->integer #\a)
+ (char->integer #\b)
+ (char->integer #\c)))
+ "abc")
+
+($check-not-predicate
+ ($let*
+ ((cs (bytevector (char->integer #\a)
+ (char->integer #\b)
+ (char->integer #\c)))
+ (x (bytevector->string cs))
+ (y (bytevector->string cs)))
+ (eq? x y)))
+
+($check-predicate (mutable-string?
+ (bytevector->string (bytevector (char->integer #\a)
+ (char->integer #\b)))))
+
;; 13.1.1 string->symbol
;; XXX symbol->string
;;
