From: ludo@gnu.org (Ludovic Courtès)
To: guile-devel@gnu.org
Subject: Re: Merging Guile-R6RS-Libs in `master'
Date: Thu, 28 May 2009 00:27:38 +0200 [thread overview]
Message-ID: <87ws829o6d.fsf@gnu.org> (raw)
In-Reply-To: 877i1d3yi2.fsf@gnu.org
[-- Attachment #1.1: Type: text/plain, Size: 610 bytes --]
Hello!
Attached is my initial patch to integrate Guile-R6RS-Libs (bytevectors
and I/O ports). I'll commit it shortly to `master' if nobody objects.
It adds a dependency on GNU libunistring (by Bruno Haible). We could
avoid it by importing all the Gnulib modules libunistring is based on,
but I think it's better to not ship and link a copy of such a large body
of code. Mike's work needs it as well.
Then will come:
* documentation, probably with bytevectors in `api-data.texi' and
ports in `api-io.texi';
* reader extension;
* generalized vector extension for bytevectors.
Thanks,
Ludo'.
[-- Attachment #1.2: The patch --]
[-- Type: text/x-patch, Size: 164725 bytes --]
From 49e92cb7e629792fd670ac5b6a23cdba9641658d Mon Sep 17 00:00:00 2001
From: =?utf-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 27 May 2009 18:18:07 +0200
Subject: [PATCH] Import R6RS bytevectors and I/O ports from Guile-R6RS-Libs 0.2.
* README: Document dependency on GNU libunistring.
* benchmark-suite/Makefile.am (SCM_BENCHMARKS): Add
`benchmark/bytevectors.bm'.
* configure.in: Make sure we have libunistring; update $LIBS.
* libguile.h: Include "bytevectors.h" and "r6rs-ports.h".
* libguile/Makefile.am (libguile_la_SOURCES): Add `bytevectors.c' and
`r6rs-ports.c'
(DOT_X_FILES): Add `bytevectors.x' and `r6rs-ports.x'.
(DOT_DOC_FILES): Add `bytevectors.doc' and `r6rs-ports.doc'.
(noinst_HEADERS): Add `ieee-754.h'.
(modinclude_HEADERS): Add `bytevectors.h' and `r6rs-ports.h'
* libguile/validate.h (SCM_VALIDATE_BYTEVECTOR): New macro.
* module/Makefile.am (SOURCES): Add $(RNRS_SOURCES).
(RNRS_SOURCES): New variable.
* test-suite/Makefile.am (SCM_TESTS): Add `bytevectors.test' and
`r6rs-ports.test'.
---
README | 6 +
benchmark-suite/Makefile.am | 1 +
benchmark-suite/benchmarks/bytevectors.bm | 99 ++
configure.in | 7 +
libguile.h | 4 +-
libguile/Makefile.am | 26 +-
libguile/bytevectors.c | 1978 +++++++++++++++++++++++++++++
libguile/bytevectors.h | 133 ++
libguile/ieee-754.h | 90 ++
libguile/r6rs-ports.c | 1118 ++++++++++++++++
libguile/r6rs-ports.h | 43 +
libguile/validate.h | 5 +-
module/Makefile.am | 7 +-
module/rnrs/bytevector.scm | 84 ++
module/rnrs/io/ports.scm | 111 ++
test-suite/Makefile.am | 2 +
test-suite/tests/bytevectors.test | 531 ++++++++
test-suite/tests/r6rs-ports.test | 455 +++++++
18 files changed, 4688 insertions(+), 12 deletions(-)
create mode 100644 benchmark-suite/benchmarks/bytevectors.bm
create mode 100644 libguile/bytevectors.c
create mode 100644 libguile/bytevectors.h
create mode 100644 libguile/ieee-754.h
create mode 100644 libguile/r6rs-ports.c
create mode 100644 libguile/r6rs-ports.h
create mode 100644 module/rnrs/bytevector.scm
create mode 100644 module/rnrs/io/ports.scm
create mode 100644 test-suite/tests/bytevectors.test
create mode 100644 test-suite/tests/r6rs-ports.test
diff --git a/README b/README
index 9993fcf..4950229 100644
--- a/README
+++ b/README
@@ -61,6 +61,12 @@ Guile requires the following external packages:
libltdl is used for loading extensions at run-time. It is
available from http://www.gnu.org/software/libtool/
+ - GNU libunistring
+
+ libunistring is used for Unicode string operations, such as the
+ `utf*->string' procedures. It is available from
+ http://www.gnu.org/software/libunistring/ .
+
Special Instructions For Some Systems =====================================
diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am
index e65e8bc..dcadd58 100644
--- a/benchmark-suite/Makefile.am
+++ b/benchmark-suite/Makefile.am
@@ -1,4 +1,5 @@
SCM_BENCHMARKS = benchmarks/0-reference.bm \
+ benchmarks/bytevectors.bm \
benchmarks/continuations.bm \
benchmarks/if.bm \
benchmarks/logand.bm \
diff --git a/benchmark-suite/benchmarks/bytevectors.bm b/benchmark-suite/benchmarks/bytevectors.bm
new file mode 100644
index 0000000..9547a71
--- /dev/null
+++ b/benchmark-suite/benchmarks/bytevectors.bm
@@ -0,0 +1,99 @@
+;;; -*- mode: scheme; coding: latin-1; -*-
+;;; R6RS Byte Vectors.
+;;;
+;;; Copyright 2009 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (benchmarks bytevector)
+ :use-module (rnrs bytevector)
+ :use-module (srfi srfi-4)
+ :use-module (benchmark-suite lib))
+
+(define bv (make-bytevector 16384))
+
+(define %native-endianness
+ (native-endianness))
+
+(define %foreign-endianness
+ (if (eq? (native-endianness) (endianness little))
+ (endianness big)
+ (endianness little)))
+
+(define u8v (make-u8vector 16384))
+(define u16v (make-u16vector 8192))
+(define u32v (make-u32vector 4196))
+(define u64v (make-u64vector 2048))
+
+\f
+(with-benchmark-prefix "ref/set!"
+
+ (benchmark "bytevector-u8-ref" 1000000
+ (bytevector-u8-ref bv 0))
+
+ (benchmark "bytevector-u16-ref (foreign)" 1000000
+ (bytevector-u16-ref bv 0 %foreign-endianness))
+
+ (benchmark "bytevector-u16-ref (native)" 1000000
+ (bytevector-u16-ref bv 0 %native-endianness))
+
+ (benchmark "bytevector-u16-native-ref" 1000000
+ (bytevector-u16-native-ref bv 0))
+
+ (benchmark "bytevector-u32-ref (foreign)" 1000000
+ (bytevector-u32-ref bv 0 %foreign-endianness))
+
+ (benchmark "bytevector-u32-ref (native)" 1000000
+ (bytevector-u32-ref bv 0 %native-endianness))
+
+ (benchmark "bytevector-u32-native-ref" 1000000
+ (bytevector-u32-native-ref bv 0))
+
+ (benchmark "bytevector-u64-ref (foreign)" 1000000
+ (bytevector-u64-ref bv 0 %foreign-endianness))
+
+ (benchmark "bytevector-u64-ref (native)" 1000000
+ (bytevector-u64-ref bv 0 %native-endianness))
+
+ (benchmark "bytevector-u64-native-ref" 1000000
+ (bytevector-u16-native-ref bv 0)))
+
+\f
+(with-benchmark-prefix "lists"
+
+ (benchmark "bytevector->u8-list" 2000
+ (bytevector->u8-list bv))
+
+ (benchmark "bytevector->uint-list 16-bit" 2000
+ (bytevector->uint-list bv (native-endianness) 2))
+
+ (benchmark "bytevector->uint-list 64-bit" 2000
+ (bytevector->uint-list bv (native-endianness) 8)))
+
+\f
+(with-benchmark-prefix "SRFI-4" ;; for comparison
+
+ (benchmark "u8vector-ref" 1000000
+ (u8vector-ref u8v 0))
+
+ (benchmark "u16vector-ref" 1000000
+ (u16vector-ref u16v 0))
+
+ (benchmark "u32vector-ref" 1000000
+ (u32vector-ref u32v 0))
+
+ (benchmark "u64vector-ref" 1000000
+ (u64vector-ref u64v 0)))
diff --git a/configure.in b/configure.in
index 07c4766..6568e52 100644
--- a/configure.in
+++ b/configure.in
@@ -836,6 +836,13 @@ AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <gmp.h>]],
[],
[AC_MSG_ERROR([At least GNU MP 4.1 is required, see README])])
+dnl GNU libunistring tests.
+if test "x$LTLIBUNISTRING" != "x"; then
+ LIBS="$LTLIBUNISTRING $LIBS"
+else
+ AC_MSG_ERROR([GNU libunistring is required, please install it.])
+fi
+
dnl i18n tests
#AC_CHECK_HEADERS([libintl.h])
#AC_CHECK_FUNCS(gettext)
diff --git a/libguile.h b/libguile.h
index 40122df..6a6d232 100644
--- a/libguile.h
+++ b/libguile.h
@@ -1,7 +1,7 @@
#ifndef SCM_LIBGUILE_H
#define SCM_LIBGUILE_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009 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
@@ -32,6 +32,7 @@ extern "C" {
#include "libguile/arbiters.h"
#include "libguile/async.h"
#include "libguile/boolean.h"
+#include "libguile/bytevectors.h"
#include "libguile/chars.h"
#include "libguile/continuations.h"
#include "libguile/dynl.h"
@@ -75,6 +76,7 @@ extern "C" {
#include "libguile/procprop.h"
#include "libguile/properties.h"
#include "libguile/procs.h"
+#include "libguile/r6rs-ports.h"
#include "libguile/ramap.h"
#include "libguile/random.h"
#include "libguile/read.h"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 63f2ef2..fcf197a 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -106,7 +106,8 @@ guile_LDFLAGS = $(GUILE_CFLAGS)
libguile_la_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS)
libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
- chars.c continuations.c convert.c debug.c deprecation.c \
+ bytevectors.c chars.c continuations.c \
+ convert.c debug.c deprecation.c \
deprecated.c discouraged.c dynwind.c eq.c error.c \
eval.c evalext.c extensions.c feature.c fluids.c fports.c \
futures.c gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c \
@@ -115,7 +116,8 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
guardians.c hash.c hashtab.c hooks.c init.c inline.c \
ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \
modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \
- print.c procprop.c procs.c properties.c random.c rdelim.c read.c \
+ print.c procprop.c procs.c properties.c \
+ r6rs-ports.c random.c rdelim.c read.c \
root.c rw.c scmsigs.c script.c simpos.c smob.c sort.c srcprop.c \
stackchk.c stacks.c stime.c strings.c srfi-4.c srfi-13.c srfi-14.c \
strorder.c strports.c struct.c symbols.c threads.c null-threads.c \
@@ -134,7 +136,8 @@ libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \
-module -L$(builddir) -lguile \
-version-info @LIBGUILE_I18N_INTERFACE@
-DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \
+DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x \
+ bytevectors.x chars.x \
continuations.x debug.x deprecation.x deprecated.x discouraged.x \
dynl.x dynwind.x eq.x error.x eval.x evalext.x \
extensions.x feature.x fluids.x fports.x futures.x gc.x gc-mark.x \
@@ -143,7 +146,8 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \
hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \
list.x load.x macros.x mallocs.x modules.x numbers.x objects.x \
objprop.x options.x pairs.x ports.x print.x procprop.x procs.x \
- properties.x random.x rdelim.x read.x root.x rw.x scmsigs.x \
+ properties.x r6rs-ports.x random.x rdelim.x \
+ read.x root.x rw.x scmsigs.x \
script.x simpos.x smob.x sort.x srcprop.x stackchk.x stacks.x \
stime.x strings.x srfi-4.x srfi-13.x srfi-14.x strorder.x \
strports.x struct.x symbols.x threads.x throw.x values.x \
@@ -155,7 +159,8 @@ DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x
EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
- boolean.doc chars.doc continuations.doc debug.doc deprecation.doc \
+ boolean.doc bytevectors.doc chars.doc \
+ continuations.doc debug.doc deprecation.doc \
deprecated.doc discouraged.doc dynl.doc dynwind.doc \
eq.doc error.doc eval.doc evalext.doc \
extensions.doc feature.doc fluids.doc fports.doc futures.doc \
@@ -165,7 +170,8 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc \
list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc \
objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc \
- procprop.doc procs.doc properties.doc random.doc rdelim.doc \
+ procprop.doc procs.doc properties.doc r6rs-ports.doc \
+ random.doc rdelim.doc \
read.doc root.doc rw.doc scmsigs.doc script.doc simpos.doc \
smob.doc sort.doc srcprop.doc stackchk.doc stacks.doc stime.doc \
strings.doc srfi-4.doc srfi-13.doc srfi-14.doc strorder.doc \
@@ -204,7 +210,7 @@ install-exec-hook:
## working.
noinst_HEADERS = convert.i.c \
conv-integer.i.c conv-uinteger.i.c \
- eval.i.c \
+ eval.i.c ieee-754.h \
srfi-4.i.c \
quicksort.i.c \
win32-uname.h win32-dirent.h win32-socket.h \
@@ -223,7 +229,8 @@ pkginclude_HEADERS =
# These are headers visible as <libguile/mumble.h>.
modincludedir = $(includedir)/libguile
modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \
- boolean.h chars.h continuations.h convert.h debug.h debug-malloc.h \
+ boolean.h bytevectors.h chars.h continuations.h convert.h \
+ debug.h debug-malloc.h \
deprecation.h deprecated.h discouraged.h dynl.h dynwind.h \
eq.h error.h eval.h evalext.h extensions.h \
feature.h filesys.h fluids.h fports.h futures.h gc.h \
@@ -232,7 +239,8 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \
hashtab.h hooks.h i18n.h init.h inline.h ioext.h iselect.h \
keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \
net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h \
- posix.h regex-posix.h print.h procprop.h procs.h properties.h \
+ posix.h r6rs-ports.h regex-posix.h print.h \
+ procprop.h procs.h properties.h \
random.h ramap.h rdelim.h read.h root.h rw.h scmsigs.h validate.h \
script.h simpos.h smob.h snarf.h socket.h sort.h srcprop.h \
stackchk.h stacks.h stime.h strings.h srfi-4.h srfi-13.h srfi-14.h \
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
new file mode 100644
index 0000000..4c3a353
--- /dev/null
+++ b/libguile/bytevectors.c
@@ -0,0 +1,1978 @@
+/* Copyright (C) 2009 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 2.1 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
+ */
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <alloca.h>
+
+#include <gmp.h>
+
+#include "libguile/_scm.h"
+#include "libguile/bytevectors.h"
+#include "libguile/strings.h"
+#include "libguile/validate.h"
+#include "libguile/ieee-754.h"
+
+#include <byteswap.h>
+#include <striconveh.h>
+#include <uniconv.h>
+
+#ifdef HAVE_LIMITS_H
+# include <limits.h>
+#else
+/* Assuming 32-bit longs. */
+# define ULONG_MAX 4294967295UL
+#endif
+
+#include <string.h>
+
+
+\f
+/* Utilities. */
+
+/* Convenience macros. These are used by the various templates (macros) that
+ are parameterized by integer signedness. */
+#define INT8_T_signed scm_t_int8
+#define INT8_T_unsigned scm_t_uint8
+#define INT16_T_signed scm_t_int16
+#define INT16_T_unsigned scm_t_uint16
+#define INT32_T_signed scm_t_int32
+#define INT32_T_unsigned scm_t_uint32
+#define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L))
+#define is_unsigned_int8(_x) ((_x) <= 255UL)
+#define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
+#define is_unsigned_int16(_x) ((_x) <= 65535UL)
+#define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L))
+#define is_unsigned_int32(_x) ((_x) <= 4294967295UL)
+#define SIGNEDNESS_signed 1
+#define SIGNEDNESS_unsigned 0
+
+#define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign
+#define INT_SWAP(_size) bswap_ ## _size
+#define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
+#define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
+
+
+#define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \
+ unsigned c_len, c_index; \
+ _sign char *c_bv; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, bv); \
+ c_index = scm_to_uint (index); \
+ \
+ c_len = SCM_BYTEVECTOR_LENGTH (bv); \
+ c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \
+ \
+ if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
+ scm_out_of_range (FUNC_NAME, index);
+
+/* Template for fixed-size integer access (only 8, 16 or 32-bit). */
+#define INTEGER_REF(_len, _sign) \
+ SCM result; \
+ \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ { \
+ INT_TYPE (_len, _sign) c_result; \
+ \
+ memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
+ if (!scm_is_eq (endianness, native_endianness)) \
+ c_result = INT_SWAP (_len) (c_result); \
+ \
+ result = SCM_I_MAKINUM (c_result); \
+ } \
+ \
+ return result;
+
+/* Template for fixed-size integer access using the native endianness. */
+#define INTEGER_NATIVE_REF(_len, _sign) \
+ SCM result; \
+ \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ \
+ { \
+ INT_TYPE (_len, _sign) c_result; \
+ \
+ memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
+ result = SCM_I_MAKINUM (c_result); \
+ } \
+ \
+ return result;
+
+/* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
+#define INTEGER_SET(_len, _sign) \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ { \
+ _sign long c_value; \
+ INT_TYPE (_len, _sign) c_value_short; \
+ \
+ if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
+ scm_wrong_type_arg (FUNC_NAME, 3, value); \
+ \
+ c_value = SCM_I_INUM (value); \
+ if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ c_value_short = (INT_TYPE (_len, _sign)) c_value; \
+ if (!scm_is_eq (endianness, native_endianness)) \
+ c_value_short = INT_SWAP (_len) (c_value_short); \
+ \
+ memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
+ } \
+ \
+ return SCM_UNSPECIFIED;
+
+/* Template for fixed-size integer modification using the native
+ endianness. */
+#define INTEGER_NATIVE_SET(_len, _sign) \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ \
+ { \
+ _sign long c_value; \
+ INT_TYPE (_len, _sign) c_value_short; \
+ \
+ if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
+ scm_wrong_type_arg (FUNC_NAME, 3, value); \
+ \
+ c_value = SCM_I_INUM (value); \
+ if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ c_value_short = (INT_TYPE (_len, _sign)) c_value; \
+ \
+ memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
+ } \
+ \
+ return SCM_UNSPECIFIED;
+
+
+\f
+/* Bytevector type. */
+
+SCM_GLOBAL_SMOB (scm_tc16_bytevector, "r6rs-bytevector", 0);
+
+#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
+ SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len))
+#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
+ SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf))
+
+/* The empty bytevector. */
+SCM scm_null_bytevector = SCM_UNSPECIFIED;
+
+
+static inline SCM
+make_bytevector_from_buffer (unsigned len, signed char *contents)
+{
+ /* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */
+ SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector, len, contents);
+}
+
+static inline SCM
+make_bytevector (unsigned len)
+{
+ SCM bv;
+
+ if (SCM_UNLIKELY (len == 0))
+ bv = scm_null_bytevector;
+ else
+ {
+ signed char *contents = NULL;
+
+ if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len))
+ contents = (signed char *) scm_gc_malloc (len, SCM_GC_BYTEVECTOR);
+
+ bv = make_bytevector_from_buffer (len, contents);
+ }
+
+ return bv;
+}
+
+/* Return a new bytevector of size LEN octets. */
+SCM
+scm_c_make_bytevector (unsigned len)
+{
+ return (make_bytevector (len));
+}
+
+/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
+ by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
+SCM
+scm_c_take_bytevector (signed char *contents, unsigned len)
+{
+ SCM bv;
+
+ if (SCM_UNLIKELY (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len)))
+ {
+ /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */
+ signed char *c_bv;
+
+ bv = make_bytevector (len);
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+ memcpy (c_bv, contents, len);
+ scm_gc_free (contents, len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ bv = make_bytevector_from_buffer (len, contents);
+
+ return bv;
+}
+
+/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
+ size) and return BV. */
+SCM
+scm_i_shrink_bytevector (SCM bv, unsigned c_new_len)
+{
+ if (!SCM_BYTEVECTOR_INLINE_P (bv))
+ {
+ unsigned c_len;
+ signed char *c_bv, *c_new_bv;
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+
+ SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
+
+ if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len))
+ {
+ /* Copy to the in-line buffer and free the current buffer. */
+ c_new_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+ memcpy (c_new_bv, c_bv, c_new_len);
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ {
+ /* Resize the existing buffer. */
+ c_new_bv = scm_gc_realloc (c_bv, c_len, c_new_len,
+ SCM_GC_BYTEVECTOR);
+ SCM_BYTEVECTOR_SET_CONTENTS (bv, c_new_bv);
+ }
+ }
+
+ return bv;
+}
+
+SCM_SMOB_PRINT (scm_tc16_bytevector, print_bytevector,
+ bv, port, pstate)
+{
+ unsigned c_len, i;
+ unsigned char *c_bv;
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ scm_puts ("#vu8(", port);
+ for (i = 0; i < c_len; i++)
+ {
+ if (i > 0)
+ scm_putc (' ', port);
+
+ scm_uintprint (c_bv[i], 10, port);
+ }
+
+ scm_putc (')', port);
+
+ /* Make GCC think we use it. */
+ scm_remember_upto_here ((SCM) pstate);
+
+ return 1;
+}
+
+SCM_SMOB_FREE (scm_tc16_bytevector, free_bytevector, bv)
+{
+
+ if (!SCM_BYTEVECTOR_INLINE_P (bv))
+ {
+ unsigned c_len;
+ signed char *c_bv;
+
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+
+ return 0;
+}
+
+
+\f
+/* General operations. */
+
+SCM_SYMBOL (scm_sym_big, "big");
+SCM_SYMBOL (scm_sym_little, "little");
+
+SCM scm_endianness_big, scm_endianness_little;
+
+/* Host endianness (a symbol). */
+static SCM native_endianness = SCM_UNSPECIFIED;
+
+/* Byte-swapping. */
+#ifndef bswap_24
+# define bswap_24(_x) \
+ ((((_x) & 0xff0000) >> 16) | \
+ (((_x) & 0x00ff00)) | \
+ (((_x) & 0x0000ff) << 16))
+#endif
+
+
+SCM_DEFINE (scm_native_endianness, "native-endianness", 0, 0, 0,
+ (void),
+ "Return a symbol denoting the machine's native endianness.")
+#define FUNC_NAME s_scm_native_endianness
+{
+ return native_endianness;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_p, "bytevector?", 1, 0, 0,
+ (SCM obj),
+ "Return true if @var{obj} is a bytevector.")
+#define FUNC_NAME s_scm_bytevector_p
+{
+ return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_bytevector,
+ obj)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0,
+ (SCM len, SCM fill),
+ "Return a newly allocated bytevector of @var{len} bytes, "
+ "optionally filled with @var{fill}.")
+#define FUNC_NAME s_scm_make_bytevector
+{
+ SCM bv;
+ unsigned c_len;
+ signed char c_fill = '\0';
+
+ SCM_VALIDATE_UINT_COPY (1, len, c_len);
+ if (fill != SCM_UNDEFINED)
+ {
+ int value;
+
+ value = scm_to_int (fill);
+ if (SCM_UNLIKELY ((value < -128) || (value > 255)))
+ scm_out_of_range (FUNC_NAME, fill);
+ c_fill = (signed char) value;
+ }
+
+ bv = make_bytevector (c_len);
+ if (fill != SCM_UNDEFINED)
+ {
+ unsigned i;
+ signed char *contents;
+
+ contents = SCM_BYTEVECTOR_CONTENTS (bv);
+ for (i = 0; i < c_len; i++)
+ contents[i] = c_fill;
+ }
+
+ return bv;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_length, "bytevector-length", 1, 0, 0,
+ (SCM bv),
+ "Return the length (in bytes) of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_length
+{
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ return (scm_from_uint (SCM_BYTEVECTOR_LENGTH (bv)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_eq_p, "bytevector=?", 2, 0, 0,
+ (SCM bv1, SCM bv2),
+ "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
+ "have the same length and contents.")
+#define FUNC_NAME s_scm_bytevector_eq_p
+{
+ SCM result = SCM_BOOL_F;
+ unsigned c_len1, c_len2;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv1);
+ SCM_VALIDATE_BYTEVECTOR (2, bv2);
+
+ c_len1 = SCM_BYTEVECTOR_LENGTH (bv1);
+ c_len2 = SCM_BYTEVECTOR_LENGTH (bv2);
+
+ if (c_len1 == c_len2)
+ {
+ signed char *c_bv1, *c_bv2;
+
+ c_bv1 = SCM_BYTEVECTOR_CONTENTS (bv1);
+ c_bv2 = SCM_BYTEVECTOR_CONTENTS (bv2);
+
+ result = scm_from_bool (!memcmp (c_bv1, c_bv2, c_len1));
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_fill_x, "bytevector-fill!", 2, 0, 0,
+ (SCM bv, SCM fill),
+ "Fill bytevector @var{bv} with @var{fill}, a byte.")
+#define FUNC_NAME s_scm_bytevector_fill_x
+{
+ unsigned c_len, i;
+ signed char *c_bv, c_fill;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+ c_fill = scm_to_int8 (fill);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+
+ for (i = 0; i < c_len; i++)
+ c_bv[i] = c_fill;
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_copy_x, "bytevector-copy!", 5, 0, 0,
+ (SCM source, SCM source_start, SCM target, SCM target_start,
+ SCM len),
+ "Copy @var{len} bytes from @var{source} into @var{target}, "
+ "starting reading from @var{source_start} (a positive index "
+ "within @var{source}) and start writing at "
+ "@var{target_start}.")
+#define FUNC_NAME s_scm_bytevector_copy_x
+{
+ unsigned c_len, c_source_len, c_target_len;
+ unsigned c_source_start, c_target_start;
+ signed char *c_source, *c_target;
+
+ SCM_VALIDATE_BYTEVECTOR (1, source);
+ SCM_VALIDATE_BYTEVECTOR (3, target);
+
+ c_len = scm_to_uint (len);
+ c_source_start = scm_to_uint (source_start);
+ c_target_start = scm_to_uint (target_start);
+
+ c_source = SCM_BYTEVECTOR_CONTENTS (source);
+ c_target = SCM_BYTEVECTOR_CONTENTS (target);
+ c_source_len = SCM_BYTEVECTOR_LENGTH (source);
+ c_target_len = SCM_BYTEVECTOR_LENGTH (target);
+
+ if (SCM_UNLIKELY (c_source_start + c_len > c_source_len))
+ scm_out_of_range (FUNC_NAME, source_start);
+ if (SCM_UNLIKELY (c_target_start + c_len > c_target_len))
+ scm_out_of_range (FUNC_NAME, target_start);
+
+ memcpy (c_target + c_target_start,
+ c_source + c_source_start,
+ c_len);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0,
+ (SCM bv),
+ "Return a newly allocated copy of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_copy
+{
+ SCM copy;
+ unsigned c_len;
+ signed char *c_bv, *c_copy;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+
+ copy = make_bytevector (c_len);
+ c_copy = SCM_BYTEVECTOR_CONTENTS (copy);
+ memcpy (c_copy, c_bv, c_len);
+
+ return copy;
+}
+#undef FUNC_NAME
+
+\f
+/* Operations on bytes and octets. */
+
+SCM_DEFINE (scm_bytevector_u8_ref, "bytevector-u8-ref", 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the octet located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_u8_ref
+{
+ INTEGER_NATIVE_REF (8, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s8_ref, "bytevector-s8-ref", 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the byte located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_s8_ref
+{
+ INTEGER_NATIVE_REF (8, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u8_set_x, "bytevector-u8-set!", 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Return the octet located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_u8_set_x
+{
+ INTEGER_NATIVE_SET (8, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Return the octet located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_u8_set_x
+{
+ INTEGER_NATIVE_SET (8, signed);
+}
+#undef FUNC_NAME
+
+#undef OCTET_ACCESSOR_PROLOGUE
+
+
+SCM_DEFINE (scm_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0,
+ (SCM bv),
+ "Return a newly allocated list of octets containing the "
+ "contents of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_to_u8_list
+{
+ SCM lst, pair;
+ unsigned c_len, i;
+ unsigned char *c_bv;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ lst = scm_make_list (scm_from_uint (c_len), SCM_UNSPECIFIED);
+ for (i = 0, pair = lst;
+ i < c_len;
+ i++, pair = SCM_CDR (pair))
+ {
+ SCM_SETCAR (pair, SCM_I_MAKINUM (c_bv[i]));
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0,
+ (SCM lst),
+ "Turn @var{lst}, a list of octets, into a bytevector.")
+#define FUNC_NAME s_scm_u8_list_to_bytevector
+{
+ SCM bv, item;
+ long c_len, i;
+ unsigned char *c_bv;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);
+
+ bv = make_bytevector (c_len);
+ c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ for (i = 0; i < c_len; lst = SCM_CDR (lst), i++)
+ {
+ item = SCM_CAR (lst);
+
+ if (SCM_LIKELY (SCM_I_INUMP (item)))
+ {
+ long c_item;
+
+ c_item = SCM_I_INUM (item);
+ if (SCM_LIKELY ((c_item >= 0) && (c_item < 256)))
+ c_bv[i] = (unsigned char) c_item;
+ else
+ goto type_error;
+ }
+ else
+ goto type_error;
+ }
+
+ return bv;
+
+ type_error:
+ scm_wrong_type_arg (FUNC_NAME, 1, item);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+/* Compute the two's complement of VALUE (a positive integer) on SIZE octets
+ using (2^(SIZE * 8) - VALUE). */
+static inline void
+twos_complement (mpz_t value, size_t size)
+{
+ unsigned long bit_count;
+
+ /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
+ checking on SIZE performed earlier. */
+ bit_count = (unsigned long) size << 3UL;
+
+ if (SCM_LIKELY (bit_count < sizeof (unsigned long)))
+ mpz_ui_sub (value, 1UL << bit_count, value);
+ else
+ {
+ mpz_t max;
+
+ mpz_init (max);
+ mpz_ui_pow_ui (max, 2, bit_count);
+ mpz_sub (value, max, value);
+ mpz_clear (max);
+ }
+}
+
+static inline SCM
+bytevector_large_ref (const char *c_bv, size_t c_size, int signed_p,
+ SCM endianness)
+{
+ SCM result;
+ mpz_t c_mpz;
+ int c_endianness, negative_p = 0;
+
+ if (signed_p)
+ {
+ if (scm_is_eq (endianness, scm_sym_big))
+ negative_p = c_bv[0] & 0x80;
+ else
+ negative_p = c_bv[c_size - 1] & 0x80;
+ }
+
+ c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
+
+ mpz_init (c_mpz);
+ mpz_import (c_mpz, 1 /* 1 word */, 1 /* word order doesn't matter */,
+ c_size /* word is C_SIZE-byte long */,
+ c_endianness,
+ 0 /* nails */, c_bv);
+
+ if (signed_p && negative_p)
+ {
+ twos_complement (c_mpz, c_size);
+ mpz_neg (c_mpz, c_mpz);
+ }
+
+ result = scm_from_mpz (c_mpz);
+ mpz_clear (c_mpz); /* FIXME: Needed? */
+
+ return result;
+}
+
+static inline int
+bytevector_large_set (char *c_bv, size_t c_size, int signed_p,
+ SCM value, SCM endianness)
+{
+ mpz_t c_mpz;
+ int c_endianness, c_sign, err = 0;
+
+ c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
+
+ mpz_init (c_mpz);
+ scm_to_mpz (value, c_mpz);
+
+ c_sign = mpz_sgn (c_mpz);
+ if (c_sign < 0)
+ {
+ if (SCM_LIKELY (signed_p))
+ {
+ mpz_neg (c_mpz, c_mpz);
+ twos_complement (c_mpz, c_size);
+ }
+ else
+ {
+ err = -1;
+ goto finish;
+ }
+ }
+
+ if (c_sign == 0)
+ /* Zero. */
+ memset (c_bv, 0, c_size);
+ else
+ {
+ size_t word_count, value_size;
+
+ value_size = (mpz_sizeinbase (c_mpz, 2) + (8 * c_size)) / (8 * c_size);
+ if (SCM_UNLIKELY (value_size > c_size))
+ {
+ err = -2;
+ goto finish;
+ }
+
+
+ mpz_export (c_bv, &word_count, 1 /* word order doesn't matter */,
+ c_size, c_endianness,
+ 0 /* nails */, c_mpz);
+ if (SCM_UNLIKELY (word_count != 1))
+ /* Shouldn't happen since we already checked with VALUE_SIZE. */
+ abort ();
+ }
+
+ finish:
+ mpz_clear (c_mpz);
+
+ return err;
+}
+
+#define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \
+ unsigned long c_len, c_index, c_size; \
+ char *c_bv; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, bv); \
+ c_index = scm_to_ulong (index); \
+ c_size = scm_to_ulong (size); \
+ \
+ c_len = SCM_BYTEVECTOR_LENGTH (bv); \
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
+ \
+ /* C_SIZE must have its 3 higher bits set to zero so that \
+ multiplying it by 8 yields a number that fits in an \
+ unsigned long. */ \
+ if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
+ scm_out_of_range (FUNC_NAME, size); \
+ if (SCM_UNLIKELY (c_index + c_size > c_len)) \
+ scm_out_of_range (FUNC_NAME, index);
+
+
+/* Template of an integer reference function. */
+#define GENERIC_INTEGER_REF(_sign) \
+ SCM result; \
+ \
+ if (c_size < 3) \
+ { \
+ int swap; \
+ _sign int value; \
+ \
+ swap = !scm_is_eq (endianness, native_endianness); \
+ switch (c_size) \
+ { \
+ case 1: \
+ { \
+ _sign char c_value8; \
+ memcpy (&c_value8, c_bv, 1); \
+ value = c_value8; \
+ } \
+ break; \
+ case 2: \
+ { \
+ INT_TYPE (16, _sign) c_value16; \
+ memcpy (&c_value16, c_bv, 2); \
+ if (swap) \
+ value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \
+ else \
+ value = c_value16; \
+ } \
+ break; \
+ default: \
+ abort (); \
+ } \
+ \
+ result = SCM_I_MAKINUM ((_sign int) value); \
+ } \
+ else \
+ result = bytevector_large_ref ((char *) c_bv, \
+ c_size, SIGNEDNESS (_sign), \
+ endianness); \
+ \
+ return result;
+
+static inline SCM
+bytevector_signed_ref (const char *c_bv, size_t c_size, SCM endianness)
+{
+ GENERIC_INTEGER_REF (signed);
+}
+
+static inline SCM
+bytevector_unsigned_ref (const char *c_bv, size_t c_size, SCM endianness)
+{
+ GENERIC_INTEGER_REF (unsigned);
+}
+
+
+/* Template of an integer assignment function. */
+#define GENERIC_INTEGER_SET(_sign) \
+ if (c_size < 3) \
+ { \
+ _sign int c_value; \
+ \
+ if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
+ goto range_error; \
+ \
+ c_value = SCM_I_INUM (value); \
+ switch (c_size) \
+ { \
+ case 1: \
+ if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \
+ { \
+ _sign char c_value8; \
+ c_value8 = (_sign char) c_value; \
+ memcpy (c_bv, &c_value8, 1); \
+ } \
+ else \
+ goto range_error; \
+ break; \
+ \
+ case 2: \
+ if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \
+ { \
+ int swap; \
+ INT_TYPE (16, _sign) c_value16; \
+ \
+ swap = !scm_is_eq (endianness, native_endianness); \
+ \
+ if (swap) \
+ c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \
+ else \
+ c_value16 = c_value; \
+ \
+ memcpy (c_bv, &c_value16, 2); \
+ } \
+ else \
+ goto range_error; \
+ break; \
+ \
+ default: \
+ abort (); \
+ } \
+ } \
+ else \
+ { \
+ int err; \
+ \
+ err = bytevector_large_set (c_bv, c_size, \
+ SIGNEDNESS (_sign), \
+ value, endianness); \
+ if (err) \
+ goto range_error; \
+ } \
+ \
+ return; \
+ \
+ range_error: \
+ scm_out_of_range (FUNC_NAME, value); \
+ return;
+
+static inline void
+bytevector_signed_set (char *c_bv, size_t c_size,
+ SCM value, SCM endianness,
+ const char *func_name)
+#define FUNC_NAME func_name
+{
+ GENERIC_INTEGER_SET (signed);
+}
+#undef FUNC_NAME
+
+static inline void
+bytevector_unsigned_set (char *c_bv, size_t c_size,
+ SCM value, SCM endianness,
+ const char *func_name)
+#define FUNC_NAME func_name
+{
+ GENERIC_INTEGER_SET (unsigned);
+}
+#undef FUNC_NAME
+
+#undef GENERIC_INTEGER_SET
+#undef GENERIC_INTEGER_REF
+
+
+SCM_DEFINE (scm_bytevector_uint_ref, "bytevector-uint-ref", 4, 0, 0,
+ (SCM bv, SCM index, SCM endianness, SCM size),
+ "Return the @var{size}-octet long unsigned integer at index "
+ "@var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_uint_ref
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
+
+ return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_sint_ref, "bytevector-sint-ref", 4, 0, 0,
+ (SCM bv, SCM index, SCM endianness, SCM size),
+ "Return the @var{size}-octet long unsigned integer at index "
+ "@var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_sint_ref
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
+
+ return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_uint_set_x, "bytevector-uint-set!", 5, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
+ "Set the @var{size}-octet long unsigned integer at @var{index} "
+ "to @var{value}.")
+#define FUNC_NAME s_scm_bytevector_uint_set_x
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
+
+ bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness,
+ FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
+ "Set the @var{size}-octet long signed integer at @var{index} "
+ "to @var{value}.")
+#define FUNC_NAME s_scm_bytevector_sint_set_x
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
+
+ bytevector_signed_set (&c_bv[c_index], c_size, value, endianness,
+ FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+\f
+/* Operations on integers of arbitrary size. */
+
+#define INTEGERS_TO_LIST(_sign) \
+ SCM lst, pair; \
+ size_t i, c_len, c_size; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, bv); \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ c_size = scm_to_uint (size); \
+ \
+ c_len = SCM_BYTEVECTOR_LENGTH (bv); \
+ if (SCM_UNLIKELY (c_len == 0)) \
+ lst = SCM_EOL; \
+ else if (SCM_UNLIKELY (c_len < c_size)) \
+ scm_out_of_range (FUNC_NAME, size); \
+ else \
+ { \
+ const char *c_bv; \
+ \
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
+ \
+ lst = scm_make_list (scm_from_uint (c_len / c_size), \
+ SCM_UNSPECIFIED); \
+ for (i = 0, pair = lst; \
+ i <= c_len - c_size; \
+ i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
+ { \
+ SCM_SETCAR (pair, \
+ bytevector_ ## _sign ## _ref (c_bv, c_size, \
+ endianness)); \
+ } \
+ } \
+ \
+ return lst;
+
+SCM_DEFINE (scm_bytevector_to_sint_list, "bytevector->sint-list",
+ 3, 0, 0,
+ (SCM bv, SCM endianness, SCM size),
+ "Return a list of signed integers of @var{size} octets "
+ "representing the contents of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_to_sint_list
+{
+ INTEGERS_TO_LIST (signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list",
+ 3, 0, 0,
+ (SCM bv, SCM endianness, SCM size),
+ "Return a list of unsigned integers of @var{size} octets "
+ "representing the contents of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_to_uint_list
+{
+ INTEGERS_TO_LIST (unsigned);
+}
+#undef FUNC_NAME
+
+#undef INTEGER_TO_LIST
+
+
+#define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
+ SCM bv; \
+ long c_len; \
+ size_t c_size; \
+ char *c_bv, *c_bv_ptr; \
+ \
+ SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ c_size = scm_to_uint (size); \
+ \
+ if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
+ scm_out_of_range (FUNC_NAME, size); \
+ \
+ bv = make_bytevector (c_len * c_size); \
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
+ \
+ for (c_bv_ptr = c_bv; \
+ !scm_is_null (lst); \
+ lst = SCM_CDR (lst), c_bv_ptr += c_size) \
+ { \
+ bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
+ SCM_CAR (lst), endianness, \
+ FUNC_NAME); \
+ } \
+ \
+ return bv;
+
+
+SCM_DEFINE (scm_uint_list_to_bytevector, "uint-list->bytevector",
+ 3, 0, 0,
+ (SCM lst, SCM endianness, SCM size),
+ "Return a bytevector containing the unsigned integers "
+ "listed in @var{lst} and encoded on @var{size} octets "
+ "according to @var{endianness}.")
+#define FUNC_NAME s_scm_uint_list_to_bytevector
+{
+ INTEGER_LIST_TO_BYTEVECTOR (unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sint_list_to_bytevector, "sint-list->bytevector",
+ 3, 0, 0,
+ (SCM lst, SCM endianness, SCM size),
+ "Return a bytevector containing the signed integers "
+ "listed in @var{lst} and encoded on @var{size} octets "
+ "according to @var{endianness}.")
+#define FUNC_NAME s_scm_sint_list_to_bytevector
+{
+ INTEGER_LIST_TO_BYTEVECTOR (signed);
+}
+#undef FUNC_NAME
+
+#undef INTEGER_LIST_TO_BYTEVECTOR
+
+
+\f
+/* Operations on 16-bit integers. */
+
+SCM_DEFINE (scm_bytevector_u16_ref, "bytevector-u16-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the unsigned 16-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_u16_ref
+{
+ INTEGER_REF (16, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s16_ref, "bytevector-s16-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the signed 16-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_s16_ref
+{
+ INTEGER_REF (16, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u16_native_ref, "bytevector-u16-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 16-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u16_native_ref
+{
+ INTEGER_NATIVE_REF (16, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s16_native_ref, "bytevector-s16-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 16-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s16_native_ref
+{
+ INTEGER_NATIVE_REF (16, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u16_set_x, "bytevector-u16-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_u16_set_x
+{
+ INTEGER_SET (16, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s16_set_x, "bytevector-s16-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_s16_set_x
+{
+ INTEGER_SET (16, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u16_native_set_x, "bytevector-u16-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the unsigned integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u16_native_set_x
+{
+ INTEGER_NATIVE_SET (16, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the signed integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s16_native_set_x
+{
+ INTEGER_NATIVE_SET (16, signed);
+}
+#undef FUNC_NAME
+
+
+\f
+/* Operations on 32-bit integers. */
+
+/* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
+ arbitrary 32-bit integers. Thus we fall back to using the
+ `large_{ref,set}' variants on 32-bit machines. */
+
+#define LARGE_INTEGER_REF(_len, _sign) \
+ INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
+ SIGNEDNESS (_sign), endianness));
+
+#define LARGE_INTEGER_SET(_len, _sign) \
+ int err; \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ SCM_VALIDATE_SYMBOL (4, endianness); \
+ \
+ err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
+ SIGNEDNESS (_sign), value, endianness); \
+ if (SCM_UNLIKELY (err)) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ return SCM_UNSPECIFIED;
+
+#define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
+ INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
+ return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
+ SIGNEDNESS (_sign), native_endianness));
+
+#define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
+ int err; \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ \
+ err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
+ SIGNEDNESS (_sign), value, \
+ native_endianness); \
+ if (SCM_UNLIKELY (err)) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ return SCM_UNSPECIFIED;
+
+
+SCM_DEFINE (scm_bytevector_u32_ref, "bytevector-u32-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the unsigned 32-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_u32_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_REF (32, unsigned);
+#else
+ LARGE_INTEGER_REF (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_ref, "bytevector-s32-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the signed 32-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_s32_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_REF (32, signed);
+#else
+ LARGE_INTEGER_REF (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u32_native_ref, "bytevector-u32-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 32-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u32_native_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_REF (32, unsigned);
+#else
+ LARGE_INTEGER_NATIVE_REF (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_native_ref, "bytevector-s32-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 32-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s32_native_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_REF (32, signed);
+#else
+ LARGE_INTEGER_NATIVE_REF (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u32_set_x, "bytevector-u32-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_u32_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_SET (32, unsigned);
+#else
+ LARGE_INTEGER_SET (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_set_x, "bytevector-s32-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_s32_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_SET (32, signed);
+#else
+ LARGE_INTEGER_SET (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u32_native_set_x, "bytevector-u32-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the unsigned integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u32_native_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_SET (32, unsigned);
+#else
+ LARGE_INTEGER_NATIVE_SET (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_native_set_x, "bytevector-s32-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the signed integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s32_native_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_SET (32, signed);
+#else
+ LARGE_INTEGER_NATIVE_SET (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+
+\f
+/* Operations on 64-bit integers. */
+
+/* For 64-bit integers, we use only the `large_{ref,set}' variant. */
+
+SCM_DEFINE (scm_bytevector_u64_ref, "bytevector-u64-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the unsigned 64-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_u64_ref
+{
+ LARGE_INTEGER_REF (64, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s64_ref, "bytevector-s64-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the signed 64-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_s64_ref
+{
+ LARGE_INTEGER_REF (64, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u64_native_ref, "bytevector-u64-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 64-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u64_native_ref
+{
+ LARGE_INTEGER_NATIVE_REF (64, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s64_native_ref, "bytevector-s64-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 64-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s64_native_ref
+{
+ LARGE_INTEGER_NATIVE_REF (64, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u64_set_x, "bytevector-u64-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_u64_set_x
+{
+ LARGE_INTEGER_SET (64, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s64_set_x, "bytevector-s64-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_s64_set_x
+{
+ LARGE_INTEGER_SET (64, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u64_native_set_x, "bytevector-u64-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the unsigned integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u64_native_set_x
+{
+ LARGE_INTEGER_NATIVE_SET (64, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s64_native_set_x, "bytevector-s64-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the signed integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s64_native_set_x
+{
+ LARGE_INTEGER_NATIVE_SET (64, signed);
+}
+#undef FUNC_NAME
+
+
+\f
+/* Operations on IEEE-754 numbers. */
+
+/* There are two possible word endians, visible in glibc's <ieee754.h>.
+ However, in R6RS, when the endianness is `little', little endian is
+ assumed for both the byte order and the word order. This is clear from
+ Section 2.1 of R6RS-lib (in response to
+ http://www.r6rs.org/formal-comments/comment-187.txt). */
+
+
+/* Convert to/from a floating-point number with different endianness. This
+ method is probably not the most efficient but it should be portable. */
+
+static inline void
+float_to_foreign_endianness (union scm_ieee754_float *target,
+ float source)
+{
+ union scm_ieee754_float src;
+
+ src.f = source;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ target->little_endian.negative = src.big_endian.negative;
+ target->little_endian.exponent = src.big_endian.exponent;
+ target->little_endian.mantissa = src.big_endian.mantissa;
+#else
+ target->big_endian.negative = src.little_endian.negative;
+ target->big_endian.exponent = src.little_endian.exponent;
+ target->big_endian.mantissa = src.little_endian.mantissa;
+#endif
+}
+
+static inline float
+float_from_foreign_endianness (const union scm_ieee754_float *source)
+{
+ union scm_ieee754_float result;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ result.big_endian.negative = source->little_endian.negative;
+ result.big_endian.exponent = source->little_endian.exponent;
+ result.big_endian.mantissa = source->little_endian.mantissa;
+#else
+ result.little_endian.negative = source->big_endian.negative;
+ result.little_endian.exponent = source->big_endian.exponent;
+ result.little_endian.mantissa = source->big_endian.mantissa;
+#endif
+
+ return (result.f);
+}
+
+static inline void
+double_to_foreign_endianness (union scm_ieee754_double *target,
+ double source)
+{
+ union scm_ieee754_double src;
+
+ src.d = source;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ target->little_little_endian.negative = src.big_endian.negative;
+ target->little_little_endian.exponent = src.big_endian.exponent;
+ target->little_little_endian.mantissa0 = src.big_endian.mantissa0;
+ target->little_little_endian.mantissa1 = src.big_endian.mantissa1;
+#else
+ target->big_endian.negative = src.little_little_endian.negative;
+ target->big_endian.exponent = src.little_little_endian.exponent;
+ target->big_endian.mantissa0 = src.little_little_endian.mantissa0;
+ target->big_endian.mantissa1 = src.little_little_endian.mantissa1;
+#endif
+}
+
+static inline double
+double_from_foreign_endianness (const union scm_ieee754_double *source)
+{
+ union scm_ieee754_double result;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ result.big_endian.negative = source->little_little_endian.negative;
+ result.big_endian.exponent = source->little_little_endian.exponent;
+ result.big_endian.mantissa0 = source->little_little_endian.mantissa0;
+ result.big_endian.mantissa1 = source->little_little_endian.mantissa1;
+#else
+ result.little_little_endian.negative = source->big_endian.negative;
+ result.little_little_endian.exponent = source->big_endian.exponent;
+ result.little_little_endian.mantissa0 = source->big_endian.mantissa0;
+ result.little_little_endian.mantissa1 = source->big_endian.mantissa1;
+#endif
+
+ return (result.d);
+}
+
+/* Template macros to abstract over doubles and floats.
+ XXX: Guile can only convert to/from doubles. */
+#define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type
+#define IEEE754_TO_SCM(_c_type) scm_from_double
+#define IEEE754_FROM_SCM(_c_type) scm_to_double
+#define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
+ _c_type ## _from_foreign_endianness
+#define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
+ _c_type ## _to_foreign_endianness
+
+
+/* Templace getters and setters. */
+
+#define IEEE754_ACCESSOR_PROLOGUE(_type) \
+ INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
+
+#define IEEE754_REF(_type) \
+ _type c_result; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ if (scm_is_eq (endianness, native_endianness)) \
+ memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
+ else \
+ { \
+ IEEE754_UNION (_type) c_raw; \
+ \
+ memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
+ c_result = \
+ IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
+ } \
+ \
+ return (IEEE754_TO_SCM (_type) (c_result));
+
+#define IEEE754_NATIVE_REF(_type) \
+ _type c_result; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ \
+ memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
+ return (IEEE754_TO_SCM (_type) (c_result));
+
+#define IEEE754_SET(_type) \
+ _type c_value; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ SCM_VALIDATE_REAL (3, value); \
+ SCM_VALIDATE_SYMBOL (4, endianness); \
+ c_value = IEEE754_FROM_SCM (_type) (value); \
+ \
+ if (scm_is_eq (endianness, native_endianness)) \
+ memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
+ else \
+ { \
+ IEEE754_UNION (_type) c_raw; \
+ \
+ IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
+ memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
+ } \
+ \
+ return SCM_UNSPECIFIED;
+
+#define IEEE754_NATIVE_SET(_type) \
+ _type c_value; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ SCM_VALIDATE_REAL (3, value); \
+ c_value = IEEE754_FROM_SCM (_type) (value); \
+ \
+ memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
+ return SCM_UNSPECIFIED;
+
+
+/* Single precision. */
+
+SCM_DEFINE (scm_bytevector_ieee_single_ref,
+ "bytevector-ieee-single-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the IEEE-754 single from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_ref
+{
+ IEEE754_REF (float);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_single_native_ref,
+ "bytevector-ieee-single-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the IEEE-754 single from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_native_ref
+{
+ IEEE754_NATIVE_REF (float);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_single_set_x,
+ "bytevector-ieee-single-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store real @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_set_x
+{
+ IEEE754_SET (float);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_single_native_set_x,
+ "bytevector-ieee-single-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the real @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x
+{
+ IEEE754_NATIVE_SET (float);
+}
+#undef FUNC_NAME
+
+
+/* Double precision. */
+
+SCM_DEFINE (scm_bytevector_ieee_double_ref,
+ "bytevector-ieee-double-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the IEEE-754 double from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_ref
+{
+ IEEE754_REF (double);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_double_native_ref,
+ "bytevector-ieee-double-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the IEEE-754 double from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_native_ref
+{
+ IEEE754_NATIVE_REF (double);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_double_set_x,
+ "bytevector-ieee-double-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store real @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_set_x
+{
+ IEEE754_SET (double);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_double_native_set_x,
+ "bytevector-ieee-double-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the real @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x
+{
+ IEEE754_NATIVE_SET (double);
+}
+#undef FUNC_NAME
+
+
+#undef IEEE754_UNION
+#undef IEEE754_TO_SCM
+#undef IEEE754_FROM_SCM
+#undef IEEE754_FROM_FOREIGN_ENDIANNESS
+#undef IEEE754_TO_FOREIGN_ENDIANNESS
+#undef IEEE754_REF
+#undef IEEE754_NATIVE_REF
+#undef IEEE754_SET
+#undef IEEE754_NATIVE_SET
+
+\f
+/* Operations on strings. */
+
+
+/* Produce a function that returns the length of a UTF-encoded string. */
+#define UTF_STRLEN_FUNCTION(_utf_width) \
+static inline size_t \
+utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
+{ \
+ size_t len = 0; \
+ const uint ## _utf_width ## _t *ptr; \
+ for (ptr = str; \
+ *ptr != 0; \
+ ptr++) \
+ { \
+ len++; \
+ } \
+ \
+ return (len * ((_utf_width) / 8)); \
+}
+
+UTF_STRLEN_FUNCTION (8)
+
+
+/* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
+#define UTF_STRLEN(_utf_width, _str) \
+ utf ## _utf_width ## _strlen (_str)
+
+/* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
+ ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
+ encoding name). */
+static inline void
+utf_encoding_name (char *name, size_t utf_width, SCM endianness)
+{
+ strcpy (name, "UTF-");
+ strcat (name, ((utf_width == 8)
+ ? "8"
+ : ((utf_width == 16)
+ ? "16"
+ : ((utf_width == 32)
+ ? "32"
+ : "??"))));
+ strcat (name,
+ ((scm_is_eq (endianness, scm_sym_big))
+ ? "BE"
+ : ((scm_is_eq (endianness, scm_sym_little))
+ ? "LE"
+ : "unknown")));
+}
+
+/* Maximum length of a UTF encoding name. */
+#define MAX_UTF_ENCODING_NAME_LEN 16
+
+/* Produce the body of a `string->utf' function. */
+#define STRING_TO_UTF(_utf_width) \
+ SCM utf; \
+ int err; \
+ char *c_str; \
+ char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
+ char *c_utf = NULL, *c_locale; \
+ size_t c_strlen, c_raw_strlen, c_utf_len = 0; \
+ \
+ SCM_VALIDATE_STRING (1, str); \
+ if (endianness == SCM_UNDEFINED) \
+ endianness = scm_sym_big; \
+ else \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ \
+ c_strlen = scm_c_string_length (str); \
+ c_raw_strlen = c_strlen * ((_utf_width) / 8); \
+ do \
+ { \
+ c_str = (char *) alloca (c_raw_strlen + 1); \
+ c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \
+ } \
+ while (c_raw_strlen > c_strlen); \
+ c_str[c_raw_strlen] = '\0'; \
+ \
+ utf_encoding_name (c_utf_name, (_utf_width), endianness); \
+ \
+ c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
+ strcpy (c_locale, locale_charset ()); \
+ \
+ err = mem_iconveh (c_str, c_raw_strlen, \
+ c_locale, c_utf_name, \
+ iconveh_question_mark, NULL, \
+ &c_utf, &c_utf_len); \
+ if (SCM_UNLIKELY (err)) \
+ scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
+ scm_list_1 (str), err); \
+ else \
+ /* C_UTF is null-terminated. */ \
+ utf = scm_c_take_bytevector ((signed char *) c_utf, \
+ c_utf_len); \
+ \
+ return (utf);
+
+
+
+SCM_DEFINE (scm_string_to_utf8, "string->utf8",
+ 1, 0, 0,
+ (SCM str),
+ "Return a newly allocated bytevector that contains the UTF-8 "
+ "encoding of @var{str}.")
+#define FUNC_NAME s_scm_string_to_utf8
+{
+ SCM utf;
+ char *c_str;
+ uint8_t *c_utf;
+ size_t c_strlen, c_raw_strlen;
+
+ SCM_VALIDATE_STRING (1, str);
+
+ c_strlen = scm_c_string_length (str);
+ c_raw_strlen = c_strlen;
+ do
+ {
+ c_str = (char *) alloca (c_raw_strlen + 1);
+ c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen);
+ }
+ while (c_raw_strlen > c_strlen);
+ c_str[c_raw_strlen] = '\0';
+
+ c_utf = u8_strconv_from_locale (c_str);
+ if (SCM_UNLIKELY (c_utf == NULL))
+ scm_syserror (FUNC_NAME);
+ else
+ /* C_UTF is null-terminated. */
+ utf = scm_c_take_bytevector ((signed char *) c_utf,
+ UTF_STRLEN (8, c_utf));
+
+ return (utf);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_to_utf16, "string->utf16",
+ 1, 1, 0,
+ (SCM str, SCM endianness),
+ "Return a newly allocated bytevector that contains the UTF-16 "
+ "encoding of @var{str}.")
+#define FUNC_NAME s_scm_string_to_utf16
+{
+ STRING_TO_UTF (16);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_to_utf32, "string->utf32",
+ 1, 1, 0,
+ (SCM str, SCM endianness),
+ "Return a newly allocated bytevector that contains the UTF-32 "
+ "encoding of @var{str}.")
+#define FUNC_NAME s_scm_string_to_utf32
+{
+ STRING_TO_UTF (32);
+}
+#undef FUNC_NAME
+
+
+/* Produce the body of a function that converts a UTF-encoded bytevector to a
+ string. */
+#define UTF_TO_STRING(_utf_width) \
+ SCM str = SCM_BOOL_F; \
+ int err; \
+ char *c_str = NULL, *c_locale; \
+ char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
+ const char *c_utf; \
+ size_t c_strlen = 0, c_utf_len; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, utf); \
+ if (endianness == SCM_UNDEFINED) \
+ endianness = scm_sym_big; \
+ else \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ \
+ c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \
+ c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
+ utf_encoding_name (c_utf_name, (_utf_width), endianness); \
+ \
+ c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
+ strcpy (c_locale, locale_charset ()); \
+ \
+ err = mem_iconveh (c_utf, c_utf_len, \
+ c_utf_name, c_locale, \
+ iconveh_question_mark, NULL, \
+ &c_str, &c_strlen); \
+ if (SCM_UNLIKELY (err)) \
+ scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
+ scm_list_1 (utf), err); \
+ else \
+ /* C_STR is null-terminated. */ \
+ str = scm_take_locale_stringn (c_str, c_strlen); \
+ \
+ return (str);
+
+
+SCM_DEFINE (scm_utf8_to_string, "utf8->string",
+ 1, 0, 0,
+ (SCM utf),
+ "Return a newly allocate string that contains from the UTF-8-"
+ "encoded contents of bytevector @var{utf}.")
+#define FUNC_NAME s_scm_utf8_to_string
+{
+ SCM str;
+ int err;
+ char *c_str = NULL, *c_locale;
+ const char *c_utf;
+ size_t c_utf_len, c_strlen = 0;
+
+ SCM_VALIDATE_BYTEVECTOR (1, utf);
+
+ c_utf_len = SCM_BYTEVECTOR_LENGTH (utf);
+
+ c_locale = (char *) alloca (strlen (locale_charset ()) + 1);
+ strcpy (c_locale, locale_charset ());
+
+ c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf);
+ err = mem_iconveh (c_utf, c_utf_len,
+ "UTF-8", c_locale,
+ iconveh_question_mark, NULL,
+ &c_str, &c_strlen);
+ if (SCM_UNLIKELY (err))
+ scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A",
+ scm_list_1 (utf), err);
+ else
+ /* C_STR is null-terminated. */
+ str = scm_take_locale_stringn (c_str, c_strlen);
+
+ return (str);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_utf16_to_string, "utf16->string",
+ 1, 1, 0,
+ (SCM utf, SCM endianness),
+ "Return a newly allocate string that contains from the UTF-16-"
+ "encoded contents of bytevector @var{utf}.")
+#define FUNC_NAME s_scm_utf16_to_string
+{
+ UTF_TO_STRING (16);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_utf32_to_string, "utf32->string",
+ 1, 1, 0,
+ (SCM utf, SCM endianness),
+ "Return a newly allocate string that contains from the UTF-32-"
+ "encoded contents of bytevector @var{utf}.")
+#define FUNC_NAME s_scm_utf32_to_string
+{
+ UTF_TO_STRING (32);
+}
+#undef FUNC_NAME
+
+
+\f
+/* Initialization. */
+
+void
+scm_init_bytevectors (void)
+{
+#include "libguile/bytevectors.x"
+
+#ifdef WORDS_BIGENDIAN
+ native_endianness = scm_sym_big;
+#else
+ native_endianness = scm_sym_little;
+#endif
+
+ scm_endianness_big = scm_sym_big;
+ scm_endianness_little = scm_sym_little;
+
+ scm_null_bytevector =
+ scm_gc_protect_object (make_bytevector_from_buffer (0, NULL));
+}
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
new file mode 100644
index 0000000..98c38ac
--- /dev/null
+++ b/libguile/bytevectors.h
@@ -0,0 +1,133 @@
+#ifndef SCM_BYTEVECTORS_H
+#define SCM_BYTEVECTORS_H
+
+/* Copyright (C) 2009 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 2.1 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+
+/* R6RS bytevectors. */
+
+#define SCM_BYTEVECTOR_LENGTH(_bv) \
+ ((unsigned) SCM_SMOB_DATA (_bv))
+#define SCM_BYTEVECTOR_CONTENTS(_bv) \
+ (SCM_BYTEVECTOR_INLINE_P (_bv) \
+ ? (signed char *) SCM_SMOB_OBJECT_2_LOC (_bv) \
+ : (signed char *) SCM_SMOB_DATA_2 (_bv))
+
+
+SCM_API SCM scm_endianness_big;
+SCM_API SCM scm_endianness_little;
+
+SCM_API SCM scm_make_bytevector (SCM, SCM);
+SCM_API SCM scm_c_make_bytevector (unsigned);
+SCM_API SCM scm_native_endianness (void);
+SCM_API SCM scm_bytevector_p (SCM);
+SCM_API SCM scm_bytevector_length (SCM);
+SCM_API SCM scm_bytevector_eq_p (SCM, SCM);
+SCM_API SCM scm_bytevector_fill_x (SCM, SCM);
+SCM_API SCM scm_bytevector_copy_x (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_copy (SCM);
+
+SCM_API SCM scm_bytevector_to_u8_list (SCM);
+SCM_API SCM scm_u8_list_to_bytevector (SCM);
+SCM_API SCM scm_uint_list_to_bytevector (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_to_uint_list (SCM, SCM, SCM);
+SCM_API SCM scm_sint_list_to_bytevector (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_to_sint_list (SCM, SCM, SCM);
+
+SCM_API SCM scm_bytevector_u16_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s16_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_u32_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s32_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_u64_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s64_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_u8_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s8_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_uint_ref (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_sint_ref (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u16_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s16_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u32_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s32_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u64_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s64_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u16_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s16_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u32_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s32_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u64_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s64_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u8_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s8_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_uint_set_x (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_sint_set_x (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u16_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s16_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u32_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s32_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u64_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s64_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_string_to_utf8 (SCM);
+SCM_API SCM scm_string_to_utf16 (SCM, SCM);
+SCM_API SCM scm_string_to_utf32 (SCM, SCM);
+SCM_API SCM scm_utf8_to_string (SCM);
+SCM_API SCM scm_utf16_to_string (SCM, SCM);
+SCM_API SCM scm_utf32_to_string (SCM, SCM);
+
+
+\f
+/* Internal API. */
+
+/* The threshold (in octets) under which bytevectors are stored "in-line",
+ i.e., without allocating memory beside the SMOB itself (a double cell).
+ This optimization is necessary since small bytevectors are expected to be
+ common. */
+#define SCM_BYTEVECTOR_INLINE_THRESHOLD (2 * sizeof (SCM))
+#define SCM_BYTEVECTOR_INLINEABLE_SIZE_P(_size) \
+ ((_size) <= SCM_BYTEVECTOR_INLINE_THRESHOLD)
+#define SCM_BYTEVECTOR_INLINE_P(_bv) \
+ (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (SCM_BYTEVECTOR_LENGTH (_bv)))
+
+/* Hint that is passed to `scm_gc_malloc ()' and friends. */
+#define SCM_GC_BYTEVECTOR "bytevector"
+
+SCM_API void scm_init_bytevectors (void);
+
+SCM_INTERNAL scm_t_bits scm_tc16_bytevector;
+SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, unsigned);
+
+#define scm_c_shrink_bytevector(_bv, _len) \
+ (SCM_BYTEVECTOR_INLINE_P (_bv) \
+ ? (_bv) \
+ : scm_i_shrink_bytevector ((_bv), (_len)))
+
+SCM_INTERNAL SCM scm_i_shrink_bytevector (SCM, unsigned);
+SCM_INTERNAL SCM scm_null_bytevector;
+
+#endif /* SCM_BYTEVECTORS_H */
diff --git a/libguile/ieee-754.h b/libguile/ieee-754.h
new file mode 100644
index 0000000..e345efa
--- /dev/null
+++ b/libguile/ieee-754.h
@@ -0,0 +1,90 @@
+/* Copyright (C) 1992, 1995, 1996, 1999 Free Software Foundation, Inc.
+ This file is part of the GNU C Library.
+
+ The GNU C 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 2.1 of the License, or (at your option) any later version.
+
+ The GNU C 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 the GNU C Library; if not, write to the Free
+ Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+ 02111-1307 USA. */
+
+#ifndef SCM_IEEE_754_H
+#define SCM_IEEE_754_H 1
+
+/* Based on glibc's <ieee754.h> and modified by Ludovic Courtès to include
+ all possible IEEE-754 double-precision representations. */
+
+\f
+/* IEEE 754 simple-precision format (32-bit). */
+
+union scm_ieee754_float
+ {
+ float f;
+
+ struct
+ {
+ unsigned int negative:1;
+ unsigned int exponent:8;
+ unsigned int mantissa:23;
+ } big_endian;
+
+ struct
+ {
+ unsigned int mantissa:23;
+ unsigned int exponent:8;
+ unsigned int negative:1;
+ } little_endian;
+ };
+
+
+\f
+/* IEEE 754 double-precision format (64-bit). */
+
+union scm_ieee754_double
+ {
+ double d;
+
+ struct
+ {
+ /* Big endian. */
+
+ unsigned int negative:1;
+ unsigned int exponent:11;
+ /* Together these comprise the mantissa. */
+ unsigned int mantissa0:20;
+ unsigned int mantissa1:32;
+ } big_endian;
+
+ struct
+ {
+ /* Both byte order and word order are little endian. */
+
+ /* Together these comprise the mantissa. */
+ unsigned int mantissa1:32;
+ unsigned int mantissa0:20;
+ unsigned int exponent:11;
+ unsigned int negative:1;
+ } little_little_endian;
+
+ struct
+ {
+ /* Byte order is little endian but word order is big endian. Not
+ sure this is very wide spread. */
+ unsigned int mantissa0:20;
+ unsigned int exponent:11;
+ unsigned int negative:1;
+ unsigned int mantissa1:32;
+ } little_big_endian;
+
+ };
+
+
+#endif /* SCM_IEEE_754_H */
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
new file mode 100644
index 0000000..a07636f
--- /dev/null
+++ b/libguile/r6rs-ports.c
@@ -0,0 +1,1118 @@
+/* Copyright (C) 2009 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 2.1 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
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+# include <unistd.h>
+#endif
+
+#include <string.h>
+#include <stdio.h>
+#include <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/bytevectors.h"
+#include "libguile/chars.h"
+#include "libguile/eval.h"
+#include "libguile/r6rs-ports.h"
+#include "libguile/strings.h"
+#include "libguile/validate.h"
+#include "libguile/values.h"
+#include "libguile/vectors.h"
+
+
+\f
+/* Unimplemented features. */
+
+
+/* Transoders are currently not implemented since Guile 1.8 is not
+ Unicode-capable. Thus, most of the code here assumes the use of the
+ binary transcoder. */
+static inline void
+transcoders_not_implemented (void)
+{
+ fprintf (stderr, "%s: warning: transcoders not implemented\n",
+ PACKAGE_NAME);
+}
+
+\f
+/* End-of-file object. */
+
+SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0,
+ (void),
+ "Return the end-of-file object.")
+#define FUNC_NAME s_scm_eof_object
+{
+ return (SCM_EOF_VAL);
+}
+#undef FUNC_NAME
+
+\f
+/* Input ports. */
+
+#ifndef MIN
+# define MIN(a,b) ((a) < (b) ? (a) : (b))
+#endif
+
+/* Bytevector input ports or "bip" for short. */
+static scm_t_bits bytevector_input_port_type = 0;
+
+static inline SCM
+make_bip (SCM bv)
+{
+ SCM port;
+ char *c_bv;
+ unsigned c_len;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
+
+ port = scm_new_port_table_entry (bytevector_input_port_type);
+
+ /* Prevent BV from being GC'd. */
+ SCM_SETSTREAM (port, SCM_UNPACK (bv));
+
+ /* Have the port directly access the bytevector. */
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
+ c_port->read_end = (unsigned char *) c_bv + c_len;
+ c_port->read_buf_size = c_len;
+
+ /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
+ SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits);
+
+ return port;
+}
+
+static SCM
+bip_mark (SCM port)
+{
+ /* Mark the underlying bytevector. */
+ return (SCM_PACK (SCM_STREAM (port)));
+}
+
+static int
+bip_fill_input (SCM port)
+{
+ int result;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ if (c_port->read_pos >= c_port->read_end)
+ result = EOF;
+ else
+ result = (int) *c_port->read_pos;
+
+ return result;
+}
+
+static off_t
+bip_seek (SCM port, off_t offset, int whence)
+#define FUNC_NAME "bip_seek"
+{
+ off_t c_result = 0;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ switch (whence)
+ {
+ case SEEK_CUR:
+ offset += c_port->read_pos - c_port->read_buf;
+ /* Fall through. */
+
+ case SEEK_SET:
+ if (c_port->read_buf + offset < c_port->read_end)
+ {
+ c_port->read_pos = c_port->read_buf + offset;
+ c_result = offset;
+ }
+ else
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ break;
+
+ case SEEK_END:
+ if (c_port->read_end - offset >= c_port->read_buf)
+ {
+ c_port->read_pos = c_port->read_end - offset;
+ c_result = c_port->read_pos - c_port->read_buf;
+ }
+ else
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ break;
+
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "invalid `seek' parameter");
+ }
+
+ return c_result;
+}
+#undef FUNC_NAME
+
+
+/* Instantiate the bytevector input port type. */
+static inline void
+initialize_bytevector_input_ports (void)
+{
+ bytevector_input_port_type =
+ scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input,
+ NULL);
+
+ scm_set_port_mark (bytevector_input_port_type, bip_mark);
+ scm_set_port_seek (bytevector_input_port_type, bip_seek);
+}
+
+
+SCM_DEFINE (scm_open_bytevector_input_port,
+ "open-bytevector-input-port", 1, 1, 0,
+ (SCM bv, SCM transcoder),
+ "Return an input port whose contents are drawn from "
+ "bytevector @var{bv}.")
+#define FUNC_NAME s_scm_open_bytevector_input_port
+{
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+ if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
+ transcoders_not_implemented ();
+
+ return (make_bip (bv));
+}
+#undef FUNC_NAME
+
+\f
+/* Custom binary ports. The following routines are shared by input and
+ output custom binary ports. */
+
+#define SCM_CBP_GET_POSITION_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
+#define SCM_CBP_SET_POSITION_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
+#define SCM_CBP_CLOSE_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
+
+static SCM
+cbp_mark (SCM port)
+{
+ /* Mark the underlying method and object vector. */
+ return (SCM_PACK (SCM_STREAM (port)));
+}
+
+static off_t
+cbp_seek (SCM port, off_t offset, int whence)
+#define FUNC_NAME "cbp_seek"
+{
+ SCM result;
+ off_t c_result = 0;
+
+ switch (whence)
+ {
+ case SEEK_CUR:
+ {
+ SCM get_position_proc;
+
+ get_position_proc = SCM_CBP_GET_POSITION_PROC (port);
+ if (SCM_LIKELY (scm_is_true (get_position_proc)))
+ result = scm_call_0 (get_position_proc);
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "R6RS custom binary port does not "
+ "support `port-position'");
+
+ offset += scm_to_int (result);
+ /* Fall through. */
+ }
+
+ case SEEK_SET:
+ {
+ SCM set_position_proc;
+
+ set_position_proc = SCM_CBP_SET_POSITION_PROC (port);
+ if (SCM_LIKELY (scm_is_true (set_position_proc)))
+ result = scm_call_1 (set_position_proc, scm_from_int (offset));
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "R6RS custom binary port does not "
+ "support `set-port-position!'");
+
+ /* Assuming setting the position succeeded. */
+ c_result = offset;
+ break;
+ }
+
+ default:
+ /* `SEEK_END' cannot be supported. */
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "R6RS custom binary ports do not "
+ "support `SEEK_END'");
+ }
+
+ return c_result;
+}
+#undef FUNC_NAME
+
+static int
+cbp_close (SCM port)
+{
+ SCM close_proc;
+
+ close_proc = SCM_CBP_CLOSE_PROC (port);
+ if (scm_is_true (close_proc))
+ /* Invoke the `close' thunk. */
+ scm_call_0 (close_proc);
+
+ return 1;
+}
+
+\f
+/* Custom binary input port ("cbip" for short). */
+
+static scm_t_bits custom_binary_input_port_type = 0;
+
+/* Size of the buffer embedded in custom binary input ports. */
+#define CBIP_BUFFER_SIZE 4096
+
+/* Return the bytevector associated with PORT. */
+#define SCM_CBIP_BYTEVECTOR(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
+
+/* Return the various procedures of PORT. */
+#define SCM_CBIP_READ_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
+
+
+static inline SCM
+make_cbip (SCM read_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc)
+{
+ SCM port, bv, method_vector;
+ char *c_bv;
+ unsigned c_len;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
+
+ /* Use a bytevector as the underlying buffer. */
+ c_len = CBIP_BUFFER_SIZE;
+ bv = scm_c_make_bytevector (c_len);
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ /* Store the various methods and bytevector in a vector. */
+ method_vector = scm_c_make_vector (5, SCM_BOOL_F);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 4, bv);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 0, read_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
+
+ port = scm_new_port_table_entry (custom_binary_input_port_type);
+
+ /* Attach it the method vector. */
+ SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
+
+ /* Have the port directly access the buffer (bytevector). */
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
+ c_port->read_end = (unsigned char *) c_bv;
+ c_port->read_buf_size = c_len;
+
+ /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
+ SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits);
+
+ return port;
+}
+
+static int
+cbip_fill_input (SCM port)
+#define FUNC_NAME "cbip_fill_input"
+{
+ int result;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ again:
+ if (c_port->read_pos >= c_port->read_end)
+ {
+ /* Invoke the user's `read!' procedure. */
+ unsigned c_octets;
+ SCM bv, read_proc, octets;
+
+ /* Use the bytevector associated with PORT as the buffer passed to the
+ `read!' procedure, thereby avoiding additional allocations. */
+ bv = SCM_CBIP_BYTEVECTOR (port);
+ read_proc = SCM_CBIP_READ_PROC (port);
+
+ /* The assumption here is that C_PORT's internal buffer wasn't changed
+ behind our back. */
+ assert (c_port->read_buf ==
+ (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv));
+ assert ((unsigned) c_port->read_buf_size
+ == SCM_BYTEVECTOR_LENGTH (bv));
+
+ octets = scm_call_3 (read_proc, bv, SCM_INUM0,
+ SCM_I_MAKINUM (CBIP_BUFFER_SIZE));
+ c_octets = scm_to_uint (octets);
+
+ c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ c_port->read_end = (unsigned char *) c_port->read_pos + c_octets;
+
+ if (c_octets > 0)
+ goto again;
+ else
+ result = EOF;
+ }
+ else
+ result = (int) *c_port->read_pos;
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_custom_binary_input_port,
+ "make-custom-binary-input-port", 5, 0, 0,
+ (SCM id, SCM read_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc),
+ "Return a new custom binary input port whose input is drained "
+ "by invoking @var{read_proc} and passing it a bytevector, an "
+ "index where octets should be written, and an octet count.")
+#define FUNC_NAME s_scm_make_custom_binary_input_port
+{
+ SCM_VALIDATE_STRING (1, id);
+ SCM_VALIDATE_PROC (2, read_proc);
+
+ if (!scm_is_false (get_position_proc))
+ SCM_VALIDATE_PROC (3, get_position_proc);
+
+ if (!scm_is_false (set_position_proc))
+ SCM_VALIDATE_PROC (4, set_position_proc);
+
+ if (!scm_is_false (close_proc))
+ SCM_VALIDATE_PROC (5, close_proc);
+
+ return (make_cbip (read_proc, get_position_proc, set_position_proc,
+ close_proc));
+}
+#undef FUNC_NAME
+
+
+/* Instantiate the custom binary input port type. */
+static inline void
+initialize_custom_binary_input_ports (void)
+{
+ custom_binary_input_port_type =
+ scm_make_port_type ("r6rs-custom-binary-input-port",
+ cbip_fill_input, NULL);
+
+ scm_set_port_mark (custom_binary_input_port_type, cbp_mark);
+ scm_set_port_seek (custom_binary_input_port_type, cbp_seek);
+ scm_set_port_close (custom_binary_input_port_type, cbp_close);
+}
+
+
+\f
+/* Binary input. */
+
+/* We currently don't support specific binary input ports. */
+#define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
+
+SCM_DEFINE (scm_get_u8, "get-u8", 1, 0, 0,
+ (SCM port),
+ "Read an octet from @var{port}, a binary input port, "
+ "blocking as necessary.")
+#define FUNC_NAME s_scm_get_u8
+{
+ SCM result;
+ int c_result;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ c_result = scm_getc (port);
+ if (c_result == EOF)
+ result = SCM_EOF_VAL;
+ else
+ result = SCM_I_MAKINUM ((unsigned char) c_result);
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_lookahead_u8, "lookahead-u8", 1, 0, 0,
+ (SCM port),
+ "Like @code{get-u8} but does not update @var{port} to "
+ "point past the octet.")
+#define FUNC_NAME s_scm_lookahead_u8
+{
+ SCM result;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ result = scm_peek_char (port);
+ if (SCM_CHARP (result))
+ result = SCM_I_MAKINUM ((signed char) SCM_CHAR (result));
+ else
+ result = SCM_EOF_VAL;
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0,
+ (SCM port, SCM count),
+ "Read @var{count} octets from @var{port}, blocking as "
+ "necessary and return a bytevector containing the octets "
+ "read. If fewer bytes are available, a bytevector smaller "
+ "than @var{count} is returned.")
+#define FUNC_NAME s_scm_get_bytevector_n
+{
+ SCM result;
+ char *c_bv;
+ unsigned c_count;
+ size_t c_read;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+ c_count = scm_to_uint (count);
+
+ result = scm_c_make_bytevector (c_count);
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (result);
+
+ if (SCM_LIKELY (c_count > 0))
+ /* XXX: `scm_c_read ()' does not update the port position. */
+ c_read = scm_c_read (port, c_bv, c_count);
+ else
+ /* Don't invoke `scm_c_read ()' since it may block. */
+ c_read = 0;
+
+ if ((c_read == 0) && (c_count > 0))
+ {
+ if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
+ result = SCM_EOF_VAL;
+ else
+ result = scm_null_bytevector;
+ }
+ else
+ {
+ if (c_read < c_count)
+ result = scm_c_shrink_bytevector (result, c_read);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0,
+ (SCM port, SCM bv, SCM start, SCM count),
+ "Read @var{count} bytes from @var{port} and store them "
+ "in @var{bv} starting at index @var{start}. Return either "
+ "the number of bytes actually read or the end-of-file "
+ "object.")
+#define FUNC_NAME s_scm_get_bytevector_n_x
+{
+ SCM result;
+ char *c_bv;
+ unsigned c_start, c_count, c_len;
+ size_t c_read;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+ SCM_VALIDATE_BYTEVECTOR (2, bv);
+ c_start = scm_to_uint (start);
+ c_count = scm_to_uint (count);
+
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ if (SCM_UNLIKELY (c_start + c_count > c_len))
+ scm_out_of_range (FUNC_NAME, count);
+
+ if (SCM_LIKELY (c_count > 0))
+ c_read = scm_c_read (port, c_bv + c_start, c_count);
+ else
+ /* Don't invoke `scm_c_read ()' since it may block. */
+ c_read = 0;
+
+ if ((c_read == 0) && (c_count > 0))
+ {
+ if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
+ result = SCM_EOF_VAL;
+ else
+ result = SCM_I_MAKINUM (0);
+ }
+ else
+ result = scm_from_size_t (c_read);
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
+ (SCM port),
+ "Read from @var{port}, blocking as necessary, until data "
+ "are available or and end-of-file is reached. Return either "
+ "a new bytevector containing the data read or the "
+ "end-of-file object.")
+#define FUNC_NAME s_scm_get_bytevector_some
+{
+ /* Read at least one byte, unless the end-of-file is already reached, and
+ read while characters are available (buffered). */
+
+ SCM result;
+ char *c_bv;
+ unsigned c_len;
+ size_t c_total;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ c_len = 4096;
+ c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
+ c_total = 0;
+
+ do
+ {
+ int c_chr;
+
+ if (c_total + 1 > c_len)
+ {
+ /* Grow the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
+ SCM_GC_BYTEVECTOR);
+ c_len *= 2;
+ }
+
+ /* We can't use `scm_c_read ()' since it blocks. */
+ c_chr = scm_getc (port);
+ if (c_chr != EOF)
+ {
+ c_bv[c_total] = (char) c_chr;
+ c_total++;
+ }
+ }
+ while ((scm_is_true (scm_char_ready_p (port)))
+ && (!SCM_EOF_OBJECT_P (scm_peek_char (port))));
+
+ if (c_total == 0)
+ {
+ result = SCM_EOF_VAL;
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ {
+ if (c_len > c_total)
+ {
+ /* Shrink the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
+ SCM_GC_BYTEVECTOR);
+ c_len = (unsigned) c_total;
+ }
+
+ result = scm_c_take_bytevector ((signed char *) c_bv, c_len);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
+ (SCM port),
+ "Read from @var{port}, blocking as necessary, until "
+ "the end-of-file is reached. Return either "
+ "a new bytevector containing the data read or the "
+ "end-of-file object (if no data were available).")
+#define FUNC_NAME s_scm_get_bytevector_all
+{
+ SCM result;
+ char *c_bv;
+ unsigned c_len, c_count;
+ size_t c_read, c_total;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ c_len = c_count = 4096;
+ c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
+ c_total = c_read = 0;
+
+ do
+ {
+ if (c_total + c_read > c_len)
+ {
+ /* Grow the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
+ SCM_GC_BYTEVECTOR);
+ c_count = c_len;
+ c_len *= 2;
+ }
+
+ /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
+ reached. */
+ c_read = scm_c_read (port, c_bv + c_total, c_count);
+ c_total += c_read, c_count -= c_read;
+ }
+ while (!SCM_EOF_OBJECT_P (scm_peek_char (port)));
+
+ if (c_total == 0)
+ {
+ result = SCM_EOF_VAL;
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ {
+ if (c_len > c_total)
+ {
+ /* Shrink the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
+ SCM_GC_BYTEVECTOR);
+ c_len = (unsigned) c_total;
+ }
+
+ result = scm_c_take_bytevector ((signed char *) c_bv, c_len);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+\f
+/* Binary output. */
+
+/* We currently don't support specific binary input ports. */
+#define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
+
+
+SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0,
+ (SCM port, SCM octet),
+ "Write @var{octet} to binary port @var{port}.")
+#define FUNC_NAME s_scm_put_u8
+{
+ scm_t_uint8 c_octet;
+
+ SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
+ c_octet = scm_to_uint8 (octet);
+
+ scm_putc ((char) c_octet, port);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0,
+ (SCM port, SCM bv, SCM start, SCM count),
+ "Write the contents of @var{bv} to @var{port}, optionally "
+ "starting at index @var{start} and limiting to @var{count} "
+ "octets.")
+#define FUNC_NAME s_scm_put_bytevector
+{
+ char *c_bv;
+ unsigned c_start, c_count, c_len;
+
+ SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
+ SCM_VALIDATE_BYTEVECTOR (2, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ if (start != SCM_UNDEFINED)
+ {
+ c_start = scm_to_uint (start);
+
+ if (count != SCM_UNDEFINED)
+ {
+ c_count = scm_to_uint (count);
+ if (SCM_UNLIKELY (c_start + c_count > c_len))
+ scm_out_of_range (FUNC_NAME, count);
+ }
+ else
+ {
+ if (SCM_UNLIKELY (c_start >= c_len))
+ scm_out_of_range (FUNC_NAME, start);
+ else
+ c_count = c_len - c_start;
+ }
+ }
+ else
+ c_start = 0, c_count = c_len;
+
+ scm_c_write (port, c_bv + c_start, c_count);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+\f
+/* Bytevector output port ("bop" for short). */
+
+/* Implementation of "bops".
+
+ Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
+ it. The procedure returned along with the output port is actually an
+ applicable SMOB. The SMOB holds a reference to the port. When applied,
+ the SMOB swallows the port's internal buffer, turning it into a
+ bytevector, and resets it.
+
+ XXX: Access to a bop's internal buffer is not thread-safe. */
+
+static scm_t_bits bytevector_output_port_type = 0;
+
+SCM_SMOB (bytevector_output_port_procedure,
+ "r6rs-bytevector-output-port-procedure",
+ 0);
+
+#define SCM_GC_BOP "r6rs-bytevector-output-port"
+#define SCM_BOP_BUFFER_INITIAL_SIZE 4096
+
+/* Representation of a bop's internal buffer. */
+typedef struct
+{
+ size_t total_len;
+ size_t len;
+ size_t pos;
+ char *buffer;
+} scm_t_bop_buffer;
+
+
+/* Accessing a bop's buffer. */
+#define SCM_BOP_BUFFER(_port) \
+ ((scm_t_bop_buffer *) SCM_STREAM (_port))
+#define SCM_SET_BOP_BUFFER(_port, _buf) \
+ (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
+
+
+static inline void
+bop_buffer_init (scm_t_bop_buffer *buf)
+{
+ buf->total_len = buf->len = buf->pos = 0;
+ buf->buffer = NULL;
+}
+
+static inline void
+bop_buffer_grow (scm_t_bop_buffer *buf, size_t min_size)
+{
+ char *new_buf;
+ size_t new_size;
+
+ for (new_size = buf->total_len
+ ? buf->total_len : SCM_BOP_BUFFER_INITIAL_SIZE;
+ new_size < min_size;
+ new_size *= 2);
+
+ if (buf->buffer)
+ new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len,
+ new_size, SCM_GC_BOP);
+ else
+ new_buf = scm_gc_malloc (new_size, SCM_GC_BOP);
+
+ buf->buffer = new_buf;
+ buf->total_len = new_size;
+}
+
+static inline SCM
+make_bop (void)
+{
+ SCM port, bop_proc;
+ scm_t_port *c_port;
+ scm_t_bop_buffer *buf;
+ const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
+
+ port = scm_new_port_table_entry (bytevector_output_port_type);
+
+ buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
+ bop_buffer_init (buf);
+
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
+ c_port->write_buf_size = 0;
+
+ SCM_SET_BOP_BUFFER (port, buf);
+
+ /* Mark PORT as open and writable. */
+ SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
+
+ /* Make the bop procedure. */
+ SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure,
+ SCM_PACK (port));
+
+ return (scm_values (scm_list_2 (port, bop_proc)));
+}
+
+static size_t
+bop_free (SCM port)
+{
+ /* The port itself is necessarily freed _after_ the bop proc, since the bop
+ proc holds a reference to it. Thus we can safely free the internal
+ buffer when the bop becomes unreferenced. */
+ scm_t_bop_buffer *buf;
+
+ buf = SCM_BOP_BUFFER (port);
+ if (buf->buffer)
+ scm_gc_free (buf->buffer, buf->total_len, SCM_GC_BOP);
+
+ scm_gc_free (buf, sizeof (* buf), SCM_GC_BOP);
+
+ return 0;
+}
+
+/* Write SIZE octets from DATA to PORT. */
+static void
+bop_write (SCM port, const void *data, size_t size)
+{
+ scm_t_bop_buffer *buf;
+
+ buf = SCM_BOP_BUFFER (port);
+
+ if (buf->pos + size > buf->total_len)
+ bop_buffer_grow (buf, buf->pos + size);
+
+ memcpy (buf->buffer + buf->pos, data, size);
+ buf->pos += size;
+ buf->len = (buf->len > buf->pos) ? buf->len : buf->pos;
+}
+
+static off_t
+bop_seek (SCM port, off_t offset, int whence)
+#define FUNC_NAME "bop_seek"
+{
+ scm_t_bop_buffer *buf;
+
+ buf = SCM_BOP_BUFFER (port);
+ switch (whence)
+ {
+ case SEEK_CUR:
+ offset += (off_t) buf->pos;
+ /* Fall through. */
+
+ case SEEK_SET:
+ if (offset < 0 || (unsigned) offset > buf->len)
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ else
+ buf->pos = offset;
+ break;
+
+ case SEEK_END:
+ if (offset < 0 || (unsigned) offset >= buf->len)
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ else
+ buf->pos = buf->len - (offset + 1);
+ break;
+
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "invalid `seek' parameter");
+ }
+
+ return buf->pos;
+}
+#undef FUNC_NAME
+
+/* Fetch data from a bop. */
+SCM_SMOB_APPLY (bytevector_output_port_procedure,
+ bop_proc_apply, 0, 0, 0, (SCM bop_proc))
+{
+ SCM port, bv;
+ scm_t_bop_buffer *buf, result_buf;
+
+ port = SCM_PACK (SCM_SMOB_DATA (bop_proc));
+ buf = SCM_BOP_BUFFER (port);
+
+ result_buf = *buf;
+ bop_buffer_init (buf);
+
+ if (result_buf.len == 0)
+ bv = scm_c_take_bytevector (NULL, 0);
+ else
+ {
+ if (result_buf.total_len > result_buf.len)
+ /* Shrink the buffer. */
+ result_buf.buffer = scm_gc_realloc ((void *) result_buf.buffer,
+ result_buf.total_len,
+ result_buf.len,
+ SCM_GC_BOP);
+
+ bv = scm_c_take_bytevector ((signed char *) result_buf.buffer,
+ result_buf.len);
+ }
+
+ return bv;
+}
+
+SCM_SMOB_MARK (bytevector_output_port_procedure, bop_proc_mark,
+ bop_proc)
+{
+ /* Mark the port associated with BOP_PROC. */
+ return (SCM_PACK (SCM_SMOB_DATA (bop_proc)));
+}
+
+
+SCM_DEFINE (scm_open_bytevector_output_port,
+ "open-bytevector-output-port", 0, 1, 0,
+ (SCM transcoder),
+ "Return two values: an output port and a procedure. The latter "
+ "should be called with zero arguments to obtain a bytevector "
+ "containing the data accumulated by the port.")
+#define FUNC_NAME s_scm_open_bytevector_output_port
+{
+ if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
+ transcoders_not_implemented ();
+
+ return (make_bop ());
+}
+#undef FUNC_NAME
+
+static inline void
+initialize_bytevector_output_ports (void)
+{
+ bytevector_output_port_type =
+ scm_make_port_type ("r6rs-bytevector-output-port",
+ NULL, bop_write);
+
+ scm_set_port_seek (bytevector_output_port_type, bop_seek);
+ scm_set_port_free (bytevector_output_port_type, bop_free);
+}
+
+\f
+/* Custom binary output port ("cbop" for short). */
+
+static scm_t_bits custom_binary_output_port_type;
+
+/* Return the various procedures of PORT. */
+#define SCM_CBOP_WRITE_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
+
+
+static inline SCM
+make_cbop (SCM write_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc)
+{
+ SCM port, method_vector;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
+
+ /* Store the various methods and bytevector in a vector. */
+ method_vector = scm_c_make_vector (4, SCM_BOOL_F);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 0, write_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
+
+ port = scm_new_port_table_entry (custom_binary_output_port_type);
+
+ /* Attach it the method vector. */
+ SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
+
+ /* Have the port directly access the buffer (bytevector). */
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
+ c_port->write_buf_size = c_port->read_buf_size = 0;
+
+ /* Mark PORT as open, writable and unbuffered. */
+ SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits);
+
+ return port;
+}
+
+/* Write SIZE octets from DATA to PORT. */
+static void
+cbop_write (SCM port, const void *data, size_t size)
+#define FUNC_NAME "cbop_write"
+{
+ long int c_result;
+ size_t c_written;
+ SCM bv, write_proc, result;
+
+ /* XXX: Allocating a new bytevector at each `write' call is inefficient,
+ but necessary since (1) we don't control the lifetime of the buffer
+ pointed to by DATA, and (2) the `write!' procedure could capture the
+ bytevector it is passed. */
+ bv = scm_c_make_bytevector (size);
+ memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size);
+
+ write_proc = SCM_CBOP_WRITE_PROC (port);
+
+ /* Since the `write' procedure of Guile's ports has type `void', it must
+ try hard to write exactly SIZE bytes, regardless of how many bytes the
+ sink can handle. */
+ for (c_written = 0;
+ c_written < size;
+ c_written += c_result)
+ {
+ result = scm_call_3 (write_proc, bv,
+ scm_from_size_t (c_written),
+ scm_from_size_t (size - c_written));
+
+ c_result = scm_to_long (result);
+ if (SCM_UNLIKELY (c_result < 0
+ || (size_t) c_result > (size - c_written)))
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, result,
+ "R6RS custom binary output port `write!' "
+ "returned a incorrect integer");
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_custom_binary_output_port,
+ "make-custom-binary-output-port", 5, 0, 0,
+ (SCM id, SCM write_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc),
+ "Return a new custom binary output port whose output is drained "
+ "by invoking @var{write_proc} and passing it a bytevector, an "
+ "index where octets should be written, and an octet count.")
+#define FUNC_NAME s_scm_make_custom_binary_output_port
+{
+ SCM_VALIDATE_STRING (1, id);
+ SCM_VALIDATE_PROC (2, write_proc);
+
+ if (!scm_is_false (get_position_proc))
+ SCM_VALIDATE_PROC (3, get_position_proc);
+
+ if (!scm_is_false (set_position_proc))
+ SCM_VALIDATE_PROC (4, set_position_proc);
+
+ if (!scm_is_false (close_proc))
+ SCM_VALIDATE_PROC (5, close_proc);
+
+ return (make_cbop (write_proc, get_position_proc, set_position_proc,
+ close_proc));
+}
+#undef FUNC_NAME
+
+
+/* Instantiate the custom binary output port type. */
+static inline void
+initialize_custom_binary_output_ports (void)
+{
+ custom_binary_output_port_type =
+ scm_make_port_type ("r6rs-custom-binary-output-port",
+ NULL, cbop_write);
+
+ scm_set_port_mark (custom_binary_output_port_type, cbp_mark);
+ scm_set_port_seek (custom_binary_output_port_type, cbp_seek);
+ scm_set_port_close (custom_binary_output_port_type, cbp_close);
+}
+
+\f
+/* Initialization. */
+
+void
+scm_init_r6rs_ports (void)
+{
+#include "r6rs-ports.x"
+
+ initialize_bytevector_input_ports ();
+ initialize_custom_binary_input_ports ();
+ initialize_bytevector_output_ports ();
+ initialize_custom_binary_output_ports ();
+}
diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h
new file mode 100644
index 0000000..e29d962
--- /dev/null
+++ b/libguile/r6rs-ports.h
@@ -0,0 +1,43 @@
+#ifndef SCM_R6RS_PORTS_H
+#define SCM_R6RS_PORTS_H
+
+/* Copyright (C) 2009 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 2.1 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+/* R6RS I/O Ports. */
+
+SCM_API SCM scm_eof_object (void);
+SCM_API SCM scm_open_bytevector_input_port (SCM, SCM);
+SCM_API SCM scm_make_custom_binary_input_port (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_get_u8 (SCM);
+SCM_API SCM scm_lookahead_u8 (SCM);
+SCM_API SCM scm_get_bytevector_n (SCM, SCM);
+SCM_API SCM scm_get_bytevector_n_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_get_bytevector_some (SCM);
+SCM_API SCM scm_get_bytevector_all (SCM);
+SCM_API SCM scm_put_u8 (SCM, SCM);
+SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_open_bytevector_output_port (SCM);
+SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM);
+
+SCM_API void scm_init_r6rs_ports (void);
+
+#endif /* SCM_R6RS_PORTS_H */
diff --git a/libguile/validate.h b/libguile/validate.h
index e05b7dd..c362c02 100644
--- a/libguile/validate.h
+++ b/libguile/validate.h
@@ -3,7 +3,7 @@
#ifndef SCM_VALIDATE_H
#define SCM_VALIDATE_H
-/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007 Free Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007, 2009 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
@@ -150,6 +150,9 @@
cvar = scm_to_bool (flag); \
} while (0)
+#define SCM_VALIDATE_BYTEVECTOR(_pos, _obj) \
+ SCM_VALIDATE_SMOB ((_pos), (_obj), bytevector)
+
#define SCM_VALIDATE_CHAR(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, CHARP, "character")
#define SCM_VALIDATE_CHAR_COPY(pos, scm, cvar) \
diff --git a/module/Makefile.am b/module/Makefile.am
index 95dc75a..d149bb6 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -31,7 +31,7 @@ modpath =
# putting these core modules first.
SOURCES = \
- ice-9/psyntax-pp.scm \
+ ice-9/psyntax-pp.scm \
system/base/pmatch.scm system/base/syntax.scm \
system/base/compile.scm system/base/language.scm \
\
@@ -53,6 +53,7 @@ SOURCES = \
\
$(ICE_9_SOURCES) \
$(SRFI_SOURCES) \
+ $(RNRS_SOURCES) \
$(OOP_SOURCES) \
\
$(SCRIPTS_SOURCES)
@@ -209,6 +210,10 @@ SRFI_SOURCES = \
srfi/srfi-69.scm \
srfi/srfi-88.scm
+RNRS_SOURCES = \
+ rnrs/bytevector.scm \
+ rnrs/io/ports.scm
+
EXTRA_DIST += scripts/ChangeLog-2008
EXTRA_DIST += scripts/README
diff --git a/module/rnrs/bytevector.scm b/module/rnrs/bytevector.scm
new file mode 100644
index 0000000..793cbc0
--- /dev/null
+++ b/module/rnrs/bytevector.scm
@@ -0,0 +1,84 @@
+;;;; bytevector.scm --- R6RS bytevector API
+
+;;;; Copyright (C) 2009 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 2.1 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
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+
+;;; Commentary:
+;;;
+;;; A "bytevector" is a raw bit string. This module provides procedures to
+;;; manipulate bytevectors and interpret their contents in a number of ways:
+;;; bytevector contents can be accessed as signed or unsigned integer of
+;;; various sizes and endianness, as IEEE-754 floating point numbers, or as
+;;; strings. It is a useful tool to decode binary data.
+;;;
+;;; Code:
+
+(define-module (rnrs bytevector)
+ :export-syntax (endianness)
+ :export (native-endianness bytevector?
+ make-bytevector bytevector-length bytevector=? bytevector-fill!
+ bytevector-copy! bytevector-copy bytevector-u8-ref
+ bytevector-s8-ref
+ bytevector-u8-set! bytevector-s8-set! bytevector->u8-list
+ u8-list->bytevector
+ bytevector-uint-ref bytevector-uint-set!
+ bytevector-sint-ref bytevector-sint-set!
+ bytevector->sint-list bytevector->uint-list
+ uint-list->bytevector sint-list->bytevector
+
+ bytevector-u16-ref bytevector-s16-ref
+ bytevector-u16-set! bytevector-s16-set!
+ bytevector-u16-native-ref bytevector-s16-native-ref
+ bytevector-u16-native-set! bytevector-s16-native-set!
+
+ bytevector-u32-ref bytevector-s32-ref
+ bytevector-u32-set! bytevector-s32-set!
+ bytevector-u32-native-ref bytevector-s32-native-ref
+ bytevector-u32-native-set! bytevector-s32-native-set!
+
+ bytevector-u64-ref bytevector-s64-ref
+ bytevector-u64-set! bytevector-s64-set!
+ bytevector-u64-native-ref bytevector-s64-native-ref
+ bytevector-u64-native-set! bytevector-s64-native-set!
+
+ bytevector-ieee-single-ref
+ bytevector-ieee-single-set!
+ bytevector-ieee-single-native-ref
+ bytevector-ieee-single-native-set!
+
+ bytevector-ieee-double-ref
+ bytevector-ieee-double-set!
+ bytevector-ieee-double-native-ref
+ bytevector-ieee-double-native-set!
+
+ string->utf8 string->utf16 string->utf32
+ utf8->string utf16->string utf32->string))
+
+
+(load-extension "libguile" "scm_init_bytevectors")
+
+(define-macro (endianness sym)
+ (if (memq sym '(big little))
+ `(quote ,sym)
+ (error "unsupported endianness" sym)))
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
+
+;;; bytevector.scm ends here
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
new file mode 100644
index 0000000..73843ee
--- /dev/null
+++ b/module/rnrs/io/ports.scm
@@ -0,0 +1,111 @@
+;;;; ports.scm --- R6RS port API
+
+;;;; Copyright (C) 2009 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 2.1 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
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+
+;;; Commentary:
+;;;
+;;; The I/O port API of the R6RS is provided by this module. In many areas
+;;; it complements or refines Guile's own historical port API. For instance,
+;;; it allows for binary I/O with bytevectors.
+;;;
+;;; Code:
+
+(define-module (rnrs io ports)
+ :re-export (eof-object? port? input-port? output-port?)
+ :export (eof-object
+
+ ;; input & output ports
+ port-transcoder binary-port? transcoded-port
+ port-position set-port-position!
+ port-has-port-position? port-has-set-port-position!?
+ call-with-port
+
+ ;; input ports
+ open-bytevector-input-port
+ make-custom-binary-input-port
+
+ ;; binary input
+ get-u8 lookahead-u8
+ get-bytevector-n get-bytevector-n!
+ get-bytevector-some get-bytevector-all
+
+ ;; output ports
+ open-bytevector-output-port
+ make-custom-binary-output-port
+
+ ;; binary output
+ put-u8 put-bytevector))
+
+(load-extension "libguile" "scm_init_r6rs_ports")
+
+
+\f
+;;;
+;;; Input and output ports.
+;;;
+
+(define (port-transcoder port)
+ (error "port transcoders are not supported" port))
+
+(define (binary-port? port)
+ ;; So far, we don't support transcoders other than the binary transcoder.
+ #t)
+
+(define (transcoded-port port)
+ (error "port transcoders are not supported" port))
+
+(define (port-position port)
+ "Return the offset (an integer) indicating where the next octet will be
+read from/written to in @var{port}."
+
+ ;; FIXME: We should raise an `&assertion' error when not supported.
+ (seek port 0 SEEK_CUR))
+
+(define (set-port-position! port offset)
+ "Set the position where the next octet will be read from/written to
+@var{port}."
+
+ ;; FIXME: We should raise an `&assertion' error when not supported.
+ (seek port offset SEEK_SET))
+
+(define (port-has-port-position? port)
+ "Return @code{#t} is @var{port} supports @code{port-position}."
+ (and (false-if-exception (port-position port)) #t))
+
+(define (port-has-set-port-position!? port)
+ "Return @code{#t} is @var{port} supports @code{set-port-position!}."
+ (and (false-if-exception (set-port-position! port (port-position port)))
+ #t))
+
+(define (call-with-port port proc)
+ "Call @var{proc}, passing it @var{port} and closing @var{port} upon exit of
+@var{proc}. Return the return values of @var{proc}."
+ (dynamic-wind
+ (lambda ()
+ #t)
+ (lambda ()
+ (proc port))
+ (lambda ()
+ (close-port port))))
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
+
+;;; ports.scm ends here
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 3854d4a..0b986d4 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -26,6 +26,7 @@ SCM_TESTS = tests/alist.test \
tests/arbiters.test \
tests/asm-to-bytecode.test \
tests/bit-operations.test \
+ tests/bytevectors.test \
tests/c-api.test \
tests/chars.test \
tests/common-list.test \
@@ -62,6 +63,7 @@ SCM_TESTS = tests/alist.test \
tests/q.test \
tests/r4rs.test \
tests/r5rs_pitfall.test \
+ tests/r6rs-ports.test \
tests/ramap.test \
tests/reader.test \
tests/receive.test \
diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test
new file mode 100644
index 0000000..b2ae65c
--- /dev/null
+++ b/test-suite/tests/bytevectors.test
@@ -0,0 +1,531 @@
+;;;; bytevectors.test --- Exercise the R6RS bytevector API.
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Ludovic Courtès
+;;;;
+;;;; 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 2.1 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
+
+(define-module (test-bytevector)
+ :use-module (test-suite lib)
+ :use-module (rnrs bytevector))
+
+;;; Some of the tests in here are examples taken from the R6RS Standard
+;;; Libraries document.
+
+\f
+(with-test-prefix "2.2 General Operations"
+
+ (pass-if "native-endianness"
+ (not (not (memq (native-endianness) '(big little)))))
+
+ (pass-if "make-bytevector"
+ (and (bytevector? (make-bytevector 20))
+ (bytevector? (make-bytevector 20 3))))
+
+ (pass-if "bytevector-length"
+ (= (bytevector-length (make-bytevector 20)) 20))
+
+ (pass-if "bytevector=?"
+ (and (bytevector=? (make-bytevector 20 7)
+ (make-bytevector 20 7))
+ (not (bytevector=? (make-bytevector 20 7)
+ (make-bytevector 20 0))))))
+
+\f
+(with-test-prefix "2.3 Operations on Bytes and Octets"
+
+ (pass-if "bytevector-{u8,s8}-ref"
+ (equal? '(-127 129 -1 255)
+ (let ((b1 (make-bytevector 16 -127))
+ (b2 (make-bytevector 16 255)))
+ (list (bytevector-s8-ref b1 0)
+ (bytevector-u8-ref b1 0)
+ (bytevector-s8-ref b2 0)
+ (bytevector-u8-ref b2 0)))))
+
+ (pass-if "bytevector-{u8,s8}-set!"
+ (equal? '(-126 130 -10 246)
+ (let ((b (make-bytevector 16 -127)))
+
+ (bytevector-s8-set! b 0 -126)
+ (bytevector-u8-set! b 1 246)
+
+ (list (bytevector-s8-ref b 0)
+ (bytevector-u8-ref b 0)
+ (bytevector-s8-ref b 1)
+ (bytevector-u8-ref b 1)))))
+
+ (pass-if "bytevector->u8-list"
+ (let ((lst '(1 2 3 128 150 255)))
+ (equal? lst
+ (bytevector->u8-list
+ (let ((b (make-bytevector 6)))
+ (for-each (lambda (i v)
+ (bytevector-u8-set! b i v))
+ (iota 6)
+ lst)
+ b)))))
+
+ (pass-if "u8-list->bytevector"
+ (let ((lst '(1 2 3 128 150 255)))
+ (equal? lst
+ (bytevector->u8-list (u8-list->bytevector lst)))))
+
+ (pass-if "bytevector-uint-{ref,set!} [small]"
+ (let ((b (make-bytevector 15)))
+ (bytevector-uint-set! b 0 #x1234
+ (endianness little) 2)
+ (equal? (bytevector-uint-ref b 0 (endianness big) 2)
+ #x3412)))
+
+ (pass-if "bytevector-uint-set! [large]"
+ (let ((b (make-bytevector 16)))
+ (bytevector-uint-set! b 0 (- (expt 2 128) 3)
+ (endianness little) 16)
+ (equal? (bytevector->u8-list b)
+ '(253 255 255 255 255 255 255 255
+ 255 255 255 255 255 255 255 255))))
+
+ (pass-if "bytevector-uint-{ref,set!} [large]"
+ (let ((b (make-bytevector 120)))
+ (bytevector-uint-set! b 0 (- (expt 2 128) 3)
+ (endianness little) 16)
+ (equal? (bytevector-uint-ref b 0 (endianness little) 16)
+ #xfffffffffffffffffffffffffffffffd)))
+
+ (pass-if "bytevector-sint-ref [small]"
+ (let ((b (u8-list->bytevector '(#xff #xf0 #xff))))
+ (equal? (bytevector-sint-ref b 0 (endianness big) 2)
+ (bytevector-sint-ref b 1 (endianness little) 2)
+ -16)))
+
+ (pass-if "bytevector-sint-ref [large]"
+ (let ((b (make-bytevector 50)))
+ (bytevector-uint-set! b 0 (- (expt 2 128) 3)
+ (endianness little) 16)
+ (equal? (bytevector-sint-ref b 0 (endianness little) 16)
+ -3)))
+
+ (pass-if "bytevector-sint-set! [small]"
+ (let ((b (make-bytevector 3)))
+ (bytevector-sint-set! b 0 -16 (endianness big) 2)
+ (bytevector-sint-set! b 1 -16 (endianness little) 2)
+ (equal? (bytevector->u8-list b)
+ '(#xff #xf0 #xff)))))
+
+\f
+(with-test-prefix "2.4 Operations on Integers of Arbitrary Size"
+
+ (pass-if "bytevector->sint-list"
+ (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
+ (equal? (bytevector->sint-list b (endianness little) 2)
+ '(513 -253 513 513))))
+
+ (pass-if "bytevector->uint-list"
+ (let ((b (u8-list->bytevector '(2 1 255 3 2 1 2 1))))
+ (equal? (bytevector->uint-list b (endianness big) 2)
+ '(513 65283 513 513))))
+
+ (pass-if "bytevector->uint-list [empty]"
+ (let ((b (make-bytevector 0)))
+ (null? (bytevector->uint-list b (endianness big) 2))))
+
+ (pass-if-exception "bytevector->sint-list [out-of-range]"
+ exception:out-of-range
+ (bytevector->sint-list (make-bytevector 6) (endianness little) 8))
+
+ (pass-if "bytevector->sint-list [off-by-one]"
+ (equal? (bytevector->sint-list (make-bytevector 31 #xff)
+ (endianness little) 8)
+ '(-1 -1 -1)))
+
+ (pass-if "{sint,uint}-list->bytevector"
+ (let ((b1 (sint-list->bytevector '(513 -253 513 513)
+ (endianness little) 2))
+ (b2 (uint-list->bytevector '(513 65283 513 513)
+ (endianness little) 2))
+ (b3 (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
+ (and (bytevector=? b1 b2)
+ (bytevector=? b2 b3))))
+
+ (pass-if "sint-list->bytevector [limits]"
+ (bytevector=? (sint-list->bytevector '(-32768 32767)
+ (endianness big) 2)
+ (let ((bv (make-bytevector 4)))
+ (bytevector-u8-set! bv 0 #x80)
+ (bytevector-u8-set! bv 1 #x00)
+ (bytevector-u8-set! bv 2 #x7f)
+ (bytevector-u8-set! bv 3 #xff)
+ bv)))
+
+ (pass-if-exception "sint-list->bytevector [out-of-range]"
+ exception:out-of-range
+ (sint-list->bytevector (list 0 0 (expt 2 16)) (endianness big)
+ 2))
+
+ (pass-if-exception "uint-list->bytevector [out-of-range]"
+ exception:out-of-range
+ (uint-list->bytevector '(0 -1) (endianness big) 2)))
+
+\f
+(with-test-prefix "2.5 Operations on 16-Bit Integers"
+
+ (pass-if "bytevector-u16-ref"
+ (let ((b (u8-list->bytevector
+ '(255 255 255 255 255 255 255 255
+ 255 255 255 255 255 255 255 253))))
+ (and (equal? (bytevector-u16-ref b 14 (endianness little))
+ #xfdff)
+ (equal? (bytevector-u16-ref b 14 (endianness big))
+ #xfffd))))
+
+ (pass-if "bytevector-s16-ref"
+ (let ((b (u8-list->bytevector
+ '(255 255 255 255 255 255 255 255
+ 255 255 255 255 255 255 255 253))))
+ (and (equal? (bytevector-s16-ref b 14 (endianness little))
+ -513)
+ (equal? (bytevector-s16-ref b 14 (endianness big))
+ -3))))
+
+ (pass-if "bytevector-s16-ref [unaligned]"
+ (let ((b (u8-list->bytevector '(#xff #xf0 #xff))))
+ (equal? (bytevector-s16-ref b 1 (endianness little))
+ -16)))
+
+ (pass-if "bytevector-{u16,s16}-ref"
+ (let ((b (make-bytevector 2)))
+ (bytevector-u16-set! b 0 44444 (endianness little))
+ (and (equal? (bytevector-u16-ref b 0 (endianness little))
+ 44444)
+ (equal? (bytevector-s16-ref b 0 (endianness little))
+ (- 44444 65536)))))
+
+ (pass-if "bytevector-native-{u16,s16}-{ref,set!}"
+ (let ((b (make-bytevector 2)))
+ (bytevector-u16-native-set! b 0 44444)
+ (and (equal? (bytevector-u16-native-ref b 0)
+ 44444)
+ (equal? (bytevector-s16-native-ref b 0)
+ (- 44444 65536)))))
+
+ (pass-if "bytevector-s16-{ref,set!} [unaligned]"
+ (let ((b (make-bytevector 3)))
+ (bytevector-s16-set! b 1 -77 (endianness little))
+ (equal? (bytevector-s16-ref b 1 (endianness little))
+ -77))))
+
+\f
+(with-test-prefix "2.6 Operations on 32-bit Integers"
+
+ (pass-if "bytevector-u32-ref"
+ (let ((b (u8-list->bytevector
+ '(255 255 255 255 255 255 255 255
+ 255 255 255 255 255 255 255 253))))
+ (and (equal? (bytevector-u32-ref b 12 (endianness little))
+ #xfdffffff)
+ (equal? (bytevector-u32-ref b 12 (endianness big))
+ #xfffffffd))))
+
+ (pass-if "bytevector-s32-ref"
+ (let ((b (u8-list->bytevector
+ '(255 255 255 255 255 255 255 255
+ 255 255 255 255 255 255 255 253))))
+ (and (equal? (bytevector-s32-ref b 12 (endianness little))
+ -33554433)
+ (equal? (bytevector-s32-ref b 12 (endianness big))
+ -3))))
+
+ (pass-if "bytevector-{u32,s32}-ref"
+ (let ((b (make-bytevector 4)))
+ (bytevector-u32-set! b 0 2222222222 (endianness little))
+ (and (equal? (bytevector-u32-ref b 0 (endianness little))
+ 2222222222)
+ (equal? (bytevector-s32-ref b 0 (endianness little))
+ (- 2222222222 (expt 2 32))))))
+
+ (pass-if "bytevector-{u32,s32}-native-{ref,set!}"
+ (let ((b (make-bytevector 4)))
+ (bytevector-u32-native-set! b 0 2222222222)
+ (and (equal? (bytevector-u32-native-ref b 0)
+ 2222222222)
+ (equal? (bytevector-s32-native-ref b 0)
+ (- 2222222222 (expt 2 32)))))))
+
+\f
+(with-test-prefix "2.7 Operations on 64-bit Integers"
+
+ (pass-if "bytevector-u64-ref"
+ (let ((b (u8-list->bytevector
+ '(255 255 255 255 255 255 255 255
+ 255 255 255 255 255 255 255 253))))
+ (and (equal? (bytevector-u64-ref b 8 (endianness little))
+ #xfdffffffffffffff)
+ (equal? (bytevector-u64-ref b 8 (endianness big))
+ #xfffffffffffffffd))))
+
+ (pass-if "bytevector-s64-ref"
+ (let ((b (u8-list->bytevector
+ '(255 255 255 255 255 255 255 255
+ 255 255 255 255 255 255 255 253))))
+ (and (equal? (bytevector-s64-ref b 8 (endianness little))
+ -144115188075855873)
+ (equal? (bytevector-s64-ref b 8 (endianness big))
+ -3))))
+
+ (pass-if "bytevector-{u64,s64}-ref"
+ (let ((b (make-bytevector 8))
+ (big 9333333333333333333))
+ (bytevector-u64-set! b 0 big (endianness little))
+ (and (equal? (bytevector-u64-ref b 0 (endianness little))
+ big)
+ (equal? (bytevector-s64-ref b 0 (endianness little))
+ (- big (expt 2 64))))))
+
+ (pass-if "bytevector-{u64,s64}-native-{ref,set!}"
+ (let ((b (make-bytevector 8))
+ (big 9333333333333333333))
+ (bytevector-u64-native-set! b 0 big)
+ (and (equal? (bytevector-u64-native-ref b 0)
+ big)
+ (equal? (bytevector-s64-native-ref b 0)
+ (- big (expt 2 64))))))
+
+ (pass-if "ref/set! with zero"
+ (let ((b (make-bytevector 8)))
+ (bytevector-s64-set! b 0 -1 (endianness big))
+ (bytevector-u64-set! b 0 0 (endianness big))
+ (= 0 (bytevector-u64-ref b 0 (endianness big))))))
+
+\f
+(with-test-prefix "2.8 Operations on IEEE-754 Representations"
+
+ (pass-if "bytevector-ieee-single-native-{ref,set!}"
+ (let ((b (make-bytevector 4))
+ (number 3.00))
+ (bytevector-ieee-single-native-set! b 0 number)
+ (equal? (bytevector-ieee-single-native-ref b 0)
+ number)))
+
+ (pass-if "bytevector-ieee-single-{ref,set!}"
+ (let ((b (make-bytevector 8))
+ (number 3.14))
+ (bytevector-ieee-single-set! b 0 number (endianness little))
+ (bytevector-ieee-single-set! b 4 number (endianness big))
+ (equal? (bytevector-ieee-single-ref b 0 (endianness little))
+ (bytevector-ieee-single-ref b 4 (endianness big)))))
+
+ (pass-if "bytevector-ieee-single-{ref,set!} [unaligned]"
+ (let ((b (make-bytevector 9))
+ (number 3.14))
+ (bytevector-ieee-single-set! b 1 number (endianness little))
+ (bytevector-ieee-single-set! b 5 number (endianness big))
+ (equal? (bytevector-ieee-single-ref b 1 (endianness little))
+ (bytevector-ieee-single-ref b 5 (endianness big)))))
+
+ (pass-if "bytevector-ieee-double-native-{ref,set!}"
+ (let ((b (make-bytevector 8))
+ (number 3.14))
+ (bytevector-ieee-double-native-set! b 0 number)
+ (equal? (bytevector-ieee-double-native-ref b 0)
+ number)))
+
+ (pass-if "bytevector-ieee-double-{ref,set!}"
+ (let ((b (make-bytevector 16))
+ (number 3.14))
+ (bytevector-ieee-double-set! b 0 number (endianness little))
+ (bytevector-ieee-double-set! b 8 number (endianness big))
+ (equal? (bytevector-ieee-double-ref b 0 (endianness little))
+ (bytevector-ieee-double-ref b 8 (endianness big))))))
+
+\f
+(define (with-locale locale thunk)
+ ;; Run THUNK under LOCALE.
+ (let ((original-locale (setlocale LC_ALL)))
+ (catch 'system-error
+ (lambda ()
+ (setlocale LC_ALL locale))
+ (lambda (key . args)
+ (throw 'unresolved)))
+
+ (dynamic-wind
+ (lambda ()
+ #t)
+ thunk
+ (lambda ()
+ (setlocale LC_ALL original-locale)))))
+
+(define (with-latin1-locale thunk)
+ ;; Try out several ISO-8859-1 locales and run THUNK under the one that
+ ;; works (if any).
+ (define %locales
+ (map (lambda (name)
+ (string-append name ".ISO-8859-1"))
+ '("fr_FR" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT")))
+
+ (let loop ((locales %locales))
+ (if (null? locales)
+ (throw 'unresolved)
+ (catch 'unresolved
+ (lambda ()
+ (with-locale (car locales) thunk))
+ (lambda (key . args)
+ (loop (cdr locales)))))))
+
+
+;; Default to the C locale for the following tests.
+(setlocale LC_ALL "C")
+
+
+(with-test-prefix "2.9 Operations on Strings"
+
+ (pass-if "string->utf8"
+ (let* ((str "hello, world")
+ (utf8 (string->utf8 str)))
+ (and (bytevector? utf8)
+ (= (bytevector-length utf8)
+ (string-length str))
+ (equal? (string->list str)
+ (map integer->char (bytevector->u8-list utf8))))))
+
+ (pass-if "string->utf8 [latin-1]"
+ (with-latin1-locale
+ (lambda ()
+ (let* ((str "hé, ça va bien ?")
+ (utf8 (string->utf8 str)))
+ (and (bytevector? utf8)
+ (= (bytevector-length utf8)
+ (+ 2 (string-length str))))))))
+
+ (pass-if "string->utf16"
+ (let* ((str "hello, world")
+ (utf16 (string->utf16 str)))
+ (and (bytevector? utf16)
+ (= (bytevector-length utf16)
+ (* 2 (string-length str)))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf16
+ (endianness big) 2))))))
+
+ (pass-if "string->utf16 [little]"
+ (let* ((str "hello, world")
+ (utf16 (string->utf16 str (endianness little))))
+ (and (bytevector? utf16)
+ (= (bytevector-length utf16)
+ (* 2 (string-length str)))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf16
+ (endianness little) 2))))))
+
+
+ (pass-if "string->utf32"
+ (let* ((str "hello, world")
+ (utf32 (string->utf32 str)))
+ (and (bytevector? utf32)
+ (= (bytevector-length utf32)
+ (* 4 (string-length str)))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf32
+ (endianness big) 4))))))
+
+ (pass-if "string->utf32 [little]"
+ (let* ((str "hello, world")
+ (utf32 (string->utf32 str (endianness little))))
+ (and (bytevector? utf32)
+ (= (bytevector-length utf32)
+ (* 4 (string-length str)))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf32
+ (endianness little) 4))))))
+
+ (pass-if "utf8->string"
+ (let* ((utf8 (u8-list->bytevector (map char->integer
+ (string->list "hello, world"))))
+ (str (utf8->string utf8)))
+ (and (string? str)
+ (= (string-length str)
+ (bytevector-length utf8))
+ (equal? (string->list str)
+ (map integer->char (bytevector->u8-list utf8))))))
+
+ (pass-if "utf8->string [latin-1]"
+ (with-latin1-locale
+ (lambda ()
+ (let* ((utf8 (string->utf8 "hé, ça va bien ?"))
+ (str (utf8->string utf8)))
+ (and (string? str)
+ (= (string-length str)
+ (- (bytevector-length utf8) 2)))))))
+
+ (pass-if "utf16->string"
+ (let* ((utf16 (uint-list->bytevector (map char->integer
+ (string->list "hello, world"))
+ (endianness big) 2))
+ (str (utf16->string utf16)))
+ (and (string? str)
+ (= (* 2 (string-length str))
+ (bytevector-length utf16))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf16 (endianness big)
+ 2))))))
+
+ (pass-if "utf16->string [little]"
+ (let* ((utf16 (uint-list->bytevector (map char->integer
+ (string->list "hello, world"))
+ (endianness little) 2))
+ (str (utf16->string utf16 (endianness little))))
+ (and (string? str)
+ (= (* 2 (string-length str))
+ (bytevector-length utf16))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf16 (endianness little)
+ 2))))))
+ (pass-if "utf32->string"
+ (let* ((utf32 (uint-list->bytevector (map char->integer
+ (string->list "hello, world"))
+ (endianness big) 4))
+ (str (utf32->string utf32)))
+ (and (string? str)
+ (= (* 4 (string-length str))
+ (bytevector-length utf32))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf32 (endianness big)
+ 4))))))
+
+ (pass-if "utf32->string [little]"
+ (let* ((utf32 (uint-list->bytevector (map char->integer
+ (string->list "hello, world"))
+ (endianness little) 4))
+ (str (utf32->string utf32 (endianness little))))
+ (and (string? str)
+ (= (* 4 (string-length str))
+ (bytevector-length utf32))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf32 (endianness little)
+ 4)))))))
+
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; mode: scheme
+;;; End:
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
new file mode 100644
index 0000000..204f371
--- /dev/null
+++ b/test-suite/tests/r6rs-ports.test
@@ -0,0 +1,455 @@
+;;;; r6rs-ports.test --- Exercise the R6RS I/O port API.
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Ludovic Courtès
+;;;;
+;;;; 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 2.1 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
+
+(define-module (test-io-ports)
+ :use-module (test-suite lib)
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-11)
+ :use-module (rnrs io ports)
+ :use-module (rnrs bytevector))
+
+;;; All these tests assume Guile 1.8's port system, where characters are
+;;; treated as octets.
+
+\f
+(with-test-prefix "7.2.5 End-of-File Object"
+
+ (pass-if "eof-object"
+ (and (eqv? (eof-object) (eof-object))
+ (eq? (eof-object) (eof-object)))))
+
+\f
+(with-test-prefix "7.2.8 Binary Input"
+
+ (pass-if "get-u8"
+ (let ((port (open-input-string "A")))
+ (and (= (char->integer #\A) (get-u8 port))
+ (eof-object? (get-u8 port)))))
+
+ (pass-if "lookahead-u8"
+ (let ((port (open-input-string "A")))
+ (and (= (char->integer #\A) (lookahead-u8 port))
+ (not (eof-object? port))
+ (= (char->integer #\A) (get-u8 port))
+ (eof-object? (get-u8 port)))))
+
+ (pass-if "get-bytevector-n [short]"
+ (let* ((port (open-input-string "GNU Guile"))
+ (bv (get-bytevector-n port 4)))
+ (and (bytevector? bv)
+ (equal? (bytevector->u8-list bv)
+ (map char->integer (string->list "GNU "))))))
+
+ (pass-if "get-bytevector-n [long]"
+ (let* ((port (open-input-string "GNU Guile"))
+ (bv (get-bytevector-n port 256)))
+ (and (bytevector? bv)
+ (equal? (bytevector->u8-list bv)
+ (map char->integer (string->list "GNU Guile"))))))
+
+ (pass-if-exception "get-bytevector-n with closed port"
+ exception:wrong-type-arg
+
+ (let ((port (%make-void-port "r")))
+
+ (close-port port)
+ (get-bytevector-n port 3)))
+
+ (pass-if "get-bytevector-n! [short]"
+ (let* ((port (open-input-string "GNU Guile"))
+ (bv (make-bytevector 4))
+ (read (get-bytevector-n! port bv 0 4)))
+ (and (equal? read 4)
+ (equal? (bytevector->u8-list bv)
+ (map char->integer (string->list "GNU "))))))
+
+ (pass-if "get-bytevector-n! [long]"
+ (let* ((str "GNU Guile")
+ (port (open-input-string str))
+ (bv (make-bytevector 256))
+ (read (get-bytevector-n! port bv 0 256)))
+ (and (equal? read (string-length str))
+ (equal? (map (lambda (i)
+ (bytevector-u8-ref bv i))
+ (iota read))
+ (map char->integer (string->list str))))))
+
+ (pass-if "get-bytevector-some [simple]"
+ (let* ((str "GNU Guile")
+ (port (open-input-string str))
+ (bv (get-bytevector-some port)))
+ (and (bytevector? bv)
+ (equal? (bytevector->u8-list bv)
+ (map char->integer (string->list str))))))
+
+ (pass-if "get-bytevector-some [only-some]"
+ (let* ((str "GNU Guile")
+ (index 0)
+ (port (make-soft-port
+ (vector #f #f #f
+ (lambda ()
+ (if (>= index (string-length str))
+ (eof-object)
+ (let ((c (string-ref str index)))
+ (set! index (+ index 1))
+ c)))
+ (lambda () #t)
+ (lambda ()
+ ;; Number of readily available octets: falls to
+ ;; zero after 4 octets have been read.
+ (- 4 (modulo index 5))))
+ "r"))
+ (bv (get-bytevector-some port)))
+ (and (bytevector? bv)
+ (= index 4)
+ (= (bytevector-length bv) index)
+ (equal? (bytevector->u8-list bv)
+ (map char->integer (string->list "GNU "))))))
+
+ (pass-if "get-bytevector-all"
+ (let* ((str "GNU Guile")
+ (index 0)
+ (port (make-soft-port
+ (vector #f #f #f
+ (lambda ()
+ (if (>= index (string-length str))
+ (eof-object)
+ (let ((c (string-ref str index)))
+ (set! index (+ index 1))
+ c)))
+ (lambda () #t)
+ (let ((cont? #f))
+ (lambda ()
+ ;; Number of readily available octets: falls to
+ ;; zero after 4 octets have been read and then
+ ;; starts again.
+ (let ((a (if cont?
+ (- (string-length str) index)
+ (- 4 (modulo index 5)))))
+ (if (= 0 a) (set! cont? #t))
+ a))))
+ "r"))
+ (bv (get-bytevector-all port)))
+ (and (bytevector? bv)
+ (= index (string-length str))
+ (= (bytevector-length bv) (string-length str))
+ (equal? (bytevector->u8-list bv)
+ (map char->integer (string->list str)))))))
+
+\f
+(define (make-soft-output-port)
+ (let* ((bv (make-bytevector 1024))
+ (read-index 0)
+ (write-index 0)
+ (write-char (lambda (chr)
+ (bytevector-u8-set! bv write-index
+ (char->integer chr))
+ (set! write-index (+ 1 write-index)))))
+ (make-soft-port
+ (vector write-char
+ (lambda (str) ;; write-string
+ (for-each write-char (string->list str)))
+ (lambda () #t) ;; flush-output
+ (lambda () ;; read-char
+ (if (>= read-index (bytevector-length bv))
+ (eof-object)
+ (let ((c (bytevector-u8-ref bv read-index)))
+ (set! read-index (+ read-index 1))
+ (integer->char c))))
+ (lambda () #t)) ;; close-port
+ "rw")))
+
+(with-test-prefix "7.2.11 Binary Output"
+
+ (pass-if "put-u8"
+ (let ((port (make-soft-output-port)))
+ (put-u8 port 77)
+ (equal? (get-u8 port) 77)))
+
+ (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))))))
+
+ (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))))))
+
+ (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)))))
+
+ (pass-if-exception "put-bytevector with closed port"
+ exception:wrong-type-arg
+
+ (let* ((bv (make-bytevector 4))
+ (port (%make-void-port "w")))
+
+ (close-port port)
+ (put-bytevector port bv))))
+
+\f
+(with-test-prefix "7.2.7 Input Ports"
+
+ ;; This section appears here so that it can use the binary input
+ ;; primitives.
+
+ (pass-if "open-bytevector-input-port [1 arg]"
+ (let* ((str "Hello Port!")
+ (bv (u8-list->bytevector (map char->integer
+ (string->list str))))
+ (port (open-bytevector-input-port bv))
+ (read-to-string
+ (lambda (port)
+ (let loop ((chr (read-char port))
+ (result '()))
+ (if (eof-object? chr)
+ (apply string (reverse! result))
+ (loop (read-char port)
+ (cons chr result)))))))
+
+ (equal? (read-to-string port) str)))
+
+ (pass-if-exception "bytevector-input-port is read-only"
+ exception:wrong-type-arg
+
+ (let* ((str "Hello Port!")
+ (bv (u8-list->bytevector (map char->integer
+ (string->list str))))
+ (port (open-bytevector-input-port bv #f)))
+
+ (write "hello" port)))
+
+ (pass-if "bytevector input port supports seeking"
+ (let* ((str "Hello Port!")
+ (bv (u8-list->bytevector (map char->integer
+ (string->list str))))
+ (port (open-bytevector-input-port bv #f)))
+
+ (and (port-has-port-position? port)
+ (= 0 (port-position port))
+ (port-has-set-port-position!? port)
+ (begin
+ (set-port-position! port 6)
+ (= 6 (port-position port)))
+ (bytevector=? (get-bytevector-all port)
+ (u8-list->bytevector
+ (map char->integer (string->list "Port!")))))))
+
+ (pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
+ exception:wrong-num-args
+
+ ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully
+ ;; optional.
+ (make-custom-binary-input-port "port" (lambda args #t)))
+
+ (pass-if "make-custom-binary-input-port"
+ (let* ((source (make-bytevector 7777))
+ (read! (let ((pos 0)
+ (len (bytevector-length source)))
+ (lambda (bv start count)
+ (let ((amount (min count (- len pos))))
+ (if (> amount 0)
+ (bytevector-copy! source pos
+ bv start amount))
+ (set! pos (+ pos amount))
+ amount))))
+ (port (make-custom-binary-input-port "the port" read!
+ #f #f #f)))
+
+ (bytevector=? (get-bytevector-all port) source)))
+
+ (pass-if "custom binary input port does not support `port-position'"
+ (let* ((str "Hello Port!")
+ (source (open-bytevector-input-port
+ (u8-list->bytevector
+ (map char->integer (string->list str)))))
+ (read! (lambda (bv start count)
+ (let ((r (get-bytevector-n! source bv start count)))
+ (if (eof-object? r)
+ 0
+ r))))
+ (port (make-custom-binary-input-port "the port" read!
+ #f #f #f)))
+ (not (or (port-has-port-position? port)
+ (port-has-set-port-position!? port)))))
+
+ (pass-if "custom binary input port supports `port-position'"
+ (let* ((str "Hello Port!")
+ (source (open-bytevector-input-port
+ (u8-list->bytevector
+ (map char->integer (string->list str)))))
+ (read! (lambda (bv start count)
+ (let ((r (get-bytevector-n! source bv start count)))
+ (if (eof-object? r)
+ 0
+ r))))
+ (get-pos (lambda ()
+ (port-position source)))
+ (set-pos! (lambda (pos)
+ (set-port-position! source pos)))
+ (port (make-custom-binary-input-port "the port" read!
+ get-pos set-pos! #f)))
+
+ (and (port-has-port-position? port)
+ (= 0 (port-position port))
+ (port-has-set-port-position!? port)
+ (begin
+ (set-port-position! port 6)
+ (= 6 (port-position port)))
+ (bytevector=? (get-bytevector-all port)
+ (u8-list->bytevector
+ (map char->integer (string->list "Port!")))))))
+
+ (pass-if "custom binary input port `close-proc' is called"
+ (let* ((closed? #f)
+ (read! (lambda (bv start count) 0))
+ (get-pos (lambda () 0))
+ (set-pos! (lambda (pos) #f))
+ (close! (lambda () (set! closed? #t)))
+ (port (make-custom-binary-input-port "the port" read!
+ get-pos set-pos!
+ close!)))
+
+ (close-port port)
+ closed?)))
+
+\f
+(with-test-prefix "8.2.10 Output ports"
+
+ (pass-if "open-bytevector-output-port"
+ (let-values (((port get-content)
+ (open-bytevector-output-port #f)))
+ (let ((source (make-bytevector 7777)))
+ (put-bytevector port source)
+ (and (bytevector=? (get-content) source)
+ (bytevector=? (get-content) (make-bytevector 0))))))
+
+ (pass-if "open-bytevector-output-port [put-u8]"
+ (let-values (((port get-content)
+ (open-bytevector-output-port)))
+ (put-u8 port 77)
+ (and (bytevector=? (get-content) (make-bytevector 1 77))
+ (bytevector=? (get-content) (make-bytevector 0)))))
+
+ (pass-if "open-bytevector-output-port [display]"
+ (let-values (((port get-content)
+ (open-bytevector-output-port)))
+ (display "hello" port)
+ (and (bytevector=? (get-content) (string->utf8 "hello"))
+ (bytevector=? (get-content) (make-bytevector 0)))))
+
+ (pass-if "bytevector output port supports `port-position'"
+ (let-values (((port get-content)
+ (open-bytevector-output-port)))
+ (let ((source (make-bytevector 7777))
+ (overwrite (make-bytevector 33)))
+ (and (port-has-port-position? port)
+ (port-has-set-port-position!? port)
+ (begin
+ (put-bytevector port source)
+ (= (bytevector-length source)
+ (port-position port)))
+ (begin
+ (set-port-position! port 10)
+ (= 10 (port-position port)))
+ (begin
+ (put-bytevector port overwrite)
+ (bytevector-copy! overwrite 0 source 10
+ (bytevector-length overwrite))
+ (= (port-position port)
+ (+ 10 (bytevector-length overwrite))))
+ (bytevector=? (get-content) source)
+ (bytevector=? (get-content) (make-bytevector 0))))))
+
+ (pass-if "make-custom-binary-output"
+ (let ((port (make-custom-binary-output-port "cbop"
+ (lambda (x y z) 0)
+ #f #f #f)))
+ (and (output-port? port)
+ (binary-port? port)
+ (not (port-has-port-position? port))
+ (not (port-has-set-port-position!? port)))))
+
+ (pass-if "make-custom-binary-output-port [partial writes]"
+ (let* ((source (uint-list->bytevector (iota 333)
+ (native-endianness) 2))
+ (sink (make-bytevector (bytevector-length source)))
+ (sink-pos 0)
+ (eof? #f)
+ (write! (lambda (bv start count)
+ (if (= 0 count)
+ (begin
+ (set! eof? #t)
+ 0)
+ (let ((u8 (bytevector-u8-ref bv start)))
+ ;; Get one byte at a time.
+ (bytevector-u8-set! sink sink-pos u8)
+ (set! sink-pos (+ 1 sink-pos))
+ 1))))
+ (port (make-custom-binary-output-port "cbop" write!
+ #f #f #f)))
+ (put-bytevector port source)
+ (and (= sink-pos (bytevector-length source))
+ (not eof?)
+ (bytevector=? sink source))))
+
+ (pass-if "make-custom-binary-output-port [full writes]"
+ (let* ((source (uint-list->bytevector (iota 333)
+ (native-endianness) 2))
+ (sink (make-bytevector (bytevector-length source)))
+ (sink-pos 0)
+ (eof? #f)
+ (write! (lambda (bv start count)
+ (if (= 0 count)
+ (begin
+ (set! eof? #t)
+ 0)
+ (begin
+ (bytevector-copy! bv start
+ sink sink-pos
+ count)
+ (set! sink-pos (+ sink-pos count))
+ count))))
+ (port (make-custom-binary-output-port "cbop" write!
+ #f #f #f)))
+ (put-bytevector port source)
+ (and (= sink-pos (bytevector-length source))
+ (not eof?)
+ (bytevector=? sink source)))))
+
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; mode: scheme
+;;; End:
--
1.6.1.3
[-- Attachment #2: Type: application/pgp-signature, Size: 197 bytes --]
next prev parent reply other threads:[~2009-05-27 22:27 UTC|newest]
Thread overview: 22+ messages / expand[flat|nested] mbox.gz Atom feed top
2009-04-21 21:18 Merging Guile-R6RS-Libs in `master' Ludovic Courtès
2009-04-21 21:45 ` Julian Graham
2009-04-22 7:55 ` Ludovic Courtès
2009-04-22 14:55 ` Julian Graham
2009-04-22 15:53 ` Ludovic Courtès
2009-04-22 18:32 ` Julian Graham
2009-04-22 19:52 ` Andy Wingo
2009-04-22 20:09 ` Ludovic Courtès
2009-04-22 20:22 ` Julian Graham
2009-04-22 21:53 ` Andy Wingo
2009-04-22 19:08 ` Andy Wingo
2009-04-22 19:57 ` Ludovic Courtès
2009-04-22 19:07 ` Andy Wingo
2009-04-22 19:51 ` Ludovic Courtès
2009-04-22 20:10 ` Julian Graham
2009-04-21 21:58 ` Andy Wingo
2009-04-22 8:04 ` Ludovic Courtès
2009-05-27 22:27 ` Ludovic Courtès [this message]
2009-05-28 17:52 ` Andy Wingo
2009-05-28 19:16 ` Ludovic Courtès
2009-05-28 21:25 ` Ludovic Courtès
2009-05-29 9:02 ` Andy Wingo
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87ws829o6d.fsf@gnu.org \
--to=ludo@gnu.org \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).