commit 12e79d94e0fee73b63217e42ec2993c8296b2339
parent 6e222811e7e4659a250446be56499d0446015d75
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sun, 27 Nov 2011 19:43:13 -0300
Added vector-copy!, vector-copy-partial, and vector-copy-partial! to the ground environment. Added all corresponding tests.
Diffstat:
3 files changed, 213 insertions(+), 8 deletions(-)
diff --git a/TODO b/TODO
@@ -16,8 +16,14 @@
functions in kghelpers
** check if all inline functions need to be inline
* fix:
+** fix some inconsistencies between the man page and the interpreter
+ behaviour.
+** fix/test the tty detection in the interpreter
** current-jiffy (r7rs)
** jiffies-per-second (r7rs)
+* documentation
+** update the manual with the current features
+** add a section to the manual with the interpreter usaged
* operatives:
** $when (r7rs)
** $unless (r7rs)
@@ -34,9 +40,6 @@
** vector-map (r7rs)
** bytevector-map (r7rs)
** string-map (r7rs)
-** vector-copy! (r7rs)
-** vector-copy-partial (r7rs)
-** vector-copy-partial! (r7rs)
** read-line (r7rs)
** number->string (r7rs)
** string->number (r7rs)
diff --git a/src/kgvectors.c b/src/kgvectors.c
@@ -253,6 +253,156 @@ void vector_to_bytevector(klisp_State *K)
kapply_cc(K, res);
}
+/* 13.2.9? vector-copy! */
+void vector_copyB(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_2tp(K, ptree, "vector", ttisvector, vector1,
+ "vector", ttisvector, vector2);
+
+ if (kvector_immutablep(vector2)) {
+ klispE_throw_simple(K, "immutable destination vector");
+ return;
+ } else if (kvector_size(vector1) > kvector_size(vector2)) {
+ klispE_throw_simple(K, "destination vector is too small");
+ return;
+ }
+
+ if (!tv_equal(vector1, vector2) &&
+ !tv_equal(vector1, K->empty_vector)) {
+ memcpy(kvector_buf(vector2),
+ kvector_buf(vector1),
+ kvector_size(vector1) * sizeof(TValue));
+ }
+ kapply_cc(K, KINERT);
+}
+
+/* ?.? vector-copy-partial */
+/* TEMP: at least for now this always returns mutable vectors */
+void vector_copy_partial(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_3tp(K, ptree, "vector", ttisvector, vector,
+ "exact integer", keintegerp, tv_start,
+ "exact integer", keintegerp, tv_end);
+
+ if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 ||
+ ivalue(tv_start) > kvector_size(vector)) {
+ /* TODO show index */
+ klispE_throw_simple(K, "start index out of bounds");
+ return;
+ }
+
+ int32_t start = ivalue(tv_start);
+
+ if (!ttisfixint(tv_end) || ivalue(tv_end) < 0 ||
+ ivalue(tv_end) > kvector_size(vector)) {
+ klispE_throw_simple(K, "end index out of bounds");
+ return;
+ }
+
+ int32_t end = ivalue(tv_end);
+
+ if (start > end) {
+ /* TODO show indexes */
+ klispE_throw_simple(K, "end index is smaller than start index");
+ return;
+ }
+
+ int32_t size = end - start;
+ TValue new_vector;
+ /* the if isn't strictly necessary but it's clearer this way */
+ if (size == 0) {
+ new_vector = K->empty_vector;
+ } else {
+ new_vector = kvector_new_bs_g(K, true, kvector_buf(vector)
+ + start, size);
+ }
+ kapply_cc(K, new_vector);
+}
+
+/* ?.? vector-copy-partial! */
+void vector_copy_partialB(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_al3tp(K, ptree, "vector", ttisvector, vector1,
+ "exact integer", keintegerp, tv_start,
+ "exact integer", keintegerp, tv_end,
+ rest);
+
+ /* XXX: this will send wrong error msgs (bad number of arg) */
+ bind_2tp(K, rest,
+ "vector", ttisvector, vector2,
+ "exact integer", keintegerp, tv_start2);
+
+ if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 ||
+ ivalue(tv_start) > kvector_size(vector1)) {
+ /* TODO show index */
+ klispE_throw_simple(K, "start index out of bounds");
+ return;
+ }
+
+ int32_t start = ivalue(tv_start);
+
+ if (!ttisfixint(tv_end) || ivalue(tv_end) < 0 ||
+ ivalue(tv_end) > kvector_size(vector1)) {
+ klispE_throw_simple(K, "end index out of bounds");
+ return;
+ }
+
+ int32_t end = ivalue(tv_end);
+
+ if (start > end) {
+ /* TODO show indexes */
+ klispE_throw_simple(K, "end index is smaller than start index");
+ return;
+ }
+
+ int32_t size = end - start;
+
+ if (kvector_immutablep(vector2)) {
+ klispE_throw_simple(K, "immutable destination vector");
+ return;
+ }
+
+ if (!ttisfixint(tv_start2) || ivalue(tv_start2) < 0 ||
+ ivalue(tv_start2) > kvector_size(vector2)) {
+ klispE_throw_simple(K, "to index out of bounds");
+ return;
+ }
+
+ int32_t start2 = ivalue(tv_start2);
+ int64_t end2 = (int64_t) start2 + size;
+
+ if ((end2 > INT32_MAX) ||
+ (((int32_t) end2) > kvector_size(vector2))) {
+ klispE_throw_simple(K, "not enough space in destination");
+ return;
+ }
+
+ if (size > 0) {
+ memcpy(kvector_buf(vector2) + start2,
+ kvector_buf(vector1) + start,
+ size * sizeof(TValue));
+ }
+ kapply_cc(K, KINERT);
+}
+
/* ?.? vector-fill! */
void vector_fillB(klisp_State *K)
{
@@ -326,23 +476,32 @@ void kinit_vectors_ground_env(klisp_State *K)
add_applicative(K, ground_env, "vector->list", vector_to_list, 0);
add_applicative(K, ground_env, "list->vector", list_to_vector, 0);
- /* ??.1.?? vector-copy */
+ /* ?.? vector-copy */
add_applicative(K, ground_env, "vector-copy", vector_copy, 0);
- /* 13.?? vector->bytevector, bytevector->vector */
+ /* ?.? 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 */
+ /* ?.? vector->string, string->vector */
/* in kgstrings.c */
- /* TODO: vector-copy! vector-copy-partial vector-copy-partial! */
+ /* ?.? vector-copy! */
+ add_applicative(K, ground_env, "vector-copy!", vector_copyB, 0);
+
+ /* ?.? vector-copy-partial */
+ add_applicative(K, ground_env, "vector-copy-partial",
+ vector_copy_partial, 0);
+ /* ?.? vector-copy-partial! */
+ add_applicative(K, ground_env, "vector-copy-partial!",
+ vector_copy_partialB, 0);
+ /* ?.? vector-fill! */
add_applicative(K, ground_env, "vector-fill!", vector_fillB, 0);
- /* ??.1.?? vector->immutable-vector */
+ /* ?.? vector->immutable-vector */
add_applicative(K, ground_env, "vector->immutable-vector",
vector_to_immutable_vector, 0);
}
diff --git a/src/tests/vectors.k b/src/tests/vectors.k
@@ -123,11 +123,54 @@
($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-copy!
+;; additional property: returns #inert
+;; additional property: destination must be mutable
+;;
+($let ((v (make-vector 5 0)))
+ ($check equal? (vector-copy! (vector 1 2 3 4 5) v) #inert)
+ ($check equal? v (vector 1 2 3 4 5))
+ ($check-no-error (vector-copy! (vector->immutable-vector (vector 9 9)) v))
+ ($check equal? v (vector 9 9 3 4 5))
+ ($check-error (vector-copy! (vector 1 2 3 4 5 6) v))
+ ($check-error
+ (vector-copy!
+ (vector 1)
+ (vector->immutable-vector (vector 1)))))
+
+;; (R7RS 3rd draft, ) vector-copy-partial
+
+($check equal? (vector-copy-partial (vector 1 2 3) 0 0) (vector))
+($check equal? (vector-copy-partial (vector 1 2 3) 0 2) (vector 1 2))
+($check equal? (vector-copy-partial (vector 1 2 3) 2 3) (vector 3))
+($check equal? (vector-copy-partial (vector 1 2 3) 3 3) (vector))
+($check-error (vector-copy-partial (vector 1 2 3) 2 4))
+($check-error (vector-copy-partial (vector 1 2 3) -1 0))
+
+;; R7RS 3rd draft, vector-copy-partial!
+;; additional property: returns #inert
+;; additional property: destination must be mutable
+;;
+($let*
+ ((v (make-vector 5 9))
+ (w (vector->immutable-vector v)))
+ ($check equal? (vector-copy-partial! (vector 1 2) 0 2 v 0) #inert)
+ ($check equal? v (vector 1 2 9 9 9))
+ ($check equal? (vector-copy-partial! (vector 5 6) 1 2 v 4) #inert)
+ ($check equal? v (vector 1 2 9 9 6))
+ ($check-error (vector-copy-partial! (vector 1 2) 0 2 v -1))
+ ($check-error (vector-copy-partial! (vector 1 2) 0 2 v 4))
+ ($check-error (vector-copy-partial! (vector 1 2) 2 3 v 0))
+ ($check-error (vector-copy-partial! (vector 1 2) -1 0 v 0))
+ ($check-error (vector-copy-partial! (vector 1 2) 0 2 w 0)))
+
+
;; XXX vector-fill!
($check-predicate (inert? (vector-fill! (vector 1 2) 0)))
($check equal? ($let ((v (vector 1 2 3)))
