commit 7f7e0f672136167bc67751bcac49ffebe23556eb
parent 1f9c663b61890c75280b3163e2667c7c216a2d7d
Author: Andres Navarro <canavarro82@gmail.com>
Date: Mon, 21 Nov 2011 05:37:39 -0300
Merged last batch of changes from Oto Havle
Diffstat:
12 files changed, 889 insertions(+), 49 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -108,7 +108,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/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/environments.k b/src/tests/environments.k
@@ -4,6 +4,399 @@
;;; Basic Functionality
;;;
-;; environment
+;; 4.8.1 environment?
+
($check-predicate (applicative? environment?))
-;; ....
+($check-predicate (environment?))
+($check-predicate (environment? (get-current-environment)))
+($check-not-predicate (environment? ()))
+
+;; 4.8.2 ignore?
+
+($check-predicate (applicative? ignore?))
+($check-predicate (ignore?))
+($check-predicate (ignore? #ignore))
+($check-not-predicate (ignore? #f))
+($check-not-predicate (ignore? 0))
+($check-not-predicate (ignore? ()))
+($check-not-predicate (ignore? #inert))
+($check-not-predicate (ignore? #undefined))
+
+;; 4.8.3 eval
+
+($check-predicate (applicative? eval))
+($check-error (eval))
+($check-error (eval 0))
+($check-error (eval 0 1))
+($check-error (eval 0 (get-current-environment) 2))
+
+($let*
+ ((env (make-environment))
+ ((encapsulate #ignore #ignore) (make-encapsulation-type))
+ (encapsulation (encapsulate 0))
+ (promise ($lazy (+ 1 1)))
+ (bytevector (make-bytevector 1)))
+ ($check eq? (eval #t env) #t)
+ ($check eq? (eval #inert env) #inert)
+ ($check eq? (eval () env) ())
+ ($check eq? (eval #ignore env) #ignore)
+ ($check eq? (eval env env) env)
+ ($check eq? (eval eval env) eval)
+ ($check eq? (eval $vau env) $vau)
+ ($check eq? (eval root-continuation env) root-continuation)
+ ($check eq? (eval encapsulation env) encapsulation)
+ ($check eq? (eval promise env) promise)
+ ($check eq? (eval 0 env) 0)
+ ($check eq? (eval "string" env) "string")
+ ($check eq? (eval #\c env) #\c)
+ ($check eq? (eval (get-current-input-port) env) (get-current-input-port))
+ ($check eq? (eval bytevector env) bytevector)
+ ($check-error (eval (string->symbol "eval") env))
+ ($check eq? (eval (list $quote 1) env) 1)
+ ($check equal? (eval (list + 1 1) env) 2)
+ ($check-error (eval (list* not? #t) env))
+ ($check-error (eval (list 1) env)))
+
+($let ((env ($bindings->environment (+ *))))
+ ($check equal? (eval ($quote (+ 1 1)) env) 1))
+
+;; 4.8.4 make-environment
+
+($check-predicate (applicative? make-environment))
+($check-predicate (environment? (make-environment)))
+($let*
+ ((x 0)
+ (e1 (make-environment))
+ (e2 (make-environment (get-current-environment)))
+ (e3 (make-environment e1))
+ (e4 (make-environment e2))
+ (es (list e1 e2 e3 e4)))
+ ($check-not-predicate ($binds? e1 x))
+ ($check-predicate ($binds? e2 x))
+ ($check-not-predicate ($binds? e3 x))
+ ($check-predicate ($binds? e4 x))
+ (encycle! es 1 3)
+ ($check-predicate ($binds? (apply make-environment es))))
+
+($check-not-predicate (eq? (make-environment) (make-environment)))
+($check-not-predicate (equal? (make-environment) (make-environment)))
+($check-not-predicate (equal? (make-environment) (get-current-environment)))
+
+;; 5.10.1 $let
+
+($check-predicate (operative? $let))
+($check equal? ($let () #t) #t)
+($check-error ($let (sym) #inert))
+($check-error ($let (sym 0) #inert))
+($check-error ($let loop ((x 0)) #inert))
+($check-error ($let ((sym 0 1)) #inert))
+
+($check-predicate
+ ($let
+ ((a (and?
+ (not? ($binds? (get-current-environment) a))
+ (not? ($binds? (get-current-environment) b))))
+ (b (and?
+ (not? ($binds? (get-current-environment) a))
+ (not? ($binds? (get-current-environment) b))))
+ (f ($lambda ()
+ (and?
+ (not? ($binds? (get-current-environment) f))
+ (not? ($binds? (get-current-environment) g)))))
+ (g ($lambda ()
+ (and?
+ (not? ($binds? (get-current-environment) f))
+ (not? ($binds? (get-current-environment) g))))))
+ (and? a b (f) (g))))
+
+;; 6.7.1 $binds?
+
+($check-predicate (operative? $binds?))
+($check-predicate ($binds? (make-environment)))
+
+;; 6.7.2 get-current-environment
+
+($check-predicate (applicative? get-current-environment))
+($check-predicate (environment? (get-current-environment)))
+($check-not-predicate ($binds? (get-current-environment) x))
+($let ((x 0))
+ ($check-predicate ($binds? (get-current-environment) x)))
+
+;; 6.7.3 make-kernel-standard-environment
+
+($check-predicate (applicative? make-kernel-standard-environment))
+
+($let ((x 0))
+ ($check-not-predicate
+ ($binds? (make-kernel-standard-environment) x)))
+
+;; symbols defined in the Kernel Report
+
+($check-predicate
+ ($binds? (make-kernel-standard-environment)
+ ;; 4.1 - 4.10
+ boolean?
+ eq?
+ equal?
+ symbol?
+ inert? $if
+ pair? null? cons
+ set-car! set-cdr! copy-es-immutable
+ environment? ignore? eval make-environment
+ $define!
+ operative? applicative? $vau wrap unwrap
+ ;; 5.1 - 5.10
+ $sequence
+ list list*
+ $vau $lambda
+ car cdr
+ caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ apply
+ $cond
+ get-list-metrics list-tail
+ encycle!
+ map
+ $let
+ ;; 6.1 - 6.4, 6.7 - 6.9
+ not? and? or? $and? $or?
+ combiner?
+ length list-ref append list-neighbors filter
+ assoc member? finite-list? countable-list? reduce
+ append! copy-es assq memq?
+ $binds? get-current-environment make-kernel-standard-environment
+ $let* $letrec $letrec* $let-redirect $let-safe $remote-eval
+ $bindings->environment
+ $set! $provide! $import!
+ for-each
+ ;; 7.1 - 7.3
+ continuation? call/cc extend-continuation guard-continuation
+ continuation->applicative root-continuation error-continuation
+ apply-continuation $let/cc guard-dynamic-extent exit
+ ;; 8.1
+ make-encapsulation-type
+ ;; 9.1
+ promise? force $lazy memoize
+ ;; 10.1
+ make-keyed-dynamic-variable
+ ;; 11.1
+ make-keyed-static-variable
+ ;; 12.1 - 12.10
+ number? finite? integer?
+ =? <? <=? >=? >?
+ + * -
+ zero?
+ div mod div-and-mod
+ div0 mod0 div0-and-mod0
+ positive? negative?
+ odd? even?
+ abs
+ max min
+ lcm gcd
+ exact? inexact? robust? undefined?
+ get-real-internal-bounds get-real-exact-bounds
+ get-real-internal-primary get-real-exact-primary
+ make-inexact
+ real->inexact real->exact
+ with-strict-arithmetic get-strict-arithmetic?
+ ;; not implemented: with-narrow-arithmetic get-narrow-arithmetic?
+ rational?
+ /
+ numerator denominator
+ floor ceiling truncate round
+ rationalize simplest-rational
+ real?
+ exp log
+ sin cos tan asin acos atan
+ sqrt expt
+ ;; not implemented: complex?
+ ;; not implemented: make-rectangular real-part imag-part
+ ;; not implemented: make-polar magnitude angle
+ ;; 13.1
+ string->symbol
+ ;; 15.1 - 15.2
+ port?
+ input-port? output-port?
+ with-input-from-file with-output-to-file
+ get-current-input-port get-current-output-port
+ open-input-file open-output-file
+ close-input-file close-output-file
+ read
+ write
+ call-with-input-file call-with-output-file
+ load
+ get-module))
+
+;; Additional symbols defined in klisp.
+
+($check-predicate
+ ($binds? (make-kernel-standard-environment)
+ ;; symbols
+ symbol->string
+ ;; strings
+ string?
+ symbol->string
+ ;; TODO
+ ;; chars
+ char?
+ char=? char<? char<=? char>=? char>?
+ char->integer integer->char
+ ;; TODO
+ ;; ports
+ textual-port? binary-port?
+ with-error-to-file
+ get-current-error-port
+ open-binary-input-file open-binary-output-file
+ close-input-port close-output-port close-port
+ eof-object?
+ read-char peek-char char-ready? write-char
+ newline
+ display
+ read-u8 peek-u8 u8-ready? write-u8
+ flush-output-port
+ file-exists? delete-file rename-file
+ ;; system functions
+ current-second current-jiffy jiffies-per-second
+ ;; bytevectors
+ bytevector?
+ ;; error handling
+ error system-error-continuation))
+
+;; 6.7.4 $let*
+
+($check-predicate (operative? $let*))
+($check equal? ($let* () #f) #f)
+($check equal? ($let* () #f #t) #t)
+($check-error ($let* (sym) #inert))
+($check-error ($let* (sym 0) #inert))
+($check-error ($let* loop ((x 0)) #inert))
+($check-error ($let* ((sym 0 1)) #inert))
+
+($check-predicate
+ ($let*
+ ((a (and?
+ (not? ($binds? (get-current-environment) a))
+ (not? ($binds? (get-current-environment) b))
+ (not? ($binds? (get-current-environment) c))))
+ (b (and?
+ ($binds? (get-current-environment) a)
+ (not? ($binds? (get-current-environment) b))
+ (not? ($binds? (get-current-environment) c))))
+ (c (and?
+ ($binds? (get-current-environment) a)
+ ($binds? (get-current-environment) b)
+ (not? ($binds? (get-current-environment) c))))
+ (f ($lambda ()
+ (and?
+ ($binds? (get-current-environment) a)
+ ($binds? (get-current-environment) b)
+ ($binds? (get-current-environment) c)
+ (not? ($binds? (get-current-environment) f))
+ (not? ($binds? (get-current-environment) g)))))
+ (g ($lambda ()
+ (and?
+ ($binds? (get-current-environment) a)
+ ($binds? (get-current-environment) b)
+ ($binds? (get-current-environment) c)
+ ($binds? (get-current-environment) f)
+ (not? ($binds? (get-current-environment) g))))))
+ (and? a b c (f) (g))))
+
+;; 6.7.5 $letrec
+
+($check-predicate (operative? $letrec))
+($check-no-error ($letrec () #inert))
+
+($check-predicate
+ ($letrec ((x (not? ($binds? (get-current-environment) x)))) x))
+
+($check-predicate
+ ($letrec
+ ((f ($lambda ()
+ (and?
+ ($binds? (get-current-environment) f)
+ ($binds? (get-current-environment) g))))
+ (g ($lambda ()
+ (and?
+ ($binds? (get-current-environment) f)
+ ($binds? (get-current-environment) g)))))
+ (and? (f) (g))))
+
+;; 6.7.6 $letrec*
+
+($check-predicate (operative? $letrec*))
+($check equal? ($letrec* () 123) 123)
+
+($check-predicate
+ ($letrec* ((x (not? ($binds? (get-current-environment) x)))) x))
+
+($check-predicate
+ ($letrec*
+ ((a 1)
+ (f ($lambda ()
+ (and?
+ ($binds? (get-current-environment) a)
+ ($binds? (get-current-environment) f)))))
+ (f)))
+
+($check-predicate
+ ($letrec*
+ ((f ($lambda ()
+ ($binds? (get-current-environment) f)))
+ (g ($lambda ()
+ (and?
+ ($binds? (get-current-environment) f)
+ ($binds? (get-current-environment) g)))))
+ (and? (f) (g))))
+
+($check-predicate
+ ($letrec*
+ ((a 1)
+ (b 2)
+ (f ($lambda () ($binds? (get-current-environment) f))))
+ (f)))
+
+;; 6.7.7 $let-redirect
+
+($check-predicate (operative? $let-redirect))
+($check equal? ($let-redirect (make-environment) () 42) 42)
+
+($let
+ ((a 1)
+ (env ($let ((a 2)) (get-current-environment))))
+ ($check equal? ($let-redirect (get-current-environment) () a) 1)
+ ($check equal? ($let-redirect env () a) 2)
+ ($check equal? ($let-redirect env ((a 3)) a) 3)
+ ($check equal? ($let-redirect env ((a a)) a) 1))
+
+;; 6.7.8 $let-safe
+
+($check-predicate (operative? $let-safe))
+($check equal? ($let-safe () 42) 42)
+($let
+ (($lambda 42))
+ ($check equal? ($let-safe ((x $lambda)) (($lambda () x))) 42)
+ ($check-error ($let ((x $lambda)) (($lambda () x)))))
+
+;; 6.7.9 $remote-eval
+
+($check-predicate (operative? $remote-eval))
+($check equal? ($remote-eval 42 (make-environment)) 42)
+
+($let
+ ((e0 (make-kernel-standard-environment))
+ (e1 ($let ((or? not?)) (get-current-environment))))
+ ($check equal? ($remote-eval (or? #t) e0) #t)
+ ($check equal? ($remote-eval (or? #t) e1) #f))
+
+;; 6.7.10 $bindings->environment
+
+($check-predicate (operative? $bindings->environment))
+($check-predicate (environment? ($bindings->environment)))
+($let
+ ((env ($bindings->environment (a 1) (b 2))))
+ ($check-predicate ($binds? env a b))
+ ($check equal? (eval ($quote a) env) 1)
+ ($check equal? (eval ($quote b) env) 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)
