commit 9f582544df2887a89f72b871143b7b8022e15461
parent cbeffb8e1ebdd3b53491b728477ae9d08bf2ac44
Author: Oto Havle <havleoto@gmail.com>
Date: Sun, 20 Nov 2011 14:03:24 +0100
Backported tests and bugfixes to r7rs.
Diffstat:
12 files changed, 496 insertions(+), 49 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -107,7 +107,7 @@ mingw:
posix:
$(MAKE) all \
"MYCFLAGS=-DKLISP_USE_POSIX $(if $(USE_LIBFFI),-DKUSE_LIBFFI=1 -Dread=klisp_read -Dwrite=klisp_write)" \
- "MYLIBS=$(if $(USE_LIBFFI), -ldl -lffi)"
+ "MYLIBS=$(if $(USE_LIBFFI), -rdynamic -ldl -lffi)"
# list targets that do not create files (but not all makes understand .PHONY)
.PHONY: all default o clean
diff --git a/src/examples/ffi-gsl.k b/src/examples/ffi-gsl.k
@@ -24,7 +24,7 @@
(cif (ffi-make-call-interface abi "double" (list "double" "pointer"))) )
($lambda (f)
($let
- ( (gslf (make-blob (* 2 pointer-size)) )
+ ( (gslf (make-bytevector (* 2 pointer-size)) )
(aux ($lambda (x params) (f x))))
(set! (list gslf 0) (ffi-make-callback aux cif))
gslf))))
@@ -39,8 +39,8 @@
((gslf (make-gsl-function f)))
($lambda (x h)
($let
- ( (result (make-blob double-size))
- (abserr (make-blob double-size)))
+ ( (result (make-bytevector double-size))
+ (abserr (make-bytevector double-size)))
(gsl_deriv_central gslf x h result abserr)
(list (ref result) (ref abserr))))))))
diff --git a/src/examples/ffi-sdl.k b/src/examples/ffi-sdl.k
@@ -45,10 +45,10 @@
((SDL_WaitEvent (sdl-import "sint" "SDL_WaitEvent" "pointer")))
($lambda ()
($let*
- ( (buffer (make-blob 512))
+ ( (buffer (make-bytevector 512))
(ok (SDL_WaitEvent buffer)))
($if (zero? ok)
- (apply-continuation error-continuation "SDL_WaitEvent signalled error")
+ (error "SDL_WaitEvent signalled error")
buffer)))))
($define! align
@@ -113,14 +113,14 @@
(write status)
(newline)
($if (<? status 0)
- (apply error-continuation "error initializing SDL")
+ (error "error initializing SDL")
($sequence
(guard-dynamic-extent
()
($lambda ()
($let* ((screen (sdl-set-video-mode 640 480 32 SDL_HWSURFACE)))
($if (null? screen)
- (apply-continuation error-contination "unable to set video mode")
+ (error "unable to set video mode")
($sequence
(sdl-wm-set-caption window-title ())
(worker screen)))))
@@ -156,7 +156,7 @@
(SDL_Flip (sdl-import "sint" "SDL_Flip" "pointer")))
($lambda (screen (x y) (r g b))
($if (<? (SDL_LockSurface screen) 0)
- (apply error-continuation "SDL_LockSurface failed")
+ (error "SDL_LockSurface failed")
())
($let
( (pixels (SDL_Surface.pixels screen))
diff --git a/src/examples/ffi-signal.c b/src/examples/ffi-signal.c
@@ -0,0 +1,87 @@
+/*
+** ffi-signal.c
+**
+** Example of interpreter extension. Please follow instructions
+** in ffi-signal.k.
+**
+*/
+
+#include <signal.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <string.h>
+#include <stdio.h>
+
+#include "kstate.h"
+#include "kstring.h"
+#include "kport.h"
+#include "kghelpers.h"
+
+#if !defined(KLISP_USE_POSIX) || !defined(KUSE_LIBFFI)
+# error "Bad klisp configuration."
+#endif
+
+static int self_pipe[2];
+
+static void handler(int signo)
+{
+ uint8_t message = (uint8_t) signo;
+ write(self_pipe[1], &message, 1);
+}
+
+static void install_signal_handler(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "string", ttisstring, signame);
+ int signo;
+
+ if (!strcmp(kstring_buf(signame), "SIGINT")) {
+ signo = SIGINT;
+ } else if (!strcmp(kstring_buf(signame), "SIGCLD")) {
+ signo = SIGCLD;
+ } else {
+ klispE_throw_simple_with_irritants(K, "unsupported signal", 1, signame);
+ return;
+ }
+ signal(signo, handler);
+ kapply_cc(K, KINERT);
+}
+
+static void open_signal_port(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ FILE *fw = fdopen(self_pipe[0], "r");
+ TValue filename = kstring_new_b_imm(K, "**SIGNAL**");
+ krooted_tvs_push(K, filename);
+ TValue port = kmake_std_fport(K, filename, false, true, fw);
+ krooted_tvs_pop(K);
+ kapply_cc(K, port);
+}
+
+static void safe_add_applicative(klisp_State *K, TValue env,
+ const char *name,
+ klisp_Ofunc fn)
+{
+ TValue symbol = ksymbol_new(K, name, KNIL);
+ krooted_tvs_push(K, symbol);
+ TValue value = kmake_applicative(K, fn, 0);
+ krooted_tvs_push(K, value);
+ kadd_binding(K, env, symbol, value);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+}
+
+void kinit_signal_example(klisp_State *K)
+{
+ pipe(self_pipe);
+ fcntl(self_pipe[1], F_SETFL, O_NONBLOCK);
+ safe_add_applicative(K, K->next_env, "install-signal-handler", install_signal_handler);
+ safe_add_applicative(K, K->next_env, "open-signal-port", open_signal_port);
+ klisp_assert(K->rooted_tvs_top == 0);
+ klisp_assert(K->rooted_vars_top == 0);
+}
diff --git a/src/examples/ffi-signal.k b/src/examples/ffi-signal.k
@@ -0,0 +1,58 @@
+;;
+;; Dynamic FFI example.
+;; Signal handling and interpreter extension implemented in C.
+;;
+;; usage:
+;; .../src$ make posix USE_LIBFFI=1
+;; $ cd examples
+;; $ make -f ffi-signal.makefile
+;; $ ../klisp ffi-signal.k
+;;
+;; files:
+;; ffi-signal.so ......... interpreter extension compiled to a DLL
+;; ffi-signal.k .......... example of client code
+;; ffi-signal.c ......... C source of the extension
+;; ffi-signal.makefile ... build script
+;;
+
+;; (ffi-klisp-state) returns a value which encodes pointer
+;; to the interpreter global state (klisp_State *).
+;;
+;; The following code loads the dynamic library ffi-signal.so
+;; and passes the klisp_State pointer to the initialization
+;; function kinit_signal_example(). Having access to the
+;; internal interpreter structures, the initialization function
+;; adds new bindings to the current dynamic environment.
+;;
+((ffi-make-applicative
+ (ffi-load-library "./ffi-signal.so")
+ "kinit_signal_example"
+ (ffi-make-call-interface
+ "FFI_DEFAULT_ABI" "void" (list "pointer")))
+ (ffi-klisp-state))
+
+;; The dynamic environment now contains two new bindings:
+;;
+;; (install-signal-handler SIGNAME) installs handler for
+;; the signal named SIGNAME (e.g. "SIGINT"). Whenever
+;; a signal arrives, the handler writes a byte into
+;; an internal pipe.
+;;
+;; (open-signal-port) opens the read-end of the internal pipe
+;; as a binary input port.
+;;
+;; The following code demonstrates the signal handling (it is not
+;; possible to install arbitrary klisp procedure as a signal handler,
+;; because the interpreter is not reentrant).
+;;
+(install-signal-handler "SIGINT")
+($define! signal-port (open-signal-port))
+(display "Installed signal handler for SIGINT. Press Ctrl-C to continue...")
+(read-u8 signal-port)
+(newline)
+(display "Signal detected. Press Ctrl-C again...")
+(read-u8 signal-port)
+(newline)
+(display "Done.")
+(newline)
+
diff --git a/src/examples/ffi-signal.makefile b/src/examples/ffi-signal.makefile
@@ -0,0 +1,16 @@
+#
+# ffi-signal.makefile
+#
+# Build script for ffi-signal.so. Please follow instructions
+# in ffi-signal.k.
+#
+
+INCLUDES := -I..
+CFLAGS := -O2 -g -std=gnu99 -Wall -m32 -shared -fPIC \
+ -DKLISP_USE_POSIX -DKUSE_LIBFFI=1
+
+ffi-signal.so: ffi-signal.c
+ gcc $(CFLAGS) $(INCLUDES) -o $@ ffi-signal.c
+
+clean:
+ rm -f ffi-signal.so
diff --git a/src/examples/ffi.k b/src/examples/ffi.k
@@ -41,7 +41,7 @@
;; "uint64" uint64_t fixint, bigint
;; "float" float double
;; "double" double double
-;; "pointer" (void *) blob (only for arguments)
+;; "pointer" (void *) bytevector (only for arguments)
;; string (only for arguments)
;; nil
;; pointer (TAG_USER)
@@ -122,7 +122,7 @@
;; (REF MEMORY-LOCATION)
;; (SET! MEMORY-LOCATION VALUE)
;;
-;; MEMORY-LOCATION is either blob, string, pointer,
+;; MEMORY-LOCATION is either bytevector, string, pointer,
;; or a two-element list (MEMORY-LOCATION OFFSET).
;; The offset specification can not be nested, i.e.
;; ((blob 1) 2) is not valid memory location.
@@ -136,7 +136,7 @@
(newline)
;; Using ffi-type-suite, one can define means to convert
-;; C structs (stored in blobs or arbitrary memory locations)
+;; C structs (stored in bytevectors or arbitrary memory locations)
;; to lists.
;;
($define! align
@@ -184,7 +184,7 @@
(ffi-make-call-interface abi
"sint" (list "pointer" "pointer")))))
($lambda ()
- ($let* ((buffer (make-blob (* 2 sint-size))))
+ ($let* ((buffer (make-bytevector (* 2 sint-size))))
(unix-gettimeofday buffer ())
($let (((tv_sec tv_usec) (struct-timeval-ref buffer)))
(list tv_sec (/ tv_usec 1000000)))))))
@@ -203,8 +203,8 @@
(decode-struct "sint" "sint" "sint" "sint" "sint" "sint" "sint" "sint")))
($lambda (t)
($let*
- ( (t-buf (make-blob sint-size))
- (tm-buf (make-blob 128)) )
+ ( (t-buf (make-bytevector sint-size))
+ (tm-buf (make-bytevector 128)) )
(sint-set! t-buf t)
(localtime-r t-buf tm-buf)
($let
@@ -236,21 +236,21 @@
;; (ffi-memmove DESTINATION SOURCE SIZE) copies
;; SIZE bytes from SOURCE to DESTINATION. Both SOURCE
;; and DESTINATION are memory locations as described above.
-;; ffi-memmove can copy data between blobs and arbitrary
+;; ffi-memmove can copy data between bytevectors and arbitrary
;; memory locations.
;;
($define! copy-location
($lambda (location size)
- ($let ((blob (make-blob size)))
+ ($let ((blob (make-bytevector size)))
(ffi-memmove blob location size)
blob)))
-($define! blob->list
+($define! bytevector->list
($letrec
((aux ($lambda (blob index)
- ($if (<? index (blob-length blob))
+ ($if (<? index (bytevector-length blob))
(cons
- (blob-u8-ref blob index)
+ (bytevector-u8-ref blob index)
(aux blob (+ 1 index)))
()))))
($lambda (blob)
@@ -258,7 +258,7 @@
($define! parse-address
($lambda (location size)
- (blob->list (copy-location location size))))
+ (bytevector->list (copy-location location size))))
($define!
(voidptr-size voidptr-alignment voidptr-ref voidptr-set!)
@@ -322,10 +322,10 @@
($define! endianess
($let
- ((buffer (make-blob 4)))
+ ((buffer (make-bytevector 4)))
(uint32-set! buffer #x01020304)
($let
- ((bytes (blob->list buffer)))
+ ((bytes (bytevector->list buffer)))
($cond
((equal? bytes (list 1 2 3 4)) "big-endian")
((equal? bytes (list 4 3 2 1)) "little-endian")
diff --git a/src/kgffi.c b/src/kgffi.c
@@ -260,6 +260,23 @@ static void ffi_encode_uint32(ffi_codec_t *self, klisp_State *K, TValue v, void
}
}
+static TValue ffi_decode_sint32(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ return i2tv(*(int32_t *)buf);
+}
+
+static void ffi_encode_sint32(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ if (ttisfixint(v)) {
+ *(int32_t *) buf = ivalue(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to convert to C int32_t", 1, v);
+ return;
+ }
+}
+
static TValue ffi_decode_uint64(ffi_codec_t *self, klisp_State *K, const void *buf)
{
/* TODO */
@@ -352,6 +369,7 @@ static ffi_codec_t ffi_codecs[] = {
SIMPLE_TYPE(uint16),
SIMPLE_TYPE(sint16),
SIMPLE_TYPE(uint32),
+ SIMPLE_TYPE(sint32),
SIMPLE_TYPE(uint64),
SIMPLE_TYPE(float),
SIMPLE_TYPE(double)
@@ -478,30 +496,24 @@ void ffi_make_call_interface(klisp_State *K, TValue *xparams,
size_t nargs = check_typed_list(K, "ffi-make-call-interface", "argtype string",
kstringp, false, argtypes_tv, NULL);
- krooted_tvs_push(K, abi_tv);
- krooted_tvs_push(K, rtype_tv);
- krooted_tvs_push(K, argtypes_tv);
- TValue key = xparams[0];
- krooted_tvs_push(K, key);
+ /* Allocate C structure ffi_call_interface_t inside
+ a mutable bytevector. The structure contains C pointers
+ into itself. It must never be reallocated or copied.
+ The bytevector will be encapsulated later to protect
+ it from lisp code. */
+
size_t bytevector_size = sizeof(ffi_call_interface_t) + (sizeof(ffi_codec_t *) + sizeof(ffi_type)) * nargs;
- /* XXX was immutable, but there is no immutable bytevector constructor
- without buffer now, is it really immutable?? see end of function
- Andres Navarro */
TValue bytevector = kbytevector_new_sf(K, bytevector_size, 0);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
+ krooted_tvs_push(K, bytevector);
ffi_call_interface_t *p = (ffi_call_interface_t *) tv2bytevector(bytevector)->b;
p->acodecs = (ffi_codec_t **) ((char *) p + sizeof(ffi_call_interface_t));
p->argtypes = (ffi_type **) ((char *) p + sizeof(ffi_call_interface_t) + nargs * sizeof(ffi_codec_t *));
-
p->nargs = nargs;
p->rcodec = tv2ffi_codec(K, rtype_tv);
if (p->rcodec->decode == NULL) {
- klispE_throw_simple(K, "this type is not allowed as a return type");
- return;
+ klispE_throw_simple_with_irritants(K, "this type is not allowed as a return type", 1, rtype_tv);
+ return;
}
p->buffer_size = p->rcodec->libffi_type->size;
@@ -509,7 +521,7 @@ void ffi_make_call_interface(klisp_State *K, TValue *xparams,
for (int i = 0; i < nargs; i++) {
p->acodecs[i] = tv2ffi_codec(K, kcar(tail));
if (p->acodecs[i]->encode == NULL) {
- klispE_throw_simple(K, "this type is not allowed in argument list");
+ klispE_throw_simple_with_irritants(K, "this type is not allowed in argument list", 1, kcar(tail));
return;
}
ffi_type *t = p->acodecs[i]->libffi_type;
@@ -533,16 +545,10 @@ void ffi_make_call_interface(klisp_State *K, TValue *xparams,
klispE_throw_simple(K, "unknown error in ffi_prep_cif");
return;
}
- /* XXX if it should really be immutable this is the only sane way I can
- think of. If not, just remove.
- Andres Navarro */
- krooted_tvs_push(K, bytevector);
- bytevector = kbytevector_new_bs_imm(K, kbytevector_buf(bytevector),
- kbytevector_size(bytevector));
- krooted_tvs_push(K, bytevector);
+
+ TValue key = xparams[0];
TValue enc = kmake_encapsulation(K, key, bytevector);
krooted_tvs_pop(K);
- krooted_tvs_pop(K);
kapply_cc(K, enc);
}
@@ -1088,6 +1094,15 @@ void ffi_type_suite(klisp_State *K, TValue *xparams,
kapply_cc(K, suite_tv);
}
+void ffi_klisp_state(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ check_0p(K, ptree);
+ kapply_cc(K, p2tv(K));
+}
+
/* init ground */
void kinit_ffi_ground_env(klisp_State *K)
{
@@ -1116,6 +1131,7 @@ void kinit_ffi_ground_env(klisp_State *K)
add_applicative(K, ground_env, "ffi-make-callback", ffi_make_callback, 2, cif_key, cb_tab);
add_applicative(K, ground_env, "ffi-memmove", ffi_memmove, 0);
add_applicative(K, ground_env, "ffi-type-suite", ffi_type_suite, 0);
+ add_applicative(K, ground_env, "ffi-klisp-state", ffi_klisp_state, 0);
add_applicative(K, ground_env, "ffi-library?", enc_typep, 1, dll_key);
add_applicative(K, ground_env, "ffi-call-interface?", enc_typep, 1, cif_key);
}
diff --git a/src/kgports.c b/src/kgports.c
@@ -223,7 +223,7 @@ void get_output_buffer(klisp_State *K, TValue *xparams, TValue ptree,
*/
bool binaryp = bvalue(xparams[0]);
UNUSED(denv);
- bind_1tp(K, ptree, "port", ttisport, port);
+ bind_1tp(K, ptree, "port", ttismport, port);
if (binaryp && !kport_is_binary(port)) {
klispE_throw_simple(K, "the port should be a bytevector port");
@@ -448,7 +448,7 @@ void write_u8(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
return;
}
- kwrite_char_to_port(K, port, u8);
+ kwrite_u8_to_port(K, port, u8);
kapply_cc(K, KINERT);
}
diff --git a/src/tests/bytevectors.k b/src/tests/bytevectors.k
@@ -0,0 +1,170 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of bytevector features.
+;;
+
+;; 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
+;;
+;; (u16 X_0 X_1 ... X_{N-1}) returns a bytevector B of length 2N,
+;; such that the bytes B[2k], B[2k+1], combined into 16-bit
+;; unsigned integer, represent the number X_k
+;;
+;; (u32 X_0 X_1 ... X_{N-1}) returns a bytevector of length 4N
+;; 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)))
+
+;; TODO: endianess
+($define! u16
+ ($let
+ ((decompose ($lambda (w) (list (mod w 256) (div w 256)))))
+ ($lambda words
+ (list->bytevector (apply append (map decompose words))))))
+
+;; TODO: endianess
+($define! u32
+ ($let
+ ((decompose
+ ($lambda (w)
+ (list (mod w 256) (mod (div w 256) 256)
+ (mod (div w 65536) 256) (div w 16777216)))))
+ ($lambda words
+ (list->bytevector (apply append (map decompose words))))))
+
+
+;; XXX bytevector?
+
+($check-predicate (bytevector?))
+($check-predicate (bytevector? (make-bytevector 0)))
+($check-predicate (bytevector? (make-bytevector 1)))
+
+($check-not-predicate (bytevector? 0))
+($check-not-predicate (bytevector? ""))
+($check-not-predicate (bytevector? ()))
+
+;; XXX immutable-bytevector? mutable-bytevector?
+
+($check-predicate (immutable-bytevector?))
+($check-predicate (immutable-bytevector? (make-bytevector 0)))
+
+($check-predicate (mutable-bytevector?))
+($check-predicate (mutable-bytevector? (make-bytevector 1)))
+
+;; (R7RS 3rd draft, section 6.3.7) make-bytevector bytevector-length
+
+($check equal? (bytevector-length (make-bytevector 0)) 0)
+($check equal? (bytevector-length (make-bytevector 0 0)) 0)
+($check equal? (bytevector-length (make-bytevector 1)) 1)
+($check equal? (bytevector-length (make-bytevector 1 2)) 1)
+($check equal? (bytevector-length (make-bytevector 8192)) 8192)
+
+;; (R7RS 3rd draft, section 6.3.7) bytevector-u8-ref
+
+($check equal? (bytevector-u8-ref (make-bytevector 10 0) 1) 0)
+($check equal? (bytevector-u8-ref (make-bytevector 10 123) 5) 123)
+($check equal? (bytevector-u8-ref (make-bytevector 10 255) 9) 255)
+
+;; (R7RS 3rd draft, section 6.3.7) bytevector-u8-set!
+;; additional property: returns #inert
+;; additional property: destination must be mutable
+;;
+($let*
+ ((v (make-bytevector 10))
+ (w (bytevector->immutable-bytevector v)))
+ ($check equal? (bytevector-u8-set! v 0 1) #inert)
+ ($check equal? (bytevector-u8-ref v 0) 1)
+ ($check equal? (bytevector-u8-set! v 0 32) #inert)
+ ($check equal? (bytevector-u8-ref v 0) 32)
+ ($check equal? (bytevector-u8-set! v 6 42) #inert)
+ ($check equal? (bytevector-u8-ref v 0) 32)
+ ($check equal? (bytevector-u8-ref v 6) 42)
+ ($check-error (bytevector-u8-ref v -1))
+ ($check-error (bytevector-u8-ref v 10))
+ ($check-error (bytevector-u8-ref v 12345))
+ ($check-error (bytevector-u8-set! v -1 0))
+ ($check-error (bytevector-u8-set! v 10 255))
+ ($check-error (bytevector-u8-set! v 5 -1))
+ ($check-error (bytevector-u8-set! v 9 256))
+ ($check-error (bytevector-u8-set! v 9 #\x))
+ ($check-error (bytevector-u8-set! v 9 #f))
+ ($check-error (bytevector-u8-set! w 0 0)))
+
+;; (R7RS 3rd draft, section 6.3.7) bytevector-copy
+;;
+($check equal? (bytevector-copy (u8 1 2 3)) (u8 1 2 3))
+($check-predicate (mutable-bytevector? (bytevector-copy (u8 1 2 3))))
+
+($check-predicate
+ (mutable-bytevector?
+ (bytevector-copy (bytevector->immutable-bytevector (u8 1 2 3)))))
+
+;; XXX bytevector-copy!
+;; additional property: returns #inert
+;; additional property: destination must be mutable
+;;
+($let ((v (make-bytevector 5 0)))
+ ($check equal? (bytevector-copy! (u8 1 2 3 4 5) v) #inert)
+ ($check equal? v (u8 1 2 3 4 5))
+ ($check-no-error (bytevector-copy! (bytevector->immutable-bytevector (u8 9 9)) v))
+ ($check equal? v (u8 9 9 3 4 5))
+ ($check-error (bytevector-copy! (u8 1 2 3 4 5 6) v))
+ ($check-error
+ (bytevector-copy!
+ (u8 1)
+ (bytevector->immutable-bytevector (u8 1)))))
+
+;; (R7RS 3rd draft, section 6.3.7) bytevector-copy-partial
+
+($check equal? (bytevector-copy-partial (u8 1 2 3) 0 0) (u8))
+($check equal? (bytevector-copy-partial (u8 1 2 3) 0 2) (u8 1 2))
+($check equal? (bytevector-copy-partial (u8 1 2 3) 2 3) (u8 3))
+($check equal? (bytevector-copy-partial (u8 1 2 3) 3 3) (u8))
+($check-error (bytevector-copy-partial (u8 1 2 3) 2 4))
+($check-error (bytevector-copy-partial (u8 1 2 3) -1 0))
+
+;; R7RS 3rd draft, section 6.3.7) bytevector-copy-partial!
+;; additional property: returns #inert
+;; additional property: destination must be mutable
+;;
+($let*
+ ((v (make-bytevector 5 9))
+ (w (bytevector->immutable-bytevector v)))
+ ($check equal? (bytevector-copy-partial! (u8 1 2) 0 2 v 0) #inert)
+ ($check equal? v (u8 1 2 9 9 9))
+ ($check equal? (bytevector-copy-partial! (u8 5 6) 1 2 v 4) #inert)
+ ($check equal? v (u8 1 2 9 9 6))
+ ($check-error (bytevector-copy-partial! (u8 1 2) 0 2 v -1))
+ ($check-error (bytevector-copy-partial! (u8 1 2) 0 2 v 4))
+ ($check-error (bytevector-copy-partial! (u8 1 2) 2 3 v 0))
+ ($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->immutable-bytevector
+
+($check-predicate
+ (immutable-bytevector? (bytevector->immutable-bytevector (u8 1 2))))
+($check-not-predicate
+ (mutable-bytevector? (bytevector->immutable-bytevector (u8 1 2))))
diff --git a/src/tests/memory-ports.k b/src/tests/memory-ports.k
@@ -0,0 +1,98 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of string and bytevector port features.
+;;
+
+;; (R7RS 3rd draft, section 6.7.1) open-input-string
+;; TODO: char-ready?
+;; TODO: unicode input
+;; TODO: closing
+;;
+($let ((p (open-input-string "")))
+ ($check-predicate (port? p))
+ ($check-predicate (input-port? p))
+ ($check-not-predicate (output-port? p))
+ ($check-predicate (textual-port? p))
+ ($check-not-predicate (binary-port? p))
+ ($check-predicate (port-open? p))
+ ($check-predicate (eof-object? (peek-char p)))
+ ($check-predicate (eof-object? (read-char p))))
+
+($let ((p (open-input-string "abc")))
+ ($check equal? (read-char p) #\a)
+ ($check equal? (peek-char p) #\b)
+ ($check equal? (read-char p) #\b)
+ ($check equal? (read-char p) #\c)
+ ($check-predicate (eof-object? (read-char p))))
+
+($let ((p (open-input-string "(1 2 #ignore) \"x\"")))
+ ($check equal? (read p) (list 1 2 #ignore))
+ ($check equal? (read p) "x")
+ ($check-predicate (eof-object? (read p))))
+
+;; (R7RS 3rd draft, section 6.7.1) open-output-string get-output-string
+;; TODO: newline
+;;
+($let ((p (open-output-string)))
+ ($check-predicate (port? p))
+ ($check-predicate (output-port? p))
+ ($check-not-predicate (input-port? p))
+ ($check-predicate (textual-port? p))
+ ($check-not-predicate (binary-port? p))
+ ($check-predicate (port-open? p))
+ ($check equal? (get-output-string p) "")
+ ($check-no-error (write-char #\a p))
+ ($check equal? (get-output-string p) "a")
+ ($check-no-error (display "bc" p))
+ ($check equal? (get-output-string p) "abc")
+ ($check-no-error (write (list 1 "2" 3) p))
+ ($check equal? (get-output-string p) "abc(1 \"2\" 3)"))
+
+($check-error (get-output-string (get-current-input-port)))
+($check-error (get-output-string (get-current-output-port)))
+
+($let ((p (open-output-string)))
+ ($check-no-error (display (make-string 100 #\a) p))
+ ($check-no-error (display (make-string 1000 #\b) p))
+ ($check-no-error (display (make-string 10000 #\c) p))
+ ($check equal? (string-length (get-output-string p)) 11100)
+ ($check equal? (string-ref (get-output-string p) 11001) #\c))
+
+;; (R7RS 3rd draft, section 6.7.1) open-input-bytevector
+;; TODO: u8-ready?
+;; TODO: closing
+;;
+($let ((p (open-input-bytevector (make-bytevector 0))))
+ ($check-predicate (port? p))
+ ($check-predicate (input-port? p))
+ ($check-not-predicate (output-port? p))
+ ($check-predicate (binary-port? p))
+ ($check-not-predicate (textual-port? p))
+ ($check-predicate (eof-object? (peek-u8 p)))
+ ($check-predicate (eof-object? (read-u8 p))))
+
+($let*
+ ((v (make-bytevector 3 0))
+ (p ($sequence
+ (bytevector-u8-set! v 0 2)
+ (bytevector-u8-set! v 1 129)
+ (open-input-bytevector v))))
+ ($check equal? (read-u8 p) 2)
+ ($check equal? (peek-u8 p) 129)
+ ($check equal? (read-u8 p) 129)
+ ($check equal? (read-u8 p) 0)
+ ($check-predicate (eof-object? (read-u8 p))))
+
+;; (R7RS 3rd draft, section 6.7.1) open-output-bytevector get-output-bytevector
+
+($let ((p (open-output-bytevector)))
+ ($check equal? (bytevector-length (get-output-bytevector p)) 0)
+ ($check-no-error (write-u8 1 p))
+ ($check equal? (bytevector-length (get-output-bytevector p)) 1)
+ ($check-no-error (write-u8 10 p))
+ ($check-no-error (write-u8 129 p))
+ ($let ((v (get-output-bytevector p)))
+ ($check equal? (bytevector-length v) 3)
+ ($check equal? (bytevector-u8-ref v 0) 1)
+ ($check equal? (bytevector-u8-ref v 1) 10)
+ ($check equal? (bytevector-u8-ref v 2) 129)))
diff --git a/src/tests/test-all.k b/src/tests/test-all.k
@@ -21,6 +21,8 @@
(load "tests/strings.k")
(load "tests/characters.k")
(load "tests/ports.k")
+(load "tests/memory-ports.k")
(load "tests/error.k")
+(load "tests/bytevectors.k")
(check-report)
