mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Import R6RS bytevectors and I/O ports from Guile-R6RS-Libs 0.2.

Browse source 
* 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'.
This commit is contained in:
Ludovic Courtès 2009-05-27 18:18:07 +02:00
parent 24d56127bb
commit 1ee2c72eaf
18 changed files with 4688 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

6
README
View file

@ -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 =====================================

1
benchmark-suite/Makefile.am
View file

@ -1,4 +1,5 @@
SCM_BENCHMARKS = benchmarks/0-reference.bm \
benchmarks/bytevectors.bm \
benchmarks/continuations.bm \
benchmarks/if.bm \
benchmarks/logand.bm \

99
benchmark-suite/benchmarks/bytevectors.bm Normal file
View file

@ -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))
(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)))
(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)))
(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)))

7
configure.in
View file

@ -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)

4
libguile.h
View file

@ -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"

26
libguile/Makefile.am
View file

@ -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 \

1978
libguile/bytevectors.c Normal file
View file

File diff suppressed because it is too large Load diff

133
libguile/bytevectors.h Normal file
View file

@ -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
*/
#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);
/* 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 */

90
libguile/ieee-754.h Normal file
View file

@ -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. */
/* 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;
};
/* 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 */

1118
libguile/r6rs-ports.c Normal file
View file

File diff suppressed because it is too large Load diff

43
libguile/r6rs-ports.h Normal file
View file

@ -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
*/
#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 */

5
libguile/validate.h
View file

@ -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) \

5
module/Makefile.am
View file

@ -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

84
module/rnrs/bytevector.scm Normal file
View file

@ -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

111
module/rnrs/io/ports.scm Normal file
View file

@ -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")
;;;
;;; 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

2
test-suite/Makefile.am
View file

@ -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 \

531
test-suite/tests/bytevectors.test Normal file
View file

@ -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.
(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))))))
(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)))))
(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)))
(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))))
(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)))))))
(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))))))
(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))))))
(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:

455
test-suite/tests/r6rs-ports.test Normal file
View file

@ -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.
(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)))))
(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)))))))
(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))))
(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?)))
(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: