commit 0771a7ccf83312b313a2adb729b680442960eb26
parent 96a9d8b8f3cce525645d9b3ca13b2ec1f5843566
Author: Andres Navarro <canavarro82@gmail.com>
Date: Fri, 25 Nov 2011 16:40:08 -0300
Added bytevector-u8-fill! and vector-fill! to the ground environment. Added test for these two. TODO add "bytevector" applicative to construct bytevectors from lists.
Diffstat:
8 files changed, 101 insertions(+), 31 deletions(-)
diff --git a/TODO b/TODO
@@ -29,20 +29,19 @@
** $case-vau (r7rs)
** $named-let (r7rs)
** $do (r7rs)
+** $define-record-type (r7rs)
* applicatives:
** vector-map (r7rs)
** bytevector-map (r7rs)
** string-map (r7rs)
** vector->string (r7rs)
** string->vector (r7rs)
-** vector-fill (r7rs)
** vector-copy! (r7rs)
** vector-copy-partial (r7rs)
** vector-copy-partial! (r7rs)
** read-line (r7rs)
** number->string (r7rs)
** string->number (r7rs)
-** define-record-type (r7rs)
** char-digit?
** digit->char
** char->digit
diff --git a/src/kgbytevectors.c b/src/kgbytevectors.c
@@ -23,13 +23,13 @@
#include "kgbytevectors.h"
#include "kgnumbers.h" /* for keintegerp & knegativep */
-/* 13.1.1? bytevector? */
+/* ?.? bytevector? */
/* uses typep */
-/* 13.? immutable-bytevector?, mutable-bytevector? */
+/* ?.? immutable-bytevector?, mutable-bytevector? */
/* use ftypep */
-/* 13.1.2? make-bytevector */
+/* ?.? make-bytevector */
void make_bytevector(klisp_State *K)
{
TValue *xparams = K->next_xparams;
@@ -57,7 +57,7 @@ void make_bytevector(klisp_State *K)
kapply_cc(K, new_bytevector);
}
-/* 13.1.3? bytevector-length */
+/* ?.? bytevector-length */
void bytevector_length(klisp_State *K)
{
TValue *xparams = K->next_xparams;
@@ -72,7 +72,7 @@ void bytevector_length(klisp_State *K)
kapply_cc(K, res);
}
-/* 13.1.4? bytevector-u8-ref */
+/* ?.? bytevector-u8-ref */
void bytevector_u8_ref(klisp_State *K)
{
TValue *xparams = K->next_xparams;
@@ -101,8 +101,8 @@ void bytevector_u8_ref(klisp_State *K)
kapply_cc(K, res);
}
-/* 13.1.5? bytevector-u8-set! */
-void bytevector_u8_setS(klisp_State *K)
+/* ?.? bytevector-u8-set! */
+void bytevector_u8_setB(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -134,7 +134,7 @@ void bytevector_u8_setS(klisp_State *K)
kapply_cc(K, KINERT);
}
-/* 13.2.8? bytevector-copy */
+/* ?.? bytevector-copy */
/* TEMP: at least for now this always returns mutable bytevectors */
void bytevector_copy(klisp_State *K)
{
@@ -158,7 +158,7 @@ void bytevector_copy(klisp_State *K)
}
/* 13.2.9? bytevector-copy! */
-void bytevector_copyS(klisp_State *K)
+void bytevector_copyB(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -186,7 +186,7 @@ void bytevector_copyS(klisp_State *K)
kapply_cc(K, KINERT);
}
-/* 13.2.10? bytevector-copy-partial */
+/* ?.? bytevector-copy-partial */
/* TEMP: at least for now this always returns mutable bytevectors */
void bytevector_copy_partial(klisp_State *K)
{
@@ -235,8 +235,8 @@ void bytevector_copy_partial(klisp_State *K)
kapply_cc(K, new_bytevector);
}
-/* 13.2.11? bytevector-copy-partial! */
-void bytevector_copy_partialS(klisp_State *K)
+/* ?.? bytevector-copy-partial! */
+void bytevector_copy_partialB(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -307,7 +307,32 @@ void bytevector_copy_partialS(klisp_State *K)
kapply_cc(K, KINERT);
}
-/* 13.2.12? bytevector->immutable-bytevector */
+/* ?.? bytevector-u8-fill! */
+void bytevector_u8_fillB(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, "bytevector", ttisbytevector, bytevector,
+ "u8", ttisu8, tv_byte);
+
+ if (kbytevector_immutablep(bytevector)) {
+ klispE_throw_simple(K, "immutable bytevector");
+ return;
+ }
+
+ uint32_t size = kbytevector_size(bytevector);
+ uint8_t *buf = kbytevector_buf(bytevector);
+ while(size-- > 0) {
+ *buf++ = (uint8_t) ivalue(tv_byte);
+ }
+ kapply_cc(K, KINERT);
+}
+
+/* ?.? bytevector->immutable-bytevector */
void bytevector_to_immutable_bytevector(klisp_State *K)
{
TValue *xparams = K->next_xparams;
@@ -357,21 +382,25 @@ void kinit_bytevectors_ground_env(klisp_State *K)
/* ??.1.4? bytevector-u8-ref */
add_applicative(K, ground_env, "bytevector-u8-ref", bytevector_u8_ref, 0);
/* ??.1.5? bytevector-u8-set! */
- add_applicative(K, ground_env, "bytevector-u8-set!", bytevector_u8_setS,
+ add_applicative(K, ground_env, "bytevector-u8-set!", bytevector_u8_setB,
0);
/* ??.1.?? bytevector-copy */
add_applicative(K, ground_env, "bytevector-copy", bytevector_copy, 0);
/* ??.1.?? bytevector-copy! */
- add_applicative(K, ground_env, "bytevector-copy!", bytevector_copyS, 0);
+ add_applicative(K, ground_env, "bytevector-copy!", bytevector_copyB, 0);
/* ??.1.?? bytevector-copy-partial */
add_applicative(K, ground_env, "bytevector-copy-partial",
bytevector_copy_partial, 0);
/* ??.1.?? bytevector-copy-partial! */
add_applicative(K, ground_env, "bytevector-copy-partial!",
- bytevector_copy_partialS, 0);
+ bytevector_copy_partialB, 0);
+ /* ??.?? bytevector-u8-fill! */
+ add_applicative(K, ground_env, "bytevector-u8-fill!",
+ bytevector_u8_fillB, 0);
+
/* ??.1.?? bytevector->immutable-bytevector */
add_applicative(K, ground_env, "bytevector->immutable-bytevector",
bytevector_to_immutable_bytevector, 0);
diff --git a/src/kgbytevectors.h b/src/kgbytevectors.h
@@ -31,19 +31,19 @@ void bytevector_length(klisp_State *K);
void bytevector_u8_ref(klisp_State *K);
/* ??.1.5? bytevector-u8-set! */
-void bytevector_u8_setS(klisp_State *K);
+void bytevector_u8_setB(klisp_State *K);
/* ??.2.?? bytevector-copy */
void bytevector_copy(klisp_State *K);
/* ??.2.?? bytevector-copy! */
-void bytevector_copyS(klisp_State *K);
+void bytevector_copyB(klisp_State *K);
/* ??.2.?? bytevector-copy-partial */
void bytevector_copy_partial(klisp_State *K);
/* ??.2.?? bytevector-copy-partial! */
-void bytevector_copy_partialS(klisp_State *K);
+void bytevector_copy_partialB(klisp_State *K);
/* ??.2.?? bytevector->immutable-bytevector */
void bytevector_to_immutable_bytevector(klisp_State *K);
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -105,7 +105,7 @@ void string_ref(klisp_State *K)
}
/* 13.1.5? string-set! */
-void string_setS(klisp_State *K)
+void string_setB(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -208,11 +208,11 @@ void kstring_title_case(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_1tp(K, ptree, "string", ttisstring, str);
- int32_t size = kstring_size(str);
+ uint32_t size = kstring_size(str);
TValue res = kstring_new_bs(K, kstring_buf(str), size);
char *buf = kstring_buf(res);
bool first = true;
- for(int32_t i = 0; i < size; ++i, buf++) {
+ while(size-- > 0) {
char ch = *buf;
if (ch == ' ')
first = true;
@@ -223,6 +223,7 @@ void kstring_title_case(klisp_State *K)
*buf = toupper(ch);
first = false;
}
+ ++buf;
}
kapply_cc(K, res);
}
@@ -500,7 +501,7 @@ void string_to_immutable_string(klisp_State *K)
}
/* 13.2.10? string-fill! */
-void string_fillS(klisp_State *K)
+void string_fillB(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -548,7 +549,7 @@ void kinit_strings_ground_env(klisp_State *K)
/* 13.1.4? string-ref */
add_applicative(K, ground_env, "string-ref", string_ref, 0);
/* 13.1.5? string-set! */
- add_applicative(K, ground_env, "string-set!", string_setS, 0);
+ add_applicative(K, ground_env, "string-set!", string_setB, 0);
/* 13.2.1? string */
add_applicative(K, ground_env, "string", string, 0);
/* 13.?? string-upcase, string-downcase, string-titlecase,
@@ -597,5 +598,5 @@ void kinit_strings_ground_env(klisp_State *K)
string_to_immutable_string, 0);
/* 13.2.10? string-fill! */
- add_applicative(K, ground_env, "string-fill!", string_fillS, 0);
+ add_applicative(K, ground_env, "string-fill!", string_fillB, 0);
}
diff --git a/src/kgstrings.h b/src/kgstrings.h
@@ -81,7 +81,7 @@ void string_copy(klisp_State *K);
void string_to_immutable_string(klisp_State *K);
/* 13.2.10? string-fill! */
-void string_fillS(klisp_State *K);
+void string_fillB(klisp_State *K);
/* Helpers */
bool kstringp(TValue obj);
diff --git a/src/kgvectors.c b/src/kgvectors.c
@@ -89,7 +89,7 @@ void vector_ref(klisp_State *K)
}
/* (R7RS 3rd draft 6.3.6) vector-set! */
-void vector_setS(klisp_State *K)
+void vector_setB(klisp_State *K)
{
klisp_assert(ttisenvironment(K->next_env));
@@ -187,6 +187,31 @@ void vector_to_list(klisp_State *K)
kapply_cc(K, tail);
}
+/* ?.? vector-fill! */
+void vector_fillB(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, vector,
+ "any", anytype, fill);
+
+ if (kvector_immutablep(vector)) {
+ klispE_throw_simple(K, "immutable vector");
+ return;
+ }
+
+ uint32_t size = kvector_length(vector);
+ TValue *buf = kvector_array(vector);
+ while(size-- > 0) {
+ *buf++ = fill;
+ }
+ kapply_cc(K, KINERT);
+}
+
/* ??.?.? vector->immutable-vector */
void vector_to_immutable_vector(klisp_State *K)
{
@@ -228,7 +253,7 @@ void kinit_vectors_ground_env(klisp_State *K)
/* (R7RS 3rd draft 6.3.6) vector-ref vector-set! */
add_applicative(K, ground_env, "vector-ref", vector_ref, 0);
- add_applicative(K, ground_env, "vector-set!", vector_setS, 0);
+ add_applicative(K, ground_env, "vector-set!", vector_setB, 0);
/* (R7RS 3rd draft 6.3.6) vector, vector->list, list->vector */
add_applicative(K, ground_env, "vector", vector, 0);
@@ -238,9 +263,11 @@ 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, vector-fill */
+ /* TODO: vector->string, string->vector */
/* TODO: vector-copy! vector-copy-partial vector-copy-partial! */
+ add_applicative(K, ground_env, "vector-fill!", vector_fillB, 0);
+
/* ??.1.?? vector->immutable-vector */
add_applicative(K, ground_env, "vector->immutable-vector",
vector_to_immutable_vector, 0);
diff --git a/src/tests/bytevectors.k b/src/tests/bytevectors.k
@@ -162,6 +162,13 @@
($check-error (bytevector-copy-partial! (u8 1 2) -1 0 v 0))
($check-error (bytevector-copy-partial! (u8 1 2) 0 2 w 0)))
+;; XXX bytevector-u8-fill!
+($check-predicate (inert? (bytevector-u8-fill! (bytevector 1 2) 0)))
+($check equal? ($let ((b (bytevector 1 2 3)))
+ (bytevector-u8-fill! b 0)
+ b)
+ (bytevector 0 0 0))
+
;; XXX bytevector->immutable-bytevector
($check-predicate
diff --git a/src/tests/vectors.k b/src/tests/vectors.k
@@ -95,6 +95,13 @@
(mutable-vector?
(vector-copy (vector->immutable-vector (vector 1 2 3)))))
+;; XXX vector-fill!
+($check-predicate (inert? (vector-fill! (vector 1 2) 0)))
+($check equal? ($let ((v (vector 1 2 3)))
+ (vector-fill! v "str")
+ v)
+ (vector "str" "str" "str"))
+
;; XXX vector->immutable-vector
($check-predicate (applicative? vector->immutable-vector))
