klisp

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

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:
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++++++++++++++++++++++++++++++++++++++++------------------------
Asrc/tests/bytevectors.k | 170+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Msrc/tests/environments.k | 397++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
Asrc/tests/memory-ports.k | 98+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Msrc/tests/test-all.k | 2++
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)