klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

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:
Msrc/Makefile | 2+-
Msrc/examples/ffi-gsl.k | 6+++---
Msrc/examples/ffi-sdl.k | 10+++++-----
Asrc/examples/ffi-signal.c | 87+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/examples/ffi-signal.k | 58++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/examples/ffi-signal.makefile | 16++++++++++++++++
Msrc/examples/ffi.k | 28++++++++++++++--------------
Msrc/kgffi.c | 64++++++++++++++++++++++++++++++++++++++++------------------------
Msrc/kgports.c | 4++--
Asrc/tests/bytevectors.k | 170+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/tests/memory-ports.k | 98+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Msrc/tests/test-all.k | 2++
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)