commit 3063304c62cabf23655a1d25ff35ccd4956cf365
parent 0771a7ccf83312b313a2adb729b680442960eb26
Author: Andres Navarro <canavarro82@gmail.com>
Date: Fri, 25 Nov 2011 17:07:38 -0300
Added bytevector, list->bytevector, and bytevector->list to the ground environment. Refactored kgbytevectors.h and kgstrings.h.
Diffstat:
6 files changed, 116 insertions(+), 140 deletions(-)
diff --git a/TODO b/TODO
@@ -34,6 +34,8 @@
** vector-map (r7rs)
** bytevector-map (r7rs)
** string-map (r7rs)
+** vector->bytevector
+** bytevector->vector
** vector->string (r7rs)
** string->vector (r7rs)
** vector-copy! (r7rs)
diff --git a/src/kgbytevectors.c b/src/kgbytevectors.c
@@ -29,6 +29,87 @@
/* ?.? immutable-bytevector?, mutable-bytevector? */
/* use ftypep */
+/* Helper for bytevector and list->bytevector */
+/* GC: Assumes ls is rooted */
+TValue list_to_bytevector_h(klisp_State *K, char *name, TValue ls)
+{
+ int32_t dummy;
+ /* don't allow cycles */
+ int32_t pairs = check_typed_list(K, name, "u8", ku8p, false,
+ ls, &dummy);
+
+ TValue new_bb;
+ /* the if isn't strictly necessary but it's clearer this way */
+ if (pairs == 0) {
+ return K->empty_bytevector;
+ } else {
+ new_bb = kbytevector_new_s(K, pairs);
+ uint8_t *buf = kbytevector_buf(new_bb);
+ TValue tail = ls;
+ while(pairs--) {
+ *buf++ = ivalue(kcar(tail));
+ tail = kcdr(tail);
+ }
+ return new_bb;
+ }
+}
+
+/* ?.? bytevector */
+void 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);
+
+ TValue new_bb = list_to_bytevector_h(K, "bytevector", ptree);
+ kapply_cc(K, new_bb);
+}
+
+/* ?.? bytevector->list */
+void bytevector_to_list(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);
+ int32_t pairs = kbytevector_size(bb);
+ uint8_t *buf = kbytevector_buf(bb);
+
+ TValue tail = kget_dummy1(K);
+
+ while(pairs--) {
+ TValue new_pair = kcons(K, i2tv(*buf), KNIL);
+ buf++;
+ kset_cdr(tail, new_pair);
+ tail = new_pair;
+ }
+ kapply_cc(K, kcutoff_dummy1(K));
+}
+
+/* ?.? list->bytevector */
+void list_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);
+
+ /* check later in list_to_bytevector_h */
+ bind_1p(K, ptree, ls);
+
+ TValue new_bb = list_to_bytevector_h(K, "list->bytevector", ls);
+ kapply_cc(K, new_bb);
+}
+
/* ?.? make-bytevector */
void make_bytevector(klisp_State *K)
{
@@ -374,6 +455,12 @@ void kinit_bytevectors_ground_env(klisp_State *K)
p2tv(kimmutable_bytevectorp));
add_applicative(K, ground_env, "mutable-bytevector?", ftypep, 2, symbol,
p2tv(kmutable_bytevectorp));
+ /* ??.1.? bytevector */
+ add_applicative(K, ground_env, "bytevector", bytevector, 0);
+ /* ??.1.? list->bytevector */
+ add_applicative(K, ground_env, "list->bytevector", list_to_bytevector, 0);
+ /* ??.1.? bytevector->list */
+ add_applicative(K, ground_env, "bytevector->list", bytevector_to_list, 0);
/* ??.1.2? make-bytevector */
add_applicative(K, ground_env, "make-bytevector", make_bytevector, 0);
/* ??.1.3? bytevector-length */
diff --git a/src/kgbytevectors.h b/src/kgbytevectors.h
@@ -7,46 +7,7 @@
#ifndef kgbytevectors_h
#define kgbytevectors_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* ??.1.1? bytevector? */
-/* uses typep */
-
-/* ??.1.2? make-bytevector */
-void make_bytevector(klisp_State *K);
-
-/* ??.1.3? bytevector-length */
-void bytevector_length(klisp_State *K);
-
-/* ??.1.4? bytevector-u8-ref */
-void bytevector_u8_ref(klisp_State *K);
-
-/* ??.1.5? bytevector-u8-set! */
-void bytevector_u8_setB(klisp_State *K);
-
-/* ??.2.?? bytevector-copy */
-void bytevector_copy(klisp_State *K);
-
-/* ??.2.?? bytevector-copy! */
-void bytevector_copyB(klisp_State *K);
-
-/* ??.2.?? bytevector-copy-partial */
-void bytevector_copy_partial(klisp_State *K);
-
-/* ??.2.?? bytevector-copy-partial! */
-void bytevector_copy_partialB(klisp_State *K);
-
-/* ??.2.?? bytevector->immutable-bytevector */
-void bytevector_to_immutable_bytevector(klisp_State *K);
/* init ground */
void kinit_bytevectors_ground_env(klisp_State *K);
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -139,7 +139,7 @@ void string_setB(klisp_State *K)
/* Helper for string and list->string */
/* GC: Assumes ls is rooted */
-inline TValue list_to_string_h(klisp_State *K, char *name, TValue ls)
+TValue list_to_string_h(klisp_State *K, char *name, TValue ls)
{
int32_t dummy;
/* don't allow cycles */
diff --git a/src/kgstrings.h b/src/kgstrings.h
@@ -7,84 +7,7 @@
#ifndef kgstrings_h
#define kgstrings_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* 13.1.1? string? */
-/* uses typep */
-
-/* 13.1.? immutable-string?, mutable-string? */
-/* use ftypep */
-
-/* 13.1.2? make-string */
-void make_string(klisp_State *K);
-
-/* 13.1.3? string-length */
-void string_length(klisp_State *K);
-
-/* 13.1.4? string-ref */
-void string_ref (klisp_State *K);
-
-/* 13.1.5? string-set! */
-void string_setS (klisp_State *K);
-
-/* 13.2.1? string */
-void string(klisp_State *K);
-
-/* 13.2.2? string=?, string-ci=? */
-/* use ftyped_bpredp */
-
-/* 13.2.3? string<?, string<=?, string>?, string>=? */
-/* use ftyped_bpredp */
-
-/* 13.2.4? string-ci<?, string-ci<=?, string-ci>?, string-ci>=? */
-/* use ftyped_bpredp */
-
-/* Helpers for binary predicates */
-/* XXX: this should probably be in file kstring.h */
-bool kstring_eqp(TValue str1, TValue str2);
-bool kstring_ci_eqp(TValue str1, TValue str2);
-
-bool kstring_ltp(TValue str1, TValue str2);
-bool kstring_lep(TValue str1, TValue str2);
-bool kstring_gtp(TValue str1, TValue str2);
-bool kstring_gep(TValue str1, TValue str2);
-
-bool kstring_ci_ltp(TValue str1, TValue str2);
-bool kstring_ci_lep(TValue str1, TValue str2);
-bool kstring_ci_gtp(TValue str1, TValue str2);
-bool kstring_ci_gep(TValue str1, TValue str2);
-
-
-/* 13.2.5? substring */
-void substring(klisp_State *K);
-
-/* 13.2.6? string-append */
-void string_append(klisp_State *K);
-
-/* 13.2.7? string->list, list->string */
-void list_to_string(klisp_State *K);
-void string_to_list(klisp_State *K);
-
-/* 13.2.8? string-copy */
-void string_copy(klisp_State *K);
-
-/* 13.2.9? string->immutable-string */
-void string_to_immutable_string(klisp_State *K);
-
-/* 13.2.10? string-fill! */
-void string_fillB(klisp_State *K);
-
-/* Helpers */
-bool kstringp(TValue obj);
/* init ground */
void kinit_strings_ground_env(klisp_State *K);
diff --git a/src/tests/bytevectors.k b/src/tests/bytevectors.k
@@ -5,9 +5,6 @@
;; helper functions
;;
-;; (list->bytevector INTEGERS) converts list of integers to bytevector
-;; The elements of INTEGERS must be in the range 0...255.
-;;
;; (u8 X_0 X_1 ... X_{N-1}) returns a bytevector B of length N,
;; such that B[k] = X_k
;;
@@ -19,23 +16,8 @@
;; such that the bytes B[4k] ... B[4k+3], combined into 32-bit
;; unsigned integer, represent the number X_k
;;
-($define! list->bytevector
- ($lambda (bytes)
- ($let*
- ( (n (length bytes))
- (v (make-bytevector n)) )
- ($letrec
- ((loop ($lambda (i xs)
- ($if (<? i n)
- ($sequence
- (bytevector-u8-set! v i (car xs))
- (loop (+ i 1) (cdr xs)))
- #inert))))
- (loop 0 bytes)
- v))))
-
-($define! u8
- ($lambda bytes (list->bytevector bytes)))
+
+($define! u8 bytevector)
;; TODO: endianess
($define! u16
@@ -73,6 +55,27 @@
($check-predicate (mutable-bytevector?))
($check-predicate (mutable-bytevector? (make-bytevector 1)))
+;; XXX bytevector
+($check-predicate (bytevector? (bytevector 1 2 3)))
+($check-predicate (mutable-bytevector? (bytevector 1 2 3)))
+($check equal? (bytevector 1 2 3) (list->bytevector (list 1 2 3)))
+
+;; XXX list->bytevector
+($check equal? (make-bytevector 0) (list->bytevector ()))
+($check equal? (make-bytevector 3 1) (list->bytevector (list 1 1 1)))
+($check equal? (list->bytevector (list 1 2 3 4)) (u8 1 2 3 4))
+($check-predicate (mutable-bytevector? (list->bytevector (list 1 2 3))))
+($check-predicate (mutable-bytevector? (list->bytevector
+ (copy-es-immutable (list 1 2 3)))))
+
+;; XXX bytevector->list
+($check-predicate (null? (bytevector->list (u8))))
+($check equal? (bytevector->list (u8 1 2 3 4)) (list 1 2 3 4))
+($check-predicate (mutable-pair? (bytevector->list (u8 1 2))))
+($check-predicate (mutable-pair? (bytevector->list
+ (bytevector->immutable-bytevector
+ (u8 1 2)))))
+
;; (R7RS 3rd draft, section 6.3.7) make-bytevector bytevector-length
($check equal? (bytevector-length (make-bytevector 0)) 0)
@@ -163,11 +166,11 @@
($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)))
+($check-predicate (inert? (bytevector-u8-fill! (u8 1 2) 0)))
+($check equal? ($let ((b (u8 1 2 3)))
(bytevector-u8-fill! b 0)
b)
- (bytevector 0 0 0))
+ (u8 0 0 0))
;; XXX bytevector->immutable-bytevector
