commit e5fb6339f72557e07b5e5be366014e6391938901
parent 955613e496747b76e2fa582d03cc7d724dd851b3
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sun, 27 Nov 2011 18:38:02 -0300
Added string->vector and vector->string to the ground environment. Refactored kvector.h.
Diffstat:
8 files changed, 115 insertions(+), 22 deletions(-)
diff --git a/TODO b/TODO
@@ -36,8 +36,8 @@
** string-map (r7rs)
** vector->bytevector
** bytevector->vector
-** vector->string (r7rs)
-** string->vector (r7rs)
+** string->bytevector
+** bytevector->string
** vector-copy! (r7rs)
** vector-copy-partial (r7rs)
** vector-copy-partial! (r7rs)
diff --git a/src/Makefile b/src/Makefile
@@ -233,7 +233,7 @@ kground.o: kground.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kgerrors.h kgffi.h ktable.h keval.h krepl.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 \
+ kpair.h kgc.h ksymbol.h kstring.h kghelpers.h kenvironment.h kvector.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 \
diff --git a/src/kgequalp.c b/src/kgequalp.c
@@ -204,14 +204,14 @@ bool equal2p(klisp_State *K, TValue obj1, TValue obj2)
}
break;
case K_TVECTOR:
- if (kvector_length(obj1) == kvector_length(obj2)) {
+ if (kvector_size(obj1) == kvector_size(obj2)) {
/* if they were already compaired, consider equal for
now otherwise they are equal if all their elements
are equal pairwise */
if (!equal_find2_mergep(K, obj1, obj2)) {
- uint32_t i = kvector_length(obj1);
- TValue *array1 = kvector_array(obj1);
- TValue *array2 = kvector_array(obj1);
+ uint32_t i = kvector_size(obj1);
+ TValue *array1 = kvector_buf(obj1);
+ TValue *array2 = kvector_buf(obj1);
while(i-- > 0) {
ks_spush(K, array1[i]);
ks_spush(K, array2[i]);
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -21,6 +21,7 @@
#include "ksymbol.h"
#include "kchar.h"
#include "kstring.h"
+#include "kvector.h"
#include "kghelpers.h"
#include "kgstrings.h"
@@ -458,6 +459,65 @@ void list_to_string(klisp_State *K)
kapply_cc(K, new_str);
}
+/* 13.? string->vector, vector->string */
+void string_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, "string", ttisstring, str);
+ TValue res;
+
+ if (kstring_emptyp(str)) {
+ res = K->empty_vector;
+ } else {
+ uint32_t size = kstring_size(str);
+
+ /* MAYBE add vector constructor without fill */
+ /* no need to root this */
+ res = kvector_new_sf(K, size, KINERT);
+ char *src = kstring_buf(str);
+ TValue *dst = kvector_buf(res);
+ while(size--) {
+ char ch = *src++; /* not needed but just in case */
+ *dst++ = ch2tv(ch);
+ }
+ }
+ kapply_cc(K, res);
+}
+
+/* TEMP Only ASCII for now */
+void vector_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, "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;
+ }
+ *dst++ = chvalue(tv);
+ }
+ kapply_cc(K, res);
+}
+
/* 13.2.8? string-copy */
/* TEMP: at least for now this always returns mutable strings */
void string_copy(klisp_State *K)
@@ -591,6 +651,9 @@ void kinit_strings_ground_env(klisp_State *K)
/* 13.2.7? string->list, list->string */
add_applicative(K, ground_env, "string->list", string_to_list, 0);
add_applicative(K, ground_env, "list->string", list_to_string, 0);
+ /* 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.2.8? string-copy */
add_applicative(K, ground_env, "string-copy", string_copy, 0);
/* 13.2.9? string->immutable-string */
diff --git a/src/kgvectors.c b/src/kgvectors.c
@@ -61,7 +61,7 @@ void vector_length(klisp_State *K)
bind_1tp(K, ptree, "vector", ttisvector, vector);
- TValue res = i2tv(kvector_length(vector));
+ TValue res = i2tv(kvector_size(vector));
kapply_cc(K, res);
}
@@ -80,12 +80,12 @@ void vector_ref(klisp_State *K)
return;
}
int32_t i = ivalue(tv_i);
- if (i < 0 || i >= kvector_length(vector)) {
+ if (i < 0 || i >= kvector_size(vector)) {
klispE_throw_simple_with_irritants(K, "vector index out of bounds",
1, tv_i);
return;
}
- kapply_cc(K, kvector_array(vector)[i]);
+ kapply_cc(K, kvector_buf(vector)[i]);
}
/* (R7RS 3rd draft 6.3.6) vector-set! */
@@ -104,7 +104,7 @@ void vector_setB(klisp_State *K)
}
int32_t i = ivalue(tv_i);
- if (i < 0 || i >= kvector_length(vector)) {
+ if (i < 0 || i >= kvector_size(vector)) {
klispE_throw_simple_with_irritants(K, "vector index out of bounds",
1, tv_i);
return;
@@ -113,7 +113,7 @@ void vector_setB(klisp_State *K)
return;
}
- kvector_array(vector)[i] = tv_new_value;
+ kvector_buf(vector)[i] = tv_new_value;
kapply_cc(K, KINERT);
}
@@ -128,7 +128,7 @@ void vector_copy(klisp_State *K)
TValue new_vector = kvector_emptyp(v)?
v
- : kvector_new_bs_g(K, true, kvector_array(v), kvector_length(v));
+ : kvector_new_bs_g(K, true, kvector_buf(v), kvector_size(v));
kapply_cc(K, new_vector);
}
@@ -142,7 +142,7 @@ static TValue list_to_vector_h(klisp_State *K, const char *name, TValue ls)
} else {
TValue res = kvector_new_sf(K, pairs, KINERT);
for (int i = 0; i < pairs; i++) {
- kvector_array(res)[i] = kcar(ls);
+ kvector_buf(res)[i] = kcar(ls);
ls = kcdr(ls);
}
return res;
@@ -180,9 +180,9 @@ void vector_to_list(klisp_State *K)
TValue tail = KNIL;
krooted_vars_push(K, &tail);
- size_t i = kvector_length(v);
+ size_t i = kvector_size(v);
while (i-- > 0)
- tail = kcons(K, kvector_array(v)[i], tail);
+ tail = kcons(K, kvector_buf(v)[i], tail);
krooted_vars_pop(K);
kapply_cc(K, tail);
}
@@ -204,8 +204,8 @@ void vector_fillB(klisp_State *K)
return;
}
- uint32_t size = kvector_length(vector);
- TValue *buf = kvector_array(vector);
+ uint32_t size = kvector_size(vector);
+ TValue *buf = kvector_buf(vector);
while(size-- > 0) {
*buf++ = fill;
}
@@ -222,7 +222,7 @@ void vector_to_immutable_vector(klisp_State *K)
TValue res = kvector_immutablep(v)?
v
- : kvector_new_bs_g(K, false, kvector_array(v), kvector_length(v));
+ : kvector_new_bs_g(K, false, kvector_buf(v), kvector_size(v));
kapply_cc(K, res);
}
diff --git a/src/kvector.c b/src/kvector.c
@@ -14,6 +14,8 @@
/* helper function allocating vectors */
+/* XXX I'm not too convinced this is the best way to handle the empty
+ vector... Try to find a better way */
static Vector *kvector_alloc(klisp_State *K, bool m, uint32_t length)
{
Vector *new_vector;
diff --git a/src/kvector.h b/src/kvector.h
@@ -24,10 +24,10 @@ bool kmutable_vectorp(TValue obj);
/* some macros to access the parts of vectors */
-#define kvector_array(tv_) (tv2vector(tv_)->array)
-#define kvector_length(tv_) (tv2vector(tv_)->sizearray)
+#define kvector_buf(tv_) (tv2vector(tv_)->array)
+#define kvector_size(tv_) (tv2vector(tv_)->sizearray)
-#define kvector_emptyp(tv_) (kvector_length(tv_) == 0)
+#define kvector_emptyp(tv_) (kvector_size(tv_) == 0)
#define kvector_mutablep(tv_) (kis_mutable(tv_))
#define kvector_immutablep(tv_) (kis_immutable(tv_))
diff --git a/src/tests/strings.k b/src/tests/strings.k
@@ -226,6 +226,34 @@
($check-error (list->string ($quote (#\a #0=(#\a . #0#)))))
+;; XXX string->vector
+
+($check equal? (string->vector "") (vector))
+($check equal? (string->vector "abc") (vector #\a #\B #\c))
+
+($check-not-predicate
+ ($let*
+ ( (str "abc")
+ (x (string->vector str))
+ (y (string->vector str)))
+ (eq? x y)))
+
+($check-predicate (mutable-vector? (string->vector "abc")))
+
+;; XXX vector->string
+
+($check equal? (vector->string (vector)) "")
+($check equal? (vector->string (vector #\a #\b #\c)) "abc")
+
+($check-not-predicate
+ ($let*
+ ( (cs (vector #\a #\b #\c))
+ (x (vector->string cs))
+ (y (vector->string cs)))
+ (eq? x y)))
+
+($check-predicate (mutable-string? (vector->string (vector #\a #\b))))
+
;; 13.1.1 string->symbol
;; XXX symbol->string
;;
