From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: ludo@gnu.org (Ludovic =?iso-8859-1?Q?Court=E8s?=) Newsgroups: gmane.lisp.guile.devel Subject: Re: Merging Guile-R6RS-Libs in `master' Date: Thu, 28 May 2009 00:27:38 +0200 Message-ID: <87ws829o6d.fsf@gnu.org> References: <873ac1wvs1.fsf@gnu.org> <877i1d3yi2.fsf@gnu.org> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/signed; boundary="==-=-="; micalg=pgp-sha1; protocol="application/pgp-signature" X-Trace: ger.gmane.org 1243463355 12829 80.91.229.12 (27 May 2009 22:29:15 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Wed, 27 May 2009 22:29:15 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Thu May 28 00:29:10 2009 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.50) id 1M9Rbj-0003Xg-9Q for guile-devel@m.gmane.org; Thu, 28 May 2009 00:29:10 +0200 Original-Received: from localhost ([127.0.0.1]:46336 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1M9Rbi-0007le-IQ for guile-devel@m.gmane.org; Wed, 27 May 2009 18:28:22 -0400 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.43) id 1M9Rbc-0007lE-CI for guile-devel@gnu.org; Wed, 27 May 2009 18:28:16 -0400 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.43) id 1M9RbW-0007gr-Pd for guile-devel@gnu.org; Wed, 27 May 2009 18:28:14 -0400 Original-Received: from [199.232.76.173] (port=47122 helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1M9RbW-0007gY-Ki for guile-devel@gnu.org; Wed, 27 May 2009 18:28:10 -0400 Original-Received: from main.gmane.org ([80.91.229.2]:36442 helo=ciao.gmane.org) by monty-python.gnu.org with esmtps (TLS-1.0:RSA_AES_256_CBC_SHA1:32) (Exim 4.60) (envelope-from ) id 1M9RbU-0005nR-1r for guile-devel@gnu.org; Wed, 27 May 2009 18:28:10 -0400 Original-Received: from list by ciao.gmane.org with local (Exim 4.43) id 1M9RbO-0001ON-PP for guile-devel@gnu.org; Wed, 27 May 2009 22:28:02 +0000 Original-Received: from reverse-83.fdn.fr ([80.67.176.83]) by main.gmane.org with esmtp (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Wed, 27 May 2009 22:28:02 +0000 Original-Received: from ludo by reverse-83.fdn.fr with local (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Wed, 27 May 2009 22:28:02 +0000 X-Injected-Via-Gmane: http://gmane.org/ Original-Lines: 5108 Original-X-Complaints-To: usenet@ger.gmane.org X-Gmane-NNTP-Posting-Host: reverse-83.fdn.fr X-URL: http://www.fdn.fr/~lcourtes/ X-Revolutionary-Date: 9 Prairial an 217 de la =?iso-8859-1?Q?R=E9volution?= X-PGP-Key-ID: 0xEA52ECF4 X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 821D 815D 902A 7EAB 5CEE D120 7FBA 3D4F EB1F 5364 X-OS: i686-pc-linux-gnu User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/23.0.90 (gnu/linux) Cancel-Lock: sha1:KLW8pjClAGoZ53Hqillcl5kxc2Y= X-detected-operating-system: by monty-python.gnu.org: GNU/Linux 2.6, seldom 2.4 (older, 4) X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:8538 Archived-At: --==-=-= Content-Type: multipart/mixed; boundary="=-=-=" --=-=-= 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'. --=-=-= Content-Type: text/x-patch; charset=iso-8859-1 Content-Disposition: inline; filename=0001-Import-R6RS-bytevectors-and-I-O-ports-from-Guile-R6R.patch Content-Transfer-Encoding: quoted-printable Content-Description: The patch From=2049e92cb7e629792fd670ac5b6a23cdba9641658d Mon Sep 17 00:00:00 2001 From: =3D?utf-8?q?Ludovic=3D20Court=3DC3=3DA8s?=3D 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'. =2D-- 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 =2D-- 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/ =20 + - 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/ . + =20 Special Instructions For Some Systems =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D =20 diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am index e65e8bc..dcadd58 100644 =2D-- a/benchmark-suite/Makefile.am +++ b/benchmark-suite/Makefile.am @@ -1,4 +1,5 @@ SCM_BENCHMARKS =3D 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/be= nchmarks/bytevectors.bm new file mode 100644 index 0000000..9547a71 =2D-- /dev/null +++ b/benchmark-suite/benchmarks/bytevectors.bm @@ -0,0 +1,99 @@ +;;; -*- mode: scheme; coding: latin-1; -*- +;;; R6RS Byte Vectors. +;;; +;;; Copyright 2009 Ludovic Court=E8s +;;; +;;; +;;; 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))) diff --git a/configure.in b/configure.in index 07c4766..6568e52 100644 =2D-- a/configure.in +++ b/configure.in @@ -836,6 +836,13 @@ AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include ]], [], [AC_MSG_ERROR([At least GNU MP 4.1 is required, see README])]) =20 +dnl GNU libunistring tests. +if test "x$LTLIBUNISTRING" !=3D "x"; then + LIBS=3D"$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 =2D-- a/libguile.h +++ b/libguile.h @@ -1,7 +1,7 @@ #ifndef SCM_LIBGUILE_H #define SCM_LIBGUILE_H =20 =2D/* 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, 20= 08, 2009 Free Software Foundation, Inc. *=20 * 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 =2D-- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -106,7 +106,8 @@ guile_LDFLAGS =3D $(GUILE_CFLAGS) libguile_la_CFLAGS =3D $(GUILE_CFLAGS) $(AM_CFLAGS) =20 libguile_la_SOURCES =3D alist.c arbiters.c async.c backtrace.c boolean.c \ =2D 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 =3D alist.c arbiters.c async.c back= trace.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 \ =2D 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 =3D \ -module -L$(builddir) -lguile \ -version-info @LIBGUILE_I18N_INTERFACE@ =20 =2DDOT_X_FILES =3D alist.x arbiters.x async.x backtrace.x boolean.x chars.x= \ +DOT_X_FILES =3D 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 =3D 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 \ =2D 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 +=3D frames.x instructions.x objcodes.x pro= grams.x vm.x EXTRA_DOT_X_FILES =3D @EXTRA_DOT_X_FILES@ =20 DOT_DOC_FILES =3D alist.doc arbiters.doc async.doc backtrace.doc \ =2D 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 =3D alist.doc arbiters.doc async.doc back= trace.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 \ =2D 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 =3D convert.i.c \ conv-integer.i.c conv-uinteger.i.c \ =2D 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 =3D # These are headers visible as . modincludedir =3D $(includedir)/libguile modinclude_HEADERS =3D __scm.h alist.h arbiters.h async.h backtrace.h \ =2D 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 =3D __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 \ =2D 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 =2D-- /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-130= 1 USA + */ + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include + +#include + +#include "libguile/_scm.h" +#include "libguile/bytevectors.h" +#include "libguile/strings.h" +#include "libguile/validate.h" +#include "libguile/ieee-754.h" + +#include +#include +#include + +#ifdef HAVE_LIMITS_H +# include +#else +/* Assuming 32-bit longs. */ +# define ULONG_MAX 4294967295UL +#endif + +#include + + + +/* Utilities. */ + +/* Convenience macros. These are used by the various templates (macros) t= hat + 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) >=3D -128L) && ((_x) <=3D 127L)) +#define is_unsigned_int8(_x) ((_x) <=3D 255UL) +#define is_signed_int16(_x) (((_x) >=3D -32768L) && ((_x) <=3D 32767L)) +#define is_unsigned_int16(_x) ((_x) <=3D 65535UL) +#define is_signed_int32(_x) (((_x) >=3D -2147483648L) && ((_x) <=3D 21= 47483647L)) +#define is_unsigned_int32(_x) ((_x) <=3D 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 =3D scm_to_uint (index); \ + \ + c_len =3D SCM_BYTEVECTOR_LENGTH (bv); \ + c_bv =3D (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >=3D 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 =3D INT_SWAP (_len) (c_result); \ + \ + result =3D 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 =3D 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 =3D SCM_I_INUM (value); \ + if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \ + scm_out_of_range (FUNC_NAME, value); \ + \ + c_value_short =3D (INT_TYPE (_len, _sign)) c_value; \ + if (!scm_is_eq (endianness, native_endianness)) \ + c_value_short =3D 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 =3D SCM_I_INUM (value); \ + if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \ + scm_out_of_range (FUNC_NAME, value); \ + \ + c_value_short =3D (INT_TYPE (_len, _sign)) c_value; \ + \ + memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \ + } \ + \ + return SCM_UNSPECIFIED; + + + +/* 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 =3D 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 =3D=3D 0)) + bv =3D scm_null_bytevector; + else + { + signed char *contents =3D NULL; + + if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len)) + contents =3D (signed char *) scm_gc_malloc (len, SCM_GC_BYTEVECTOR); + + bv =3D 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 =3D make_bytevector (len); + c_bv =3D SCM_BYTEVECTOR_CONTENTS (bv); + memcpy (c_bv, contents, len); + scm_gc_free (contents, len, SCM_GC_BYTEVECTOR); + } + else + bv =3D 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 =3D SCM_BYTEVECTOR_LENGTH (bv); + c_bv =3D 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 =3D 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 =3D 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 =3D SCM_BYTEVECTOR_LENGTH (bv); + c_bv =3D (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + + scm_puts ("#vu8(", port); + for (i =3D 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 =3D SCM_BYTEVECTOR_CONTENTS (bv); + c_len =3D SCM_BYTEVECTOR_LENGTH (bv); + + scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + } + + return 0; +} + + + +/* 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 =3D 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 =3D '\0'; + + SCM_VALIDATE_UINT_COPY (1, len, c_len); + if (fill !=3D SCM_UNDEFINED) + { + int value; + + value =3D scm_to_int (fill); + if (SCM_UNLIKELY ((value < -128) || (value > 255))) + scm_out_of_range (FUNC_NAME, fill); + c_fill =3D (signed char) value; + } + + bv =3D make_bytevector (c_len); + if (fill !=3D SCM_UNDEFINED) + { + unsigned i; + signed char *contents; + + contents =3D SCM_BYTEVECTOR_CONTENTS (bv); + for (i =3D 0; i < c_len; i++) + contents[i] =3D 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=3D?", 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 =3D SCM_BOOL_F; + unsigned c_len1, c_len2; + + SCM_VALIDATE_BYTEVECTOR (1, bv1); + SCM_VALIDATE_BYTEVECTOR (2, bv2); + + c_len1 =3D SCM_BYTEVECTOR_LENGTH (bv1); + c_len2 =3D SCM_BYTEVECTOR_LENGTH (bv2); + + if (c_len1 =3D=3D c_len2) + { + signed char *c_bv1, *c_bv2; + + c_bv1 =3D SCM_BYTEVECTOR_CONTENTS (bv1); + c_bv2 =3D SCM_BYTEVECTOR_CONTENTS (bv2); + + result =3D 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 =3D scm_to_int8 (fill); + + c_len =3D SCM_BYTEVECTOR_LENGTH (bv); + c_bv =3D SCM_BYTEVECTOR_CONTENTS (bv); + + for (i =3D 0; i < c_len; i++) + c_bv[i] =3D 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 =3D scm_to_uint (len); + c_source_start =3D scm_to_uint (source_start); + c_target_start =3D scm_to_uint (target_start); + + c_source =3D SCM_BYTEVECTOR_CONTENTS (source); + c_target =3D SCM_BYTEVECTOR_CONTENTS (target); + c_source_len =3D SCM_BYTEVECTOR_LENGTH (source); + c_target_len =3D 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 =3D SCM_BYTEVECTOR_LENGTH (bv); + c_bv =3D SCM_BYTEVECTOR_CONTENTS (bv); + + copy =3D make_bytevector (c_len); + c_copy =3D SCM_BYTEVECTOR_CONTENTS (copy); + memcpy (c_copy, c_bv, c_len); + + return copy; +} +#undef FUNC_NAME + + +/* 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 =3D SCM_BYTEVECTOR_LENGTH (bv); + c_bv =3D (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + + lst =3D scm_make_list (scm_from_uint (c_len), SCM_UNSPECIFIED); + for (i =3D 0, pair =3D lst; + i < c_len; + i++, pair =3D 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 =3D make_bytevector (c_len); + c_bv =3D (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + + for (i =3D 0; i < c_len; lst =3D SCM_CDR (lst), i++) + { + item =3D SCM_CAR (lst); + + if (SCM_LIKELY (SCM_I_INUMP (item))) + { + long c_item; + + c_item =3D SCM_I_INUM (item); + if (SCM_LIKELY ((c_item >=3D 0) && (c_item < 256))) + c_bv[i] =3D (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 octe= ts + 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 =3D (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 =3D 0; + + if (signed_p) + { + if (scm_is_eq (endianness, scm_sym_big)) + negative_p =3D c_bv[0] & 0x80; + else + negative_p =3D c_bv[c_size - 1] & 0x80; + } + + c_endianness =3D 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 =3D 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 =3D 0; + + c_endianness =3D scm_is_eq (endianness, scm_sym_big) ? 1 : -1; + + mpz_init (c_mpz); + scm_to_mpz (value, c_mpz); + + c_sign =3D 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 =3D -1; + goto finish; + } + } + + if (c_sign =3D=3D 0) + /* Zero. */ + memset (c_bv, 0, c_size); + else + { + size_t word_count, value_size; + + value_size =3D (mpz_sizeinbase (c_mpz, 2) + (8 * c_size)) / (8 * c_s= ize); + if (SCM_UNLIKELY (value_size > c_size)) + { + err =3D -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 !=3D 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 =3D scm_to_ulong (index); \ + c_size =3D scm_to_ulong (size); \ + \ + c_len =3D SCM_BYTEVECTOR_LENGTH (bv); \ + c_bv =3D (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 =3D=3D 0) || (c_size >=3D (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 =3D !scm_is_eq (endianness, native_endianness); \ + switch (c_size) \ + { \ + case 1: \ + { \ + _sign char c_value8; \ + memcpy (&c_value8, c_bv, 1); \ + value =3D c_value8; \ + } \ + break; \ + case 2: \ + { \ + INT_TYPE (16, _sign) c_value16; \ + memcpy (&c_value16, c_bv, 2); \ + if (swap) \ + value =3D (INT_TYPE (16, _sign)) bswap_16 (c_value16); \ + else \ + value =3D c_value16; \ + } \ + break; \ + default: \ + abort (); \ + } \ + \ + result =3D SCM_I_MAKINUM ((_sign int) value); \ + } \ + else \ + result =3D 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 =3D 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 =3D (_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 =3D !scm_is_eq (endianness, native_endianness); \ + \ + if (swap) \ + c_value16 =3D (INT_TYPE (16, _sign)) bswap_16 (c_value); \ + else \ + c_value16 =3D c_value; \ + \ + memcpy (c_bv, &c_value16, 2); \ + } \ + else \ + goto range_error; \ + break; \ + \ + default: \ + abort (); \ + } \ + } \ + else \ + { \ + int err; \ + \ + err =3D 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 + + + +/* 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 =3D scm_to_uint (size); \ + \ + c_len =3D SCM_BYTEVECTOR_LENGTH (bv); \ + if (SCM_UNLIKELY (c_len =3D=3D 0)) \ + lst =3D SCM_EOL; \ + else if (SCM_UNLIKELY (c_len < c_size)) \ + scm_out_of_range (FUNC_NAME, size); \ + else \ + { \ + const char *c_bv; \ + \ + c_bv =3D (char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + lst =3D scm_make_list (scm_from_uint (c_len / c_size), \ + SCM_UNSPECIFIED); \ + for (i =3D 0, pair =3D lst; \ + i <=3D c_len - c_size; \ + i +=3D c_size, c_bv +=3D c_size, pair =3D 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 =3D scm_to_uint (size); \ + \ + if (SCM_UNLIKELY ((c_size =3D=3D 0) || (c_size >=3D (ULONG_MAX >> 3L))))= \ + scm_out_of_range (FUNC_NAME, size); \ + \ + bv =3D make_bytevector (c_len * c_size); \ + c_bv =3D (char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + for (c_bv_ptr =3D c_bv; \ + !scm_is_null (lst); \ + lst =3D SCM_CDR (lst), c_bv_ptr +=3D 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 + + + +/* 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 + + + +/* 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 =3D 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 =3D 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 + + + +/* 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 + + + +/* Operations on IEEE-754 numbers. */ + +/* There are two possible word endians, visible in glibc's . + 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 =3D source; + +#ifdef WORDS_BIGENDIAN + /* Assuming little endian for both byte and word order. */ + target->little_endian.negative =3D src.big_endian.negative; + target->little_endian.exponent =3D src.big_endian.exponent; + target->little_endian.mantissa =3D src.big_endian.mantissa; +#else + target->big_endian.negative =3D src.little_endian.negative; + target->big_endian.exponent =3D src.little_endian.exponent; + target->big_endian.mantissa =3D 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 =3D source->little_endian.negative; + result.big_endian.exponent =3D source->little_endian.exponent; + result.big_endian.mantissa =3D source->little_endian.mantissa; +#else + result.little_endian.negative =3D source->big_endian.negative; + result.little_endian.exponent =3D source->big_endian.exponent; + result.little_endian.mantissa =3D 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 =3D source; + +#ifdef WORDS_BIGENDIAN + /* Assuming little endian for both byte and word order. */ + target->little_little_endian.negative =3D src.big_endian.negative; + target->little_little_endian.exponent =3D src.big_endian.exponent; + target->little_little_endian.mantissa0 =3D src.big_endian.mantissa0; + target->little_little_endian.mantissa1 =3D src.big_endian.mantissa1; +#else + target->big_endian.negative =3D src.little_little_endian.negative; + target->big_endian.exponent =3D src.little_little_endian.exponent; + target->big_endian.mantissa0 =3D src.little_little_endian.mantissa0; + target->big_endian.mantissa1 =3D 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 =3D source->little_little_endian.negative; + result.big_endian.exponent =3D source->little_little_endian.exponent; + result.big_endian.mantissa0 =3D source->little_little_endian.mantissa0; + result.big_endian.mantissa1 =3D source->little_little_endian.mantissa1; +#else + result.little_little_endian.negative =3D source->big_endian.negative; + result.little_little_endian.exponent =3D source->big_endian.exponent; + result.little_little_endian.mantissa0 =3D source->big_endian.mantissa0; + result.little_little_endian.mantissa1 =3D 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 =3D \ + 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 =3D 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 =3D 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 + + +/* 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 =3D 0; \ + const uint ## _utf_width ## _t *ptr; \ + for (ptr =3D str; \ + *ptr !=3D 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 =3D=3D 8) + ? "8" + : ((utf_width =3D=3D 16) + ? "16" + : ((utf_width =3D=3D 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 =3D NULL, *c_locale; \ + size_t c_strlen, c_raw_strlen, c_utf_len =3D 0; \ + \ + SCM_VALIDATE_STRING (1, str); \ + if (endianness =3D=3D SCM_UNDEFINED) \ + endianness =3D scm_sym_big; \ + else \ + SCM_VALIDATE_SYMBOL (2, endianness); \ + \ + c_strlen =3D scm_c_string_length (str); \ + c_raw_strlen =3D c_strlen * ((_utf_width) / 8); \ + do \ + { \ + c_str =3D (char *) alloca (c_raw_strlen + 1); \ + c_raw_strlen =3D scm_to_locale_stringbuf (str, c_str, c_strlen); \ + } \ + while (c_raw_strlen > c_strlen); \ + c_str[c_raw_strlen] =3D '\0'; \ + \ + utf_encoding_name (c_utf_name, (_utf_width), endianness); \ + \ + c_locale =3D (char *) alloca (strlen (locale_charset ()) + 1); \ + strcpy (c_locale, locale_charset ()); \ + \ + err =3D 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 =3D 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 =3D scm_c_string_length (str); + c_raw_strlen =3D c_strlen; + do + { + c_str =3D (char *) alloca (c_raw_strlen + 1); + c_raw_strlen =3D scm_to_locale_stringbuf (str, c_str, c_strlen); + } + while (c_raw_strlen > c_strlen); + c_str[c_raw_strlen] =3D '\0'; + + c_utf =3D u8_strconv_from_locale (c_str); + if (SCM_UNLIKELY (c_utf =3D=3D NULL)) + scm_syserror (FUNC_NAME); + else + /* C_UTF is null-terminated. */ + utf =3D 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 t= o a + string. */ +#define UTF_TO_STRING(_utf_width) \ + SCM str =3D SCM_BOOL_F; \ + int err; \ + char *c_str =3D NULL, *c_locale; \ + char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \ + const char *c_utf; \ + size_t c_strlen =3D 0, c_utf_len; \ + \ + SCM_VALIDATE_BYTEVECTOR (1, utf); \ + if (endianness =3D=3D SCM_UNDEFINED) \ + endianness =3D scm_sym_big; \ + else \ + SCM_VALIDATE_SYMBOL (2, endianness); \ + \ + c_utf_len =3D SCM_BYTEVECTOR_LENGTH (utf); \ + c_utf =3D (char *) SCM_BYTEVECTOR_CONTENTS (utf); \ + utf_encoding_name (c_utf_name, (_utf_width), endianness); \ + \ + c_locale =3D (char *) alloca (strlen (locale_charset ()) + 1); \ + strcpy (c_locale, locale_charset ()); \ + \ + err =3D 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 =3D 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 =3D NULL, *c_locale; + const char *c_utf; + size_t c_utf_len, c_strlen =3D 0; + + SCM_VALIDATE_BYTEVECTOR (1, utf); + + c_utf_len =3D SCM_BYTEVECTOR_LENGTH (utf); + + c_locale =3D (char *) alloca (strlen (locale_charset ()) + 1); + strcpy (c_locale, locale_charset ()); + + c_utf =3D (char *) SCM_BYTEVECTOR_CONTENTS (utf); + err =3D 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 =3D 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 + + + +/* Initialization. */ + +void +scm_init_bytevectors (void) +{ +#include "libguile/bytevectors.x" + +#ifdef WORDS_BIGENDIAN + native_endianness =3D scm_sym_big; +#else + native_endianness =3D scm_sym_little; +#endif + + scm_endianness_big =3D scm_sym_big; + scm_endianness_little =3D scm_sym_little; + + scm_null_bytevector =3D + 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 =2D-- /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-130= 1 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) <=3D 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 =2D-- /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 and modified by Ludovic Court=E8s to inclu= de + 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 */ diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c new file mode 100644 index 0000000..a07636f =2D-- /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-130= 1 USA + */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#ifdef HAVE_UNISTD_H +# include +#endif + +#include +#include +#include + +#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" + + + +/* 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); +} + + +/* 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 + + +/* 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 =3D 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 =3D SCM_OPN | SCM_RDNG; + + port =3D 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 =3D (char *) SCM_BYTEVECTOR_CONTENTS (bv); + c_len =3D SCM_BYTEVECTOR_LENGTH (bv); + + c_port =3D SCM_PTAB_ENTRY (port); + c_port->read_pos =3D c_port->read_buf =3D (unsigned char *) c_bv; + c_port->read_end =3D (unsigned char *) c_bv + c_len; + c_port->read_buf_size =3D 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 =3D SCM_PTAB_ENTRY (port); + + if (c_port->read_pos >=3D c_port->read_end) + result =3D EOF; + else + result =3D (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 =3D 0; + scm_t_port *c_port =3D SCM_PTAB_ENTRY (port); + + switch (whence) + { + case SEEK_CUR: + offset +=3D 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 =3D c_port->read_buf + offset; + c_result =3D offset; + } + else + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + break; + + case SEEK_END: + if (c_port->read_end - offset >=3D c_port->read_buf) + { + c_port->read_pos =3D c_port->read_end - offset; + c_result =3D 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 =3D + 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 + + +/* 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 =3D 0; + + switch (whence) + { + case SEEK_CUR: + { + SCM get_position_proc; + + get_position_proc =3D SCM_CBP_GET_POSITION_PROC (port); + if (SCM_LIKELY (scm_is_true (get_position_proc))) + result =3D 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 +=3D scm_to_int (result); + /* Fall through. */ + } + + case SEEK_SET: + { + SCM set_position_proc; + + set_position_proc =3D SCM_CBP_SET_POSITION_PROC (port); + if (SCM_LIKELY (scm_is_true (set_position_proc))) + result =3D 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 =3D 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 =3D SCM_CBP_CLOSE_PROC (port); + if (scm_is_true (close_proc)) + /* Invoke the `close' thunk. */ + scm_call_0 (close_proc); + + return 1; +} + + +/* Custom binary input port ("cbip" for short). */ + +static scm_t_bits custom_binary_input_port_type =3D 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 =3D SCM_OPN | SCM_RDNG; + + /* Use a bytevector as the underlying buffer. */ + c_len =3D CBIP_BUFFER_SIZE; + bv =3D scm_c_make_bytevector (c_len); + c_bv =3D (char *) SCM_BYTEVECTOR_CONTENTS (bv); + + /* Store the various methods and bytevector in a vector. */ + method_vector =3D 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 =3D 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 =3D SCM_PTAB_ENTRY (port); + c_port->read_pos =3D c_port->read_buf =3D (unsigned char *) c_bv; + c_port->read_end =3D (unsigned char *) c_bv; + c_port->read_buf_size =3D 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 =3D SCM_PTAB_ENTRY (port); + + again: + if (c_port->read_pos >=3D 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 t= he + `read!' procedure, thereby avoiding additional allocations. */ + bv =3D SCM_CBIP_BYTEVECTOR (port); + read_proc =3D SCM_CBIP_READ_PROC (port); + + /* The assumption here is that C_PORT's internal buffer wasn't chang= ed + behind our back. */ + assert (c_port->read_buf =3D=3D + (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv)); + assert ((unsigned) c_port->read_buf_size + =3D=3D SCM_BYTEVECTOR_LENGTH (bv)); + + octets =3D scm_call_3 (read_proc, bv, SCM_INUM0, + SCM_I_MAKINUM (CBIP_BUFFER_SIZE)); + c_octets =3D scm_to_uint (octets); + + c_port->read_pos =3D (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + c_port->read_end =3D (unsigned char *) c_port->read_pos + c_octets; + + if (c_octets > 0) + goto again; + else + result =3D EOF; + } + else + result =3D (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 =3D + 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); +} + + + +/* 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 =3D scm_getc (port); + if (c_result =3D=3D EOF) + result =3D SCM_EOF_VAL; + else + result =3D 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 =3D scm_peek_char (port); + if (SCM_CHARP (result)) + result =3D SCM_I_MAKINUM ((signed char) SCM_CHAR (result)); + else + result =3D 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 =3D scm_to_uint (count); + + result =3D scm_c_make_bytevector (c_count); + c_bv =3D (char *) SCM_BYTEVECTOR_CONTENTS (result); + + if (SCM_LIKELY (c_count > 0)) + /* XXX: `scm_c_read ()' does not update the port position. */ + c_read =3D scm_c_read (port, c_bv, c_count); + else + /* Don't invoke `scm_c_read ()' since it may block. */ + c_read =3D 0; + + if ((c_read =3D=3D 0) && (c_count > 0)) + { + if (SCM_EOF_OBJECT_P (scm_peek_char (port))) + result =3D SCM_EOF_VAL; + else + result =3D scm_null_bytevector; + } + else + { + if (c_read < c_count) + result =3D 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 =3D scm_to_uint (start); + c_count =3D scm_to_uint (count); + + c_bv =3D (char *) SCM_BYTEVECTOR_CONTENTS (bv); + c_len =3D 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 =3D scm_c_read (port, c_bv + c_start, c_count); + else + /* Don't invoke `scm_c_read ()' since it may block. */ + c_read =3D 0; + + if ((c_read =3D=3D 0) && (c_count > 0)) + { + if (SCM_EOF_OBJECT_P (scm_peek_char (port))) + result =3D SCM_EOF_VAL; + else + result =3D SCM_I_MAKINUM (0); + } + else + result =3D 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 =3D 4096; + c_bv =3D (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR); + c_total =3D 0; + + do + { + int c_chr; + + if (c_total + 1 > c_len) + { + /* Grow the bytevector. */ + c_bv =3D (char *) scm_gc_realloc (c_bv, c_len, c_len * 2, + SCM_GC_BYTEVECTOR); + c_len *=3D 2; + } + + /* We can't use `scm_c_read ()' since it blocks. */ + c_chr =3D scm_getc (port); + if (c_chr !=3D EOF) + { + c_bv[c_total] =3D (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 =3D=3D 0) + { + result =3D SCM_EOF_VAL; + scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + } + else + { + if (c_len > c_total) + { + /* Shrink the bytevector. */ + c_bv =3D (char *) scm_gc_realloc (c_bv, c_len, c_total, + SCM_GC_BYTEVECTOR); + c_len =3D (unsigned) c_total; + } + + result =3D 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 =3D c_count =3D 4096; + c_bv =3D (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR); + c_total =3D c_read =3D 0; + + do + { + if (c_total + c_read > c_len) + { + /* Grow the bytevector. */ + c_bv =3D (char *) scm_gc_realloc (c_bv, c_len, c_len * 2, + SCM_GC_BYTEVECTOR); + c_count =3D c_len; + c_len *=3D 2; + } + + /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is + reached. */ + c_read =3D scm_c_read (port, c_bv + c_total, c_count); + c_total +=3D c_read, c_count -=3D c_read; + } + while (!SCM_EOF_OBJECT_P (scm_peek_char (port))); + + if (c_total =3D=3D 0) + { + result =3D SCM_EOF_VAL; + scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + } + else + { + if (c_len > c_total) + { + /* Shrink the bytevector. */ + c_bv =3D (char *) scm_gc_realloc (c_bv, c_len, c_total, + SCM_GC_BYTEVECTOR); + c_len =3D (unsigned) c_total; + } + + result =3D scm_c_take_bytevector ((signed char *) c_bv, c_len); + } + + return result; +} +#undef FUNC_NAME + + + +/* 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 =3D 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 =3D SCM_BYTEVECTOR_LENGTH (bv); + c_bv =3D (char *) SCM_BYTEVECTOR_CONTENTS (bv); + + if (start !=3D SCM_UNDEFINED) + { + c_start =3D scm_to_uint (start); + + if (count !=3D SCM_UNDEFINED) + { + c_count =3D 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 >=3D c_len)) + scm_out_of_range (FUNC_NAME, start); + else + c_count =3D c_len - c_start; + } + } + else + c_start =3D 0, c_count =3D c_len; + + scm_c_write (port, c_bv + c_start, c_count); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + +/* 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 =3D 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 =3D buf->len =3D buf->pos =3D 0; + buf->buffer =3D 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 =3D buf->total_len + ? buf->total_len : SCM_BOP_BUFFER_INITIAL_SIZE; + new_size < min_size; + new_size *=3D 2); + + if (buf->buffer) + new_buf =3D scm_gc_realloc ((void *) buf->buffer, buf->total_len, + new_size, SCM_GC_BOP); + else + new_buf =3D scm_gc_malloc (new_size, SCM_GC_BOP); + + buf->buffer =3D new_buf; + buf->total_len =3D 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 =3D SCM_OPN | SCM_WRTNG; + + port =3D scm_new_port_table_entry (bytevector_output_port_type); + + buf =3D (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP); + bop_buffer_init (buf); + + c_port =3D SCM_PTAB_ENTRY (port); + c_port->write_buf =3D c_port->write_pos =3D c_port->write_end =3D NULL; + c_port->write_buf_size =3D 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 =3D 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 =3D 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 +=3D size; + buf->len =3D (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 =3D SCM_BOP_BUFFER (port); + switch (whence) + { + case SEEK_CUR: + offset +=3D (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 =3D offset; + break; + + case SEEK_END: + if (offset < 0 || (unsigned) offset >=3D buf->len) + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + else + buf->pos =3D 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 =3D SCM_PACK (SCM_SMOB_DATA (bop_proc)); + buf =3D SCM_BOP_BUFFER (port); + + result_buf =3D *buf; + bop_buffer_init (buf); + + if (result_buf.len =3D=3D 0) + bv =3D scm_c_take_bytevector (NULL, 0); + else + { + if (result_buf.total_len > result_buf.len) + /* Shrink the buffer. */ + result_buf.buffer =3D scm_gc_realloc ((void *) result_buf.buffer, + result_buf.total_len, + result_buf.len, + SCM_GC_BOP); + + bv =3D 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 =3D + 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); +} + + +/* 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 =3D SCM_OPN | SCM_WRTNG; + + /* Store the various methods and bytevector in a vector. */ + method_vector =3D 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 =3D 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 =3D SCM_PTAB_ENTRY (port); + c_port->write_buf =3D c_port->write_pos =3D c_port->write_end =3D NULL; + c_port->write_buf_size =3D c_port->read_buf_size =3D 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 =3D scm_c_make_bytevector (size); + memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size); + + write_proc =3D 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 =3D 0; + c_written < size; + c_written +=3D c_result) + { + result =3D scm_call_3 (write_proc, bv, + scm_from_size_t (c_written), + scm_from_size_t (size - c_written)); + + c_result =3D 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 =3D + 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); +} + + +/* 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 =2D-- /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-130= 1 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 */ diff --git a/libguile/validate.h b/libguile/validate.h index e05b7dd..c362c02 100644 =2D-- a/libguile/validate.h +++ b/libguile/validate.h @@ -3,7 +3,7 @@ #ifndef SCM_VALIDATE_H #define SCM_VALIDATE_H =20 =2D/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007 Free Software Fo= undation, Inc. +/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007, 2009 Free Softwar= e 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 =3D scm_to_bool (flag); \ } while (0) =20 +#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") =20 #define SCM_VALIDATE_CHAR_COPY(pos, scm, cvar) \ diff --git a/module/Makefile.am b/module/Makefile.am index 95dc75a..d149bb6 100644 =2D-- a/module/Makefile.am +++ b/module/Makefile.am @@ -31,7 +31,7 @@ modpath =3D # putting these core modules first. =20 SOURCES =3D \ =2D 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 =3D \ \ $(ICE_9_SOURCES) \ $(SRFI_SOURCES) \ + $(RNRS_SOURCES) \ $(OOP_SOURCES) \ \ $(SCRIPTS_SOURCES) @@ -209,6 +210,10 @@ SRFI_SOURCES =3D \ srfi/srfi-69.scm \ srfi/srfi-88.scm =20 +RNRS_SOURCES =3D \ + rnrs/bytevector.scm \ + rnrs/io/ports.scm + EXTRA_DIST +=3D scripts/ChangeLog-2008 EXTRA_DIST +=3D scripts/README =20 diff --git a/module/rnrs/bytevector.scm b/module/rnrs/bytevector.scm new file mode 100644 index 0000000..793cbc0 =2D-- /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-1= 301 USA + +;;; Author: Ludovic Court=E8s + +;;; Commentary: +;;; +;;; A "bytevector" is a raw bit string. This module provides procedures to +;;; manipulate bytevectors and interpret their contents in a number of way= s: +;;; 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=3D? bytevector-fil= l! + 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 =2D-- /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-1= 301 USA + +;;; Author: Ludovic Court=E8s + +;;; 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 instan= ce, +;;; 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 diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 3854d4a..0b986d4 100644 =2D-- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -26,6 +26,7 @@ SCM_TESTS =3D 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 =3D 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/bytevecto= rs.test new file mode 100644 index 0000000..b2ae65c =2D-- /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=E8s +;;;; +;;;; 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-1= 301 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" + (=3D (bytevector-length (make-bytevector 20)) 20)) + + (pass-if "bytevector=3D?" + (and (bytevector=3D? (make-bytevector 20 7) + (make-bytevector 20 7)) + (not (bytevector=3D? (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=3D? b1 b2) + (bytevector=3D? b2 b3)))) + + (pass-if "sint-list->bytevector [limits]" + (bytevector=3D? (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)) + (=3D 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) + (=3D (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=E9, =E7a va bien ?") + (utf8 (string->utf8 str))) + (and (bytevector? utf8) + (=3D (bytevector-length utf8) + (+ 2 (string-length str)))))))) + + (pass-if "string->utf16" + (let* ((str "hello, world") + (utf16 (string->utf16 str))) + (and (bytevector? utf16) + (=3D (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) + (=3D (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) + (=3D (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) + (=3D (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) + (=3D (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=E9, =E7a va bien ?")) + (str (utf8->string utf8))) + (and (string? str) + (=3D (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) + (=3D (* 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) + (=3D (* 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) + (=3D (* 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) + (=3D (* 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 =2D-- /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=E8s +;;;; +;;;; 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-1= 301 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 (=3D (char->integer #\A) (get-u8 port)) + (eof-object? (get-u8 port))))) + + (pass-if "lookahead-u8" + (let ((port (open-input-string "A"))) + (and (=3D (char->integer #\A) (lookahead-u8 port)) + (not (eof-object? port)) + (=3D (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 (>=3D 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) + (=3D index 4) + (=3D (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 (>=3D 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: fall= s to + ;; zero after 4 octets have been read and t= hen + ;; starts again. + (let ((a (if cont? + (- (string-length str) index) + (- 4 (modulo index 5))))) + (if (=3D 0 a) (set! cont? #t)) + a)))) + "r")) + (bv (get-bytevector-all port))) + (and (bytevector? bv) + (=3D index (string-length str)) + (=3D (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 (>=3D 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) + (=3D 0 (port-position port)) + (port-has-set-port-position!? port) + (begin + (set-port-position! port 6) + (=3D 6 (port-position port))) + (bytevector=3D? (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=3D? (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) + (=3D 0 (port-position port)) + (port-has-set-port-position!? port) + (begin + (set-port-position! port 6) + (=3D 6 (port-position port))) + (bytevector=3D? (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=3D? (get-content) source) + (bytevector=3D? (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=3D? (get-content) (make-bytevector 1 77)) + (bytevector=3D? (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=3D? (get-content) (string->utf8 "hello")) + (bytevector=3D? (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) + (=3D (bytevector-length source) + (port-position port))) + (begin + (set-port-position! port 10) + (=3D 10 (port-position port))) + (begin + (put-bytevector port overwrite) + (bytevector-copy! overwrite 0 source 10 + (bytevector-length overwrite)) + (=3D (port-position port) + (+ 10 (bytevector-length overwrite)))) + (bytevector=3D? (get-content) source) + (bytevector=3D? (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 (=3D 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 (=3D sink-pos (bytevector-length source)) + (not eof?) + (bytevector=3D? 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 (=3D 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 (=3D sink-pos (bytevector-length source)) + (not eof?) + (bytevector=3D? sink source))))) + + +;;; Local Variables: +;;; coding: latin-1 +;;; mode: scheme +;;; End: =2D-=20 1.6.1.3 --=-=-=-- --==-=-= Content-Type: application/pgp-signature -----BEGIN PGP SIGNATURE----- Version: GnuPG v2.0.11 (GNU/Linux) iEYEARECAAYFAkodvl4ACgkQd92V4upS7PTFOgCgl4Pr3jcfuN6aLWZCs08z8Avv YcUAnAs8WHwRontYmIWakr51obDv1ACM =Ve/N -----END PGP SIGNATURE----- --==-=-=--