commit 4f96b63781f5cc69c48cbdb6a0c58d87d29526a0
parent 4869172262fc9dae5e23d4b8b5ce943e9cb56b8c
Author: Andres Navarro <canavarro82@gmail.com>
Date: Wed, 16 Nov 2011 21:15:06 -0300
Added bytevector-copy-partial and bytevector-copy-partial! to the ground environment. Modified substring to always return mutable strings (as bytevector-copy-partial).
Diffstat:
5 files changed, 150 insertions(+), 10 deletions(-)
diff --git a/src/kgbytevectors.c b/src/kgbytevectors.c
@@ -160,13 +160,131 @@ void bytevector_copyS(klisp_State *K, TValue *xparams, TValue ptree,
return;
}
- memcpy(kbytevector_buf(bytevector2),
- kbytevector_buf(bytevector1),
- kbytevector_size(bytevector1));
+ if (!tv_equal(bytevector1, bytevector2) &&
+ !tv_equal(bytevector1, K->empty_bytevector)) {
+ memcpy(kbytevector_buf(bytevector2),
+ kbytevector_buf(bytevector1),
+ kbytevector_size(bytevector1));
+ }
+ kapply_cc(K, KINERT);
+}
+
+/* 13.2.10? bytevector-copy-partial */
+/* TEMP: at least for now this always returns mutable bytevectors */
+void bytevector_copy_partial(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_3tp(K, ptree, "bytevector", ttisbytevector, bytevector,
+ "exact integer", keintegerp, tv_start,
+ "exact integer", keintegerp, tv_end);
+
+ if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 ||
+ ivalue(tv_start) > kbytevector_size(bytevector)) {
+ /* 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) > kbytevector_size(bytevector)) {
+ 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_bytevector;
+ /* the if isn't strictly necessary but it's clearer this way */
+ if (size == 0) {
+ new_bytevector = K->empty_bytevector;
+ } else {
+ new_bytevector = kbytevector_new_bs(K, kbytevector_buf(bytevector)
+ + start, size);
+ }
+ kapply_cc(K, new_bytevector);
+}
+
+/* 13.2.11? bytevector-copy-partial! */
+void bytevector_copy_partialS(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_al3tp(K, ptree, "bytevector", ttisbytevector, bytevector1,
+ "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,
+ "bytevector", ttisbytevector, bytevector2,
+ "exact integer", keintegerp, tv_start2);
+
+ if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 ||
+ ivalue(tv_start) > kbytevector_size(bytevector1)) {
+ /* 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) > kbytevector_size(bytevector1)) {
+ 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 (kbytevector_immutablep(bytevector2)) {
+ klispE_throw_simple(K, "immutable destination bytevector");
+ return;
+ }
+
+ if (!ttisfixint(tv_start2) || ivalue(tv_start2) < 0 ||
+ ivalue(tv_start2) > kbytevector_size(bytevector2)) {
+ 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) > kbytevector_size(bytevector2))) {
+ klispE_throw_simple(K, "not enough space in destination");
+ return;
+ }
+
+ if (size > 0) {
+ memcpy(kbytevector_buf(bytevector2) + start2,
+ kbytevector_buf(bytevector1) + start,
+ size);
+ }
kapply_cc(K, KINERT);
}
-/* 13.2.9? bytevector->immutable-bytevector */
+/* 13.2.12? bytevector->immutable-bytevector */
void bytevector_to_immutable_bytevector(klisp_State *K, TValue *xparams,
TValue ptree, TValue denv)
{
@@ -216,6 +334,13 @@ void kinit_bytevectors_ground_env(klisp_State *K)
/* ??.1.?? bytevector-copy! */
add_applicative(K, ground_env, "bytevector-copy!", bytevector_copyS, 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);
+
/* ??.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
@@ -45,6 +45,14 @@ void bytevector_copy(klisp_State *K, TValue *xparams, TValue ptree,
void bytevector_copyS(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv);
+/* ??.2.?? bytevector-copy-partial */
+void bytevector_copy_partial(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
+
+/* ??.2.?? bytevector-copy-partial! */
+void bytevector_copy_partialS(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
+
/* ??.2.?? bytevector->immutable-bytevector */
void bytevector_to_immutable_bytevector(klisp_State *K, TValue *xparams,
TValue ptree, TValue denv);
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -34,6 +34,10 @@
*/
/* XXX: add parens around macro vars!! */
+/* TODO try to rewrite all of these with just check_0p and check_al1p,
+ (the same with check_0tp and check_al1tp)
+ add a number param and use an array of strings for msgs */
+
#define check_0p(K_, ptree_) \
if (!ttisnil(ptree_)) { \
klispE_throw_simple((K_), \
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -239,7 +239,9 @@ bool kstring_ci_gep(TValue str1, TValue str2)
}
/* 13.2.5? substring */
-/* Note: This will return an mutable string iff the source string is mutable */
+/* TEMP: at least for now this always returns mutable strings (like in Racket and
+ following the Kernel Report where it says that object returned should be mutable
+ unless stated) */
void substring(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
UNUSED(xparams);
@@ -276,10 +278,9 @@ void substring(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* the if isn't strictly necessary but it's clearer this way */
if (size == 0) {
new_str = K->empty_string;
- } else if (kstring_mutablep(str)) {
- new_str = kstring_new_bs(K, kstring_buf(str)+start, size);
} else {
- new_str = kstring_new_bs_imm(K, kstring_buf(str)+start, size);
+ /* always returns mutable strings */
+ new_str = kstring_new_bs(K, kstring_buf(str)+start, size);
}
kapply_cc(K, new_str);
}
diff --git a/src/tests/strings.k b/src/tests/strings.k
@@ -131,9 +131,10 @@
;; immutable strings are eq? iff string=?
+;; substring generates mutable strings
;; Andres Navarro
($check-predicate
- ($let* ((p "abc") (q (substring p 0 3)))
+ ($let* ((p "abc") (q (string->immutable-string (substring p 0 3))))
(eq? p q)))
;; string-copy always generate mutable strings
@@ -142,8 +143,9 @@
($let* ((p (string-copy "abc")) (q (substring p 0 3)))
(eq? p q)))
+;; substring always generate mutable strings
($check-predicate (immutable-string? (substring "abc" 0 0)))
-($check-predicate (immutable-string? (substring "abc" 0 1)))
+($check-not-predicate (immutable-string? (substring "abc" 0 1)))
;; XXX string-append
