[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-11-311-gb
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-11-311-gbf08e10 |
|
Date: |
Fri, 03 Sep 2010 14:26:00 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=bf08e10f59c062a5d5173ed7951874ed86d302aa
The branch, master has been updated
via bf08e10f59c062a5d5173ed7951874ed86d302aa (commit)
via 760538bf75262811c906129a3ea2b6defde3d27d (commit)
via 33186356668fe7697a8f2692660aaff69178d720 (commit)
from a148c752ba7adf0d2005cc7bc5928a2dde467609 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit bf08e10f59c062a5d5173ed7951874ed86d302aa
Author: Ludovic Courtès <address@hidden>
Date: Fri Sep 3 16:23:02 2010 +0200
Fix the `put-bytevector' tests.
* libguile/vports.c (sf_write): Add comment about what happens when DATA
contains binary data.
* test-suite/tests/r6rs-ports.test ("7.2.11 Binary
Output")["put-bytevector [2 args]", "put-bytevector [3 args]",
"put-bytevector [4 args]"]: Require a Latin-1 locale.
commit 760538bf75262811c906129a3ea2b6defde3d27d
Author: Ludovic Courtès <address@hidden>
Date: Fri Sep 3 15:32:31 2010 +0200
Add license header to `test-ffi'.
* test-suite/standalone/test-ffi: Add license header.
commit 33186356668fe7697a8f2692660aaff69178d720
Author: Ludovic Courtès <address@hidden>
Date: Fri Sep 3 15:12:54 2010 +0200
Add `procedure->pointer' to the FFI.
* libguile/foreign.c (make_cif): New procedure, with code formerly in
`scm_make_foreign_function'.
(scm_make_foreign_function): Use it.
(invoke_closure, scm_procedure_to_pointer)[FFI_CLOSURES]: New
functions.
* libguile/foreign.h (scm_procedure_to_pointer): New declaration.
* module/system/foreign.scm: Export `procedure->pointer' when available.
* test-suite/standalone/test-ffi (f-callback-1, f-callback-2): New
procedures and related tests.
* test-suite/standalone/test-ffi-lib.c (test_ffi_callback_1,
test_ffi_callback_2): New functions.
* test-suite/tests/foreign.test ("procedure->pointer"): New test prefix.
* doc/ref/api-foreign.texi (Dynamic FFI): Document `procedure->pointer'.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-foreign.texi | 68 ++++++++++++++++-
libguile/foreign.c | 140 +++++++++++++++++++++++++++------
libguile/foreign.h | 2 +
libguile/vports.c | 6 +-
module/system/foreign.scm | 3 +
test-suite/standalone/test-ffi | 65 +++++++++++++++-
test-suite/standalone/test-ffi-lib.c | 14 ++++
test-suite/tests/foreign.test | 56 ++++++++++++++
test-suite/tests/r6rs-ports.test | 51 +++++++-----
9 files changed, 354 insertions(+), 51 deletions(-)
diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index bcb8798..88408ad 100644
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@@ -803,8 +803,72 @@ by the foreign pointer is mutated in place.
@end example
As you can see, this interface to foreign functions is at a very low,
-somewhat dangerous level. A contribution to Guile in the form of a
-high-level FFI would be most welcome.
+somewhat dangerous address@hidden contribution to Guile in the form of
+a high-level FFI would be most welcome.}.
+
address@hidden callbacks
+The FFI can also work in the opposite direction: making Scheme
+procedures callable from C. This makes it possible to use Scheme
+procedures as ``callbacks'' expected by C function.
+
address@hidden {Scheme Procedure} procedure->pointer return-type proc arg-types
address@hidden {C Function} scm_procedure_to_pointer (return_type, proc,
arg_types)
+Return a pointer to a C function of type @var{return-type}
+taking arguments of types @var{arg-types} (a list) and
+behaving as a proxy to procedure @var{proc}. Thus
address@hidden's arity, supported argument types, and return
+type should match @var{return-type} and @var{arg-types}.
address@hidden deffn
+
+As an example, here's how the C library's @code{qsort} array sorting
+function can be made accessible to Scheme (@pxref{Array Sort Function,
address@hidden,, libc, The GNU C Library Reference Manual}):
+
address@hidden
+(define qsort!
+ (let ((qsort (make-foreign-function void
+ (dynamic-func "qsort"
+ (dynamic-link))
+ (list '* size_t size_t '*))))
+ (lambda (bv compare)
+ ;; Sort bytevector BV in-place according to comparison
+ ;; procedure COMPARE.
+ (let ((ptr (procedure->pointer int
+ (lambda (x y)
+ ;; X and Y are pointers so,
+ ;; for convenience, dereference
+ ;; them before calling COMPARE.
+ (compare (dereference-uint8* x)
+ (dereference-uint8* y)))
+ (list '* '*))))
+ (qsort (bytevector->pointer bv)
+ (bytevector-length bv) 1 ;; we're sorting bytes
+ ptr)))))
+
+(define (dereference-uint8* ptr)
+ ;; Helper function: dereference the byte pointed to by PTR.
+ (let ((b (pointer->bytevector ptr 1)))
+ (bytevector-u8-ref b 0)))
+
+(define bv
+ ;; An unsorted array of bytes.
+ (u8-list->bytevector '(7 1 127 3 5 4 77 2 9 0)))
+
+;; Sort BV.
+(qsort! bv (lambda (x y) (- x y)))
+
+;; Let's see what the sorted array looks like:
+(bytevector->u8-list bv)
address@hidden (0 1 2 3 4 5 7 9 77 127)
address@hidden example
+
+And address@hidden
+
+Note that @code{procedure->pointer} is not supported (and not defined)
+on a few exotic architectures. Thus, user code may need to check
address@hidden(defined? 'procedure->pointer)}. Nevertheless, it is available on
+many architectures, including (as of libffi 3.0.9) x86, ia64, SPARC,
+PowerPC, ARM, and MIPS, to name a few.
@c Local Variables:
@c TeX-master: "guile.texi"
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 33af172..c36972b 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -563,19 +563,14 @@ fill_ffi_type (SCM type, ffi_type *ftype, ffi_type
***type_ptrs,
ftype->elements[i] = NULL;
}
}
-
-SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0,
- (SCM return_type, SCM func_ptr, SCM arg_types),
- "Make a foreign function.\n\n"
- "Given the foreign void pointer @var{func_ptr}, its argument and\n"
- "return types @var{arg_types} and @var{return_type}, return a\n"
- "procedure that will pass arguments to the foreign function\n"
- "and return appropriate values.\n\n"
- "@var{arg_types} should be a list of foreign types.\n"
- "@code{return_type} should be a foreign type.")
-#define FUNC_NAME s_scm_make_foreign_function
+
+/* Return a "cif" (call interface) for the given RETURN_TYPE and
+ ARG_TYPES. */
+static ffi_cif *
+make_cif (SCM return_type, SCM arg_types, const char *caller)
+#define FUNC_NAME caller
{
- SCM walk, scm_cif;
+ SCM walk;
long i, nargs, n_structs, n_struct_elts;
size_t cif_len;
char *mem;
@@ -583,8 +578,6 @@ SCM_DEFINE (scm_make_foreign_function,
"make-foreign-function", 3, 0, 0,
ffi_type **type_ptrs;
ffi_type *types;
- SCM_VALIDATE_POINTER (2, func_ptr);
-
nargs = scm_ilength (arg_types);
SCM_ASSERT (nargs >= 0, arg_types, 3, FUNC_NAME);
/* fixme: assert nargs < 1<<32 */
@@ -598,32 +591,31 @@ SCM_DEFINE (scm_make_foreign_function,
"make-foreign-function", 3, 0, 0,
for (walk = arg_types; scm_is_pair (walk); walk = scm_cdr (walk))
if (!parse_ffi_type (scm_car (walk), 0, &n_structs, &n_struct_elts))
scm_wrong_type_arg (FUNC_NAME, 3, scm_car (walk));
-
+
/* the memory: with space for the cif itself */
cif_len = sizeof (ffi_cif);
/* then ffi_type pointers: one for each arg, one for each struct
element, and one for each struct (for null-termination) */
cif_len = (ROUND_UP (cif_len, alignof(void*))
- + (nargs + n_structs + n_struct_elts)*sizeof(void*));
-
+ + (nargs + n_structs + n_struct_elts)*sizeof(void*));
+
/* then the ffi_type structs themselves, one per arg and struct element, and
one for the return val */
cif_len = (ROUND_UP (cif_len, alignof(ffi_type))
- + (nargs + n_struct_elts + 1)*sizeof(ffi_type));
+ + (nargs + n_struct_elts + 1)*sizeof(ffi_type));
mem = scm_gc_malloc_pointerless (cif_len, "foreign");
- scm_cif = scm_from_pointer (mem, NULL);
cif = (ffi_cif *) mem;
/* reuse cif_len to walk through the mem */
cif_len = ROUND_UP (sizeof (ffi_cif), alignof(void*));
type_ptrs = (ffi_type**)(mem + cif_len);
cif_len = ROUND_UP (cif_len
- + (nargs + n_structs + n_struct_elts)*sizeof(void*),
- alignof(ffi_type));
+ + (nargs + n_structs + n_struct_elts)*sizeof(void*),
+ alignof(ffi_type));
types = (ffi_type*)(mem + cif_len);
-
+
/* whew. now knit the pointers together. */
cif->rtype = types++;
fill_ffi_type (return_type, cif->rtype, &type_ptrs, &types);
@@ -640,12 +632,33 @@ SCM_DEFINE (scm_make_foreign_function,
"make-foreign-function", 3, 0, 0,
cif->nargs = nargs;
cif->bytes = 0;
cif->flags = 0;
-
+
if (FFI_OK != ffi_prep_cif (cif, FFI_DEFAULT_ABI, cif->nargs, cif->rtype,
- cif->arg_types))
- scm_misc_error (FUNC_NAME, "ffi_prep_cif failed", SCM_EOL);
+ cif->arg_types))
+ SCM_MISC_ERROR ("ffi_prep_cif failed", SCM_EOL);
+
+ return cif;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0,
+ (SCM return_type, SCM func_ptr, SCM arg_types),
+ "Make a foreign function.\n\n"
+ "Given the foreign void pointer @var{func_ptr}, its argument and\n"
+ "return types @var{arg_types} and @var{return_type}, return a\n"
+ "procedure that will pass arguments to the foreign function\n"
+ "and return appropriate values.\n\n"
+ "@var{arg_types} should be a list of foreign types.\n"
+ "@code{return_type} should be a foreign type.")
+#define FUNC_NAME s_scm_make_foreign_function
+{
+ ffi_cif *cif;
+
+ SCM_VALIDATE_POINTER (2, func_ptr);
- return cif_to_procedure (scm_cif, func_ptr);
+ cif = make_cif (return_type, arg_types, FUNC_NAME);
+
+ return cif_to_procedure (scm_from_pointer (cif, NULL), func_ptr);
}
#undef FUNC_NAME
@@ -932,6 +945,81 @@ scm_i_foreign_call (SCM foreign, const SCM *argv)
}
+/* Function pointers aka. "callbacks" or "closures". */
+
+#ifdef FFI_CLOSURES
+
+/* Trampoline to invoke a libffi closure that wraps a Scheme
+ procedure. */
+static void
+invoke_closure (ffi_cif *cif, void *ret, void **args, void *data)
+{
+ size_t i;
+ SCM proc, *argv, result;
+
+ proc = PTR2SCM (data);
+
+ argv = alloca (cif->nargs * sizeof (*argv));
+
+ /* Pack ARGS to SCM values, setting ARGV pointers. */
+ for (i = 0; i < cif->nargs; i++)
+ argv[i] = pack (cif->arg_types[i], args[i]);
+
+ result = scm_call_n (proc, argv, cif->nargs);
+
+ unpack (cif->rtype, ret, result);
+}
+
+SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,
+ (SCM return_type, SCM proc, SCM arg_types),
+ "Return a pointer to a C function of type @var{return-type}\n"
+ "taking arguments of types @var{arg-types} (a list) and\n"
+ "behaving as a proxy to procedure @var{proc}. Thus\n"
+ "@var{proc}'s arity, supported argument types, and return\n"
+ "type should match @var{return-type} and @var{arg-types}.\n")
+#define FUNC_NAME s_scm_procedure_to_pointer
+{
+ SCM pointer;
+ ffi_cif *cif;
+ ffi_status err;
+ void *closure, *executable;
+
+ cif = make_cif (return_type, arg_types, FUNC_NAME);
+
+ closure = ffi_closure_alloc (sizeof (ffi_closure), &executable);
+ err = ffi_prep_closure_loc ((ffi_closure *) closure, cif,
+ invoke_closure, SCM2PTR (proc),
+ executable);
+ if (err != FFI_OK)
+ {
+ ffi_closure_free (closure);
+ SCM_MISC_ERROR ("`ffi_prep_closure_loc' failed", SCM_EOL);
+ }
+
+ if (closure == executable)
+ pointer = scm_from_pointer (executable, ffi_closure_free);
+ else
+ {
+ /* CLOSURE needs to be freed eventually. However, since
+ `GC_all_interior_pointers' is disabled, we can't just register
+ a finalizer for CLOSURE. Instead, we create a pointer object
+ for CLOSURE, with a finalizer, and register it as a weak
+ reference of POINTER. */
+ SCM friend;
+
+ pointer = scm_from_pointer (executable, NULL);
+ friend = scm_from_pointer (closure, ffi_closure_free);
+
+ register_weak_reference (pointer, friend);
+ }
+
+ return pointer;
+}
+#undef FUNC_NAME
+
+#endif /* FFI_CLOSURES */
+
+
static void
scm_init_foreign (void)
diff --git a/libguile/foreign.h b/libguile/foreign.h
index f5fac51..1c57621 100644
--- a/libguile/foreign.h
+++ b/libguile/foreign.h
@@ -95,6 +95,8 @@ SCM_INTERNAL SCM scm_pointer_to_string (SCM pointer);
SCM_API SCM scm_make_foreign_function (SCM return_type, SCM func_ptr,
SCM arg_types);
+SCM_API SCM scm_procedure_to_pointer (SCM return_type, SCM func_ptr,
+ SCM arg_types);
SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, const SCM *argv);
diff --git a/libguile/vports.c b/libguile/vports.c
index 4fab2df..5178d79 100644
--- a/libguile/vports.c
+++ b/libguile/vports.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2006, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2006, 2009, 2010
Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -78,6 +78,10 @@ sf_write (SCM port, const void *data, size_t size)
{
SCM p = SCM_PACK (SCM_STREAM (port));
+ /* DATA is assumed to be a locale-encoded C string, which makes it
+ hard to reliably pass binary data to a soft port. It can be
+ achieved by choosing a Latin-1 locale, though, but the recommended
+ approach is to use an R6RS "custom binary output port" instead. */
scm_call_1 (SCM_SIMPLE_VECTOR_REF (p, 1),
scm_from_locale_stringn ((char *) data, size));
}
diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index e9a4a7c..0ca7fbf 100644
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -43,6 +43,7 @@
pointer->string
make-foreign-function
+ ;; procedure->pointer (see below)
make-c-struct parse-c-struct))
(load-extension (string-append "libguile-" (effective-version))
@@ -57,6 +58,8 @@
"Return true if POINTER is the null pointer."
(= (pointer-address pointer) 0))
+(if (defined? 'procedure->pointer)
+ (export procedure->pointer))
;;;
diff --git a/test-suite/standalone/test-ffi b/test-suite/standalone/test-ffi
index 5918a73..960c9d1 100755
--- a/test-suite/standalone/test-ffi
+++ b/test-suite/standalone/test-ffi
@@ -1,9 +1,28 @@
#!/bin/sh
exec guile -q -s "$0" "$@"
!#
+;;; test-ffi --- Foreign function interface. -*- Scheme -*-
+;;;
+;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(use-modules (system foreign)
- (rnrs bytevectors))
+ (rnrs bytevectors)
+ (srfi srfi-1)
+ (srfi srfi-26))
(define lib
(dynamic-link (string-append (getenv "builddir") "/libtest-ffi")))
@@ -175,6 +194,50 @@ exec guile -q -s "$0" "$@"
'(0 1 2 3 4 5 6 7 0 0 0 0 0 0 0 0))
(error "unexpected dest")))
+;;
+;; Function pointers
+;;
+
+(define f-callback-1
+ (make-foreign-function int (dynamic-func "test_ffi_callback_1" lib)
+ (list '* int)))
+
+(if (defined? 'procedure->pointer)
+ (let* ((calls 0)
+ (ptr (procedure->pointer int
+ (lambda (x)
+ (set! calls (+ 1 calls))
+ (* x 3))
+ (list int)))
+ (input (iota 123)))
+ (define (expected-result x)
+ (+ 7 (* x 3)))
+
+ (let ((result (map (cut f-callback-1 ptr <>) input)))
+ (and (or (= calls (length input))
+ (error "incorrect number of callback calls" calls))
+ (or (equal? (map expected-result input) result)
+ (error "incorrect result" result))))))
+
+(define f-callback-2
+ (make-foreign-function double (dynamic-func "test_ffi_callback_2" lib)
+ (list '* float int double)))
+
+(if (defined? 'procedure->pointer)
+ (let* ((proc (lambda (x y z)
+ (* (+ x (exact->inexact y)) z)))
+ (ptr (procedure->pointer double proc
+ (list float int double)))
+ (arg1 (map (cut * <> 1.25) (iota 123 500)))
+ (arg2 (iota 123))
+ (arg3 (map (cut / <> 2.0) (iota 123 0 -10))))
+ (define result
+ (map (cut f-callback-2 ptr <> <> <>)
+ arg1 arg2 arg3))
+
+ (or (equal? result (map proc arg1 arg2 arg3))
+ (error "incorrect result" result))))
+
;;;
;;; Global symbols.
diff --git a/test-suite/standalone/test-ffi-lib.c
b/test-suite/standalone/test-ffi-lib.c
index 8dec3d3..364e6a6 100644
--- a/test-suite/standalone/test-ffi-lib.c
+++ b/test-suite/standalone/test-ffi-lib.c
@@ -213,3 +213,17 @@ void* test_ffi_memcpy (void *dest, void *src, scm_t_int32
n)
{
return memcpy (dest, src, n);
}
+
+int test_ffi_callback_1 (int (*f) (int), int x);
+int test_ffi_callback_1 (int (*f) (int), int x)
+{
+ return f (x) + 7;
+}
+
+double test_ffi_callback_2 (double (*f) (float, int, double),
+ float x, int y, double z);
+double test_ffi_callback_2 (double (*f) (float, int, double),
+ float x, int y, double z)
+{
+ return f (x, y, z);
+}
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index d93565e..fd42677 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -91,6 +91,62 @@
(string=? s (pointer->string (string->pointer s)))))))
+(with-test-prefix "procedure->pointer"
+
+ (define qsort
+ ;; Bindings for libc's `qsort' function.
+ (make-foreign-function void
+ (dynamic-func "qsort" (dynamic-link))
+ (list '* size_t size_t '*)))
+
+ (define (dereference-pointer-to-byte ptr)
+ (let ((b (pointer->bytevector ptr 1)))
+ (bytevector-u8-ref b 0)))
+
+ (define input
+ '(7 1 127 3 5 4 77 2 9 0))
+
+ (pass-if "qsort"
+ (if (defined? 'procedure->pointer)
+ (let* ((called? #f)
+ (cmp (lambda (x y)
+ (set! called? #t)
+ (- (dereference-pointer-to-byte x)
+ (dereference-pointer-to-byte y))))
+ (ptr (procedure->pointer int cmp (list '* '*)))
+ (bv (u8-list->bytevector input)))
+ (qsort (bytevector->pointer bv) (bytevector-length bv) 1
+ (procedure->pointer int cmp (list '* '*)))
+ (and called?
+ (equal? (bytevector->u8-list bv)
+ (sort input <))))
+ (throw 'unresolved)))
+
+ (pass-if-exception "qsort, wrong return type"
+ exception:wrong-type-arg
+
+ (if (defined? 'procedure->pointer)
+ (let* ((cmp (lambda (x y) #f)) ; wrong return type
+ (ptr (procedure->pointer int cmp (list '* '*)))
+ (bv (u8-list->bytevector input)))
+ (qsort (bytevector->pointer bv) (bytevector-length bv) 1
+ (procedure->pointer int cmp (list '* '*)))
+ #f)
+ (throw 'unresolved)))
+
+ (pass-if-exception "qsort, wrong arity"
+ exception:wrong-num-args
+
+ (if (defined? 'procedure->pointer)
+ (let* ((cmp (lambda (x y z) #f)) ; wrong arity
+ (ptr (procedure->pointer int cmp (list '* '*)))
+ (bv (u8-list->bytevector input)))
+ (qsort (bytevector->pointer bv) (bytevector-length bv) 1
+ (procedure->pointer int cmp (list '* '*)))
+ #f)
+ (throw 'unresolved))))
+
+
(with-test-prefix "structs"
(pass-if "parse-c-struct"
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index dae6295..0b627da 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -185,32 +185,41 @@
(put-u8 port 77)
(equal? (get-u8 port) 77)))
+ ;; Note: The `put-bytevector' tests below require a Latin-1 locale so
+ ;; that the `scm_from_locale_stringn' call in `sf_write' will let all
+ ;; the bytes through, unmodified. This is hacky, but we can't use
+ ;; "custom binary output ports" here because they're only tested
+ ;; later.
+
(pass-if "put-bytevector [2 args]"
- (let ((port (make-soft-output-port))
- (bv (make-bytevector 256)))
- (put-bytevector port bv)
- (equal? (bytevector->u8-list bv)
- (bytevector->u8-list
- (get-bytevector-n port (bytevector-length bv))))))
+ (with-latin1-locale
+ (let ((port (make-soft-output-port))
+ (bv (make-bytevector 256)))
+ (put-bytevector port bv)
+ (equal? (bytevector->u8-list bv)
+ (bytevector->u8-list
+ (get-bytevector-n port (bytevector-length bv)))))))
(pass-if "put-bytevector [3 args]"
- (let ((port (make-soft-output-port))
- (bv (make-bytevector 256))
- (start 10))
- (put-bytevector port bv start)
- (equal? (drop (bytevector->u8-list bv) start)
- (bytevector->u8-list
- (get-bytevector-n port (- (bytevector-length bv) start))))))
+ (with-latin1-locale
+ (let ((port (make-soft-output-port))
+ (bv (make-bytevector 256))
+ (start 10))
+ (put-bytevector port bv start)
+ (equal? (drop (bytevector->u8-list bv) start)
+ (bytevector->u8-list
+ (get-bytevector-n port (- (bytevector-length bv) start)))))))
(pass-if "put-bytevector [4 args]"
- (let ((port (make-soft-output-port))
- (bv (make-bytevector 256))
- (start 10)
- (count 77))
- (put-bytevector port bv start count)
- (equal? (take (drop (bytevector->u8-list bv) start) count)
- (bytevector->u8-list
- (get-bytevector-n port count)))))
+ (with-latin1-locale
+ (let ((port (make-soft-output-port))
+ (bv (make-bytevector 256))
+ (start 10)
+ (count 77))
+ (put-bytevector port bv start count)
+ (equal? (take (drop (bytevector->u8-list bv) start) count)
+ (bytevector->u8-list
+ (get-bytevector-n port count))))))
(pass-if-exception "put-bytevector with closed port"
exception:wrong-type-arg
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-11-311-gbf08e10,
Ludovic Courtès <=