summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
Diffstat (limited to 'libguile')
-rw-r--r--libguile/Makefile.am30
-rw-r--r--libguile/__scm.h26
-rw-r--r--libguile/bytevectors.c1978
-rw-r--r--libguile/bytevectors.h133
-rw-r--r--libguile/eval.c19
-rw-r--r--libguile/eval.h2
-rw-r--r--libguile/frames.c49
-rw-r--r--libguile/frames.h84
-rw-r--r--libguile/ieee-754.h90
-rw-r--r--libguile/instructions.c50
-rw-r--r--libguile/instructions.h66
-rw-r--r--libguile/macros.c113
-rw-r--r--libguile/macros.h13
-rw-r--r--libguile/modules.c4
-rw-r--r--libguile/objcodes.c49
-rw-r--r--libguile/objcodes.h66
-rw-r--r--libguile/posix.c13
-rw-r--r--libguile/programs.c49
-rw-r--r--libguile/programs.h86
-rw-r--r--libguile/r6rs-ports.c1118
-rw-r--r--libguile/r6rs-ports.h43
-rw-r--r--libguile/read.c83
-rw-r--r--libguile/stime.c13
-rw-r--r--libguile/threads.c11
-rw-r--r--libguile/validate.h5
-rw-r--r--libguile/vm-bootstrap.h50
-rw-r--r--libguile/vm-engine.c48
-rw-r--r--libguile/vm-engine.h52
-rw-r--r--libguile/vm-expand.h48
-rw-r--r--libguile/vm-i-scheme.c48
-rw-r--r--libguile/vm-i-system.c8
-rw-r--r--libguile/vm.c49
-rw-r--r--libguile/vm.h110
33 files changed, 3906 insertions, 700 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 369b24951..fcf197a54 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -32,10 +32,10 @@ DEFAULT_INCLUDES =
## Check for headers in $(srcdir)/.., so that #include
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
## building. Also look for Gnulib headers in `lib'.
-AM_CPPFLAGS = -I$(top_srcdir) -I$(top_builddir) \
+AM_CPPFLAGS = -DBUILDING_LIBGUILE=1 -I$(top_srcdir) -I$(top_builddir) \
-I$(top_srcdir)/lib -I$(top_builddir)/lib
-AM_CFLAGS = $(GCC_CFLAGS)
+AM_CFLAGS = $(GCC_CFLAGS) $(CFLAG_VISIBILITY)
## The Gnulib Libtool archive.
gnulib_library = $(top_builddir)/lib/libgnu.la
@@ -106,7 +106,8 @@ guile_LDFLAGS = $(GUILE_CFLAGS)
libguile_la_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS)
libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
- chars.c continuations.c convert.c debug.c deprecation.c \
+ bytevectors.c chars.c continuations.c \
+ convert.c debug.c deprecation.c \
deprecated.c discouraged.c dynwind.c eq.c error.c \
eval.c evalext.c extensions.c feature.c fluids.c fports.c \
futures.c gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c \
@@ -115,7 +116,8 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
guardians.c hash.c hashtab.c hooks.c init.c inline.c \
ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \
modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \
- print.c procprop.c procs.c properties.c random.c rdelim.c read.c \
+ print.c procprop.c procs.c properties.c \
+ r6rs-ports.c random.c rdelim.c read.c \
root.c rw.c scmsigs.c script.c simpos.c smob.c sort.c srcprop.c \
stackchk.c stacks.c stime.c strings.c srfi-4.c srfi-13.c srfi-14.c \
strorder.c strports.c struct.c symbols.c threads.c null-threads.c \
@@ -134,7 +136,8 @@ libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \
-module -L$(builddir) -lguile \
-version-info @LIBGUILE_I18N_INTERFACE@
-DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \
+DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x \
+ bytevectors.x chars.x \
continuations.x debug.x deprecation.x deprecated.x discouraged.x \
dynl.x dynwind.x eq.x error.x eval.x evalext.x \
extensions.x feature.x fluids.x fports.x futures.x gc.x gc-mark.x \
@@ -143,7 +146,8 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \
hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \
list.x load.x macros.x mallocs.x modules.x numbers.x objects.x \
objprop.x options.x pairs.x ports.x print.x procprop.x procs.x \
- properties.x random.x rdelim.x read.x root.x rw.x scmsigs.x \
+ properties.x r6rs-ports.x random.x rdelim.x \
+ read.x root.x rw.x scmsigs.x \
script.x simpos.x smob.x sort.x srcprop.x stackchk.x stacks.x \
stime.x strings.x srfi-4.x srfi-13.x srfi-14.x strorder.x \
strports.x struct.x symbols.x threads.x throw.x values.x \
@@ -155,7 +159,8 @@ DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x
EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
- boolean.doc chars.doc continuations.doc debug.doc deprecation.doc \
+ boolean.doc bytevectors.doc chars.doc \
+ continuations.doc debug.doc deprecation.doc \
deprecated.doc discouraged.doc dynl.doc dynwind.doc \
eq.doc error.doc eval.doc evalext.doc \
extensions.doc feature.doc fluids.doc fports.doc futures.doc \
@@ -165,7 +170,8 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc \
list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc \
objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc \
- procprop.doc procs.doc properties.doc random.doc rdelim.doc \
+ procprop.doc procs.doc properties.doc r6rs-ports.doc \
+ random.doc rdelim.doc \
read.doc root.doc rw.doc scmsigs.doc script.doc simpos.doc \
smob.doc sort.doc srcprop.doc stackchk.doc stacks.doc stime.doc \
strings.doc srfi-4.doc srfi-13.doc srfi-14.doc strorder.doc \
@@ -204,7 +210,7 @@ install-exec-hook:
## working.
noinst_HEADERS = convert.i.c \
conv-integer.i.c conv-uinteger.i.c \
- eval.i.c \
+ eval.i.c ieee-754.h \
srfi-4.i.c \
quicksort.i.c \
win32-uname.h win32-dirent.h win32-socket.h \
@@ -223,7 +229,8 @@ pkginclude_HEADERS =
# These are headers visible as <libguile/mumble.h>.
modincludedir = $(includedir)/libguile
modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \
- boolean.h chars.h continuations.h convert.h debug.h debug-malloc.h \
+ boolean.h bytevectors.h chars.h continuations.h convert.h \
+ debug.h debug-malloc.h \
deprecation.h deprecated.h discouraged.h dynl.h dynwind.h \
eq.h error.h eval.h evalext.h extensions.h \
feature.h filesys.h fluids.h fports.h futures.h gc.h \
@@ -232,7 +239,8 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \
hashtab.h hooks.h i18n.h init.h inline.h ioext.h iselect.h \
keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \
net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h \
- posix.h regex-posix.h print.h procprop.h procs.h properties.h \
+ posix.h r6rs-ports.h regex-posix.h print.h \
+ procprop.h procs.h properties.h \
random.h ramap.h rdelim.h read.h root.h rw.h scmsigs.h validate.h \
script.h simpos.h smob.h snarf.h socket.h sort.h srcprop.h \
stackchk.h stacks.h stime.h strings.h srfi-4.h srfi-13.h srfi-14.h \
diff --git a/libguile/__scm.h b/libguile/__scm.h
index 3672b1c09..07d7b4d3d 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -98,13 +98,10 @@
#define SCM_UNLIKELY(_expr) SCM_EXPECT ((_expr), 0)
/* The SCM_INTERNAL macro makes it possible to explicitly declare a function
- * as having "internal" linkage. */
-#if (defined __GNUC__) && \
- ((__GNUC__ >= 4) || (__GNUC__ == 3 && __GNUC_MINOR__ == 3))
-# define SCM_INTERNAL extern __attribute__ ((__visibility__ ("internal")))
-#else
-# define SCM_INTERNAL extern
-#endif
+ * as having "internal" linkage. However our current tack on this problem is
+ * to use GCC 4's -fvisibility=hidden, making functions internal by default,
+ * and then SCM_API marks them for export. */
+#define SCM_INTERNAL extern
@@ -154,13 +151,14 @@
/* SCM_API is a macro prepended to all function and data definitions
- which should be exported or imported in the resulting dynamic link
- library (DLL) in the Win32 port. */
-
-#if defined (SCM_IMPORT)
-# define SCM_API __declspec (dllimport) extern
-#elif defined (SCM_EXPORT) || defined (DLL_EXPORT)
-# define SCM_API __declspec (dllexport) extern
+ which should be exported from libguile. */
+
+#if BUILDING_LIBGUILE && HAVE_VISIBILITY
+# define SCM_API extern __attribute__((__visibility__("default")))
+#elif BUILDING_LIBGUILE && defined _MSC_VER
+# define SCM_API __declspec(dllexport) extern
+#elif defined _MSC_VER
+# define SCM_API __declspec(dllimport) extern
#else
# define SCM_API extern
#endif
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
new file mode 100644
index 000000000..4c3a353a1
--- /dev/null
+++ b/libguile/bytevectors.c
@@ -0,0 +1,1978 @@
+/* Copyright (C) 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <alloca.h>
+
+#include <gmp.h>
+
+#include "libguile/_scm.h"
+#include "libguile/bytevectors.h"
+#include "libguile/strings.h"
+#include "libguile/validate.h"
+#include "libguile/ieee-754.h"
+
+#include <byteswap.h>
+#include <striconveh.h>
+#include <uniconv.h>
+
+#ifdef HAVE_LIMITS_H
+# include <limits.h>
+#else
+/* Assuming 32-bit longs. */
+# define ULONG_MAX 4294967295UL
+#endif
+
+#include <string.h>
+
+
+
+/* Utilities. */
+
+/* Convenience macros. These are used by the various templates (macros) that
+ are parameterized by integer signedness. */
+#define INT8_T_signed scm_t_int8
+#define INT8_T_unsigned scm_t_uint8
+#define INT16_T_signed scm_t_int16
+#define INT16_T_unsigned scm_t_uint16
+#define INT32_T_signed scm_t_int32
+#define INT32_T_unsigned scm_t_uint32
+#define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L))
+#define is_unsigned_int8(_x) ((_x) <= 255UL)
+#define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
+#define is_unsigned_int16(_x) ((_x) <= 65535UL)
+#define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L))
+#define is_unsigned_int32(_x) ((_x) <= 4294967295UL)
+#define SIGNEDNESS_signed 1
+#define SIGNEDNESS_unsigned 0
+
+#define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign
+#define INT_SWAP(_size) bswap_ ## _size
+#define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
+#define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
+
+
+#define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \
+ unsigned c_len, c_index; \
+ _sign char *c_bv; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, bv); \
+ c_index = scm_to_uint (index); \
+ \
+ c_len = SCM_BYTEVECTOR_LENGTH (bv); \
+ c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \
+ \
+ if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
+ scm_out_of_range (FUNC_NAME, index);
+
+/* Template for fixed-size integer access (only 8, 16 or 32-bit). */
+#define INTEGER_REF(_len, _sign) \
+ SCM result; \
+ \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ { \
+ INT_TYPE (_len, _sign) c_result; \
+ \
+ memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
+ if (!scm_is_eq (endianness, native_endianness)) \
+ c_result = INT_SWAP (_len) (c_result); \
+ \
+ result = SCM_I_MAKINUM (c_result); \
+ } \
+ \
+ return result;
+
+/* Template for fixed-size integer access using the native endianness. */
+#define INTEGER_NATIVE_REF(_len, _sign) \
+ SCM result; \
+ \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ \
+ { \
+ INT_TYPE (_len, _sign) c_result; \
+ \
+ memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
+ result = SCM_I_MAKINUM (c_result); \
+ } \
+ \
+ return result;
+
+/* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
+#define INTEGER_SET(_len, _sign) \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ { \
+ _sign long c_value; \
+ INT_TYPE (_len, _sign) c_value_short; \
+ \
+ if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
+ scm_wrong_type_arg (FUNC_NAME, 3, value); \
+ \
+ c_value = SCM_I_INUM (value); \
+ if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ c_value_short = (INT_TYPE (_len, _sign)) c_value; \
+ if (!scm_is_eq (endianness, native_endianness)) \
+ c_value_short = INT_SWAP (_len) (c_value_short); \
+ \
+ memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
+ } \
+ \
+ return SCM_UNSPECIFIED;
+
+/* Template for fixed-size integer modification using the native
+ endianness. */
+#define INTEGER_NATIVE_SET(_len, _sign) \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ \
+ { \
+ _sign long c_value; \
+ INT_TYPE (_len, _sign) c_value_short; \
+ \
+ if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
+ scm_wrong_type_arg (FUNC_NAME, 3, value); \
+ \
+ c_value = SCM_I_INUM (value); \
+ if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ c_value_short = (INT_TYPE (_len, _sign)) c_value; \
+ \
+ memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
+ } \
+ \
+ return SCM_UNSPECIFIED;
+
+
+
+/* Bytevector type. */
+
+SCM_GLOBAL_SMOB (scm_tc16_bytevector, "r6rs-bytevector", 0);
+
+#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
+ SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len))
+#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
+ SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf))
+
+/* The empty bytevector. */
+SCM scm_null_bytevector = SCM_UNSPECIFIED;
+
+
+static inline SCM
+make_bytevector_from_buffer (unsigned len, signed char *contents)
+{
+ /* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */
+ SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector, len, contents);
+}
+
+static inline SCM
+make_bytevector (unsigned len)
+{
+ SCM bv;
+
+ if (SCM_UNLIKELY (len == 0))
+ bv = scm_null_bytevector;
+ else
+ {
+ signed char *contents = NULL;
+
+ if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len))
+ contents = (signed char *) scm_gc_malloc (len, SCM_GC_BYTEVECTOR);
+
+ bv = make_bytevector_from_buffer (len, contents);
+ }
+
+ return bv;
+}
+
+/* Return a new bytevector of size LEN octets. */
+SCM
+scm_c_make_bytevector (unsigned len)
+{
+ return (make_bytevector (len));
+}
+
+/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
+ by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
+SCM
+scm_c_take_bytevector (signed char *contents, unsigned len)
+{
+ SCM bv;
+
+ if (SCM_UNLIKELY (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len)))
+ {
+ /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */
+ signed char *c_bv;
+
+ bv = make_bytevector (len);
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+ memcpy (c_bv, contents, len);
+ scm_gc_free (contents, len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ bv = make_bytevector_from_buffer (len, contents);
+
+ return bv;
+}
+
+/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
+ size) and return BV. */
+SCM
+scm_i_shrink_bytevector (SCM bv, unsigned c_new_len)
+{
+ if (!SCM_BYTEVECTOR_INLINE_P (bv))
+ {
+ unsigned c_len;
+ signed char *c_bv, *c_new_bv;
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+
+ SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
+
+ if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len))
+ {
+ /* Copy to the in-line buffer and free the current buffer. */
+ c_new_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+ memcpy (c_new_bv, c_bv, c_new_len);
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ {
+ /* Resize the existing buffer. */
+ c_new_bv = scm_gc_realloc (c_bv, c_len, c_new_len,
+ SCM_GC_BYTEVECTOR);
+ SCM_BYTEVECTOR_SET_CONTENTS (bv, c_new_bv);
+ }
+ }
+
+ return bv;
+}
+
+SCM_SMOB_PRINT (scm_tc16_bytevector, print_bytevector,
+ bv, port, pstate)
+{
+ unsigned c_len, i;
+ unsigned char *c_bv;
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ scm_puts ("#vu8(", port);
+ for (i = 0; i < c_len; i++)
+ {
+ if (i > 0)
+ scm_putc (' ', port);
+
+ scm_uintprint (c_bv[i], 10, port);
+ }
+
+ scm_putc (')', port);
+
+ /* Make GCC think we use it. */
+ scm_remember_upto_here ((SCM) pstate);
+
+ return 1;
+}
+
+SCM_SMOB_FREE (scm_tc16_bytevector, free_bytevector, bv)
+{
+
+ if (!SCM_BYTEVECTOR_INLINE_P (bv))
+ {
+ unsigned c_len;
+ signed char *c_bv;
+
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+
+ return 0;
+}
+
+
+
+/* General operations. */
+
+SCM_SYMBOL (scm_sym_big, "big");
+SCM_SYMBOL (scm_sym_little, "little");
+
+SCM scm_endianness_big, scm_endianness_little;
+
+/* Host endianness (a symbol). */
+static SCM native_endianness = SCM_UNSPECIFIED;
+
+/* Byte-swapping. */
+#ifndef bswap_24
+# define bswap_24(_x) \
+ ((((_x) & 0xff0000) >> 16) | \
+ (((_x) & 0x00ff00)) | \
+ (((_x) & 0x0000ff) << 16))
+#endif
+
+
+SCM_DEFINE (scm_native_endianness, "native-endianness", 0, 0, 0,
+ (void),
+ "Return a symbol denoting the machine's native endianness.")
+#define FUNC_NAME s_scm_native_endianness
+{
+ return native_endianness;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_p, "bytevector?", 1, 0, 0,
+ (SCM obj),
+ "Return true if @var{obj} is a bytevector.")
+#define FUNC_NAME s_scm_bytevector_p
+{
+ return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_bytevector,
+ obj)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0,
+ (SCM len, SCM fill),
+ "Return a newly allocated bytevector of @var{len} bytes, "
+ "optionally filled with @var{fill}.")
+#define FUNC_NAME s_scm_make_bytevector
+{
+ SCM bv;
+ unsigned c_len;
+ signed char c_fill = '\0';
+
+ SCM_VALIDATE_UINT_COPY (1, len, c_len);
+ if (fill != SCM_UNDEFINED)
+ {
+ int value;
+
+ value = scm_to_int (fill);
+ if (SCM_UNLIKELY ((value < -128) || (value > 255)))
+ scm_out_of_range (FUNC_NAME, fill);
+ c_fill = (signed char) value;
+ }
+
+ bv = make_bytevector (c_len);
+ if (fill != SCM_UNDEFINED)
+ {
+ unsigned i;
+ signed char *contents;
+
+ contents = SCM_BYTEVECTOR_CONTENTS (bv);
+ for (i = 0; i < c_len; i++)
+ contents[i] = c_fill;
+ }
+
+ return bv;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_length, "bytevector-length", 1, 0, 0,
+ (SCM bv),
+ "Return the length (in bytes) of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_length
+{
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ return (scm_from_uint (SCM_BYTEVECTOR_LENGTH (bv)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_eq_p, "bytevector=?", 2, 0, 0,
+ (SCM bv1, SCM bv2),
+ "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
+ "have the same length and contents.")
+#define FUNC_NAME s_scm_bytevector_eq_p
+{
+ SCM result = SCM_BOOL_F;
+ unsigned c_len1, c_len2;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv1);
+ SCM_VALIDATE_BYTEVECTOR (2, bv2);
+
+ c_len1 = SCM_BYTEVECTOR_LENGTH (bv1);
+ c_len2 = SCM_BYTEVECTOR_LENGTH (bv2);
+
+ if (c_len1 == c_len2)
+ {
+ signed char *c_bv1, *c_bv2;
+
+ c_bv1 = SCM_BYTEVECTOR_CONTENTS (bv1);
+ c_bv2 = SCM_BYTEVECTOR_CONTENTS (bv2);
+
+ result = scm_from_bool (!memcmp (c_bv1, c_bv2, c_len1));
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_fill_x, "bytevector-fill!", 2, 0, 0,
+ (SCM bv, SCM fill),
+ "Fill bytevector @var{bv} with @var{fill}, a byte.")
+#define FUNC_NAME s_scm_bytevector_fill_x
+{
+ unsigned c_len, i;
+ signed char *c_bv, c_fill;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+ c_fill = scm_to_int8 (fill);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+
+ for (i = 0; i < c_len; i++)
+ c_bv[i] = c_fill;
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_copy_x, "bytevector-copy!", 5, 0, 0,
+ (SCM source, SCM source_start, SCM target, SCM target_start,
+ SCM len),
+ "Copy @var{len} bytes from @var{source} into @var{target}, "
+ "starting reading from @var{source_start} (a positive index "
+ "within @var{source}) and start writing at "
+ "@var{target_start}.")
+#define FUNC_NAME s_scm_bytevector_copy_x
+{
+ unsigned c_len, c_source_len, c_target_len;
+ unsigned c_source_start, c_target_start;
+ signed char *c_source, *c_target;
+
+ SCM_VALIDATE_BYTEVECTOR (1, source);
+ SCM_VALIDATE_BYTEVECTOR (3, target);
+
+ c_len = scm_to_uint (len);
+ c_source_start = scm_to_uint (source_start);
+ c_target_start = scm_to_uint (target_start);
+
+ c_source = SCM_BYTEVECTOR_CONTENTS (source);
+ c_target = SCM_BYTEVECTOR_CONTENTS (target);
+ c_source_len = SCM_BYTEVECTOR_LENGTH (source);
+ c_target_len = SCM_BYTEVECTOR_LENGTH (target);
+
+ if (SCM_UNLIKELY (c_source_start + c_len > c_source_len))
+ scm_out_of_range (FUNC_NAME, source_start);
+ if (SCM_UNLIKELY (c_target_start + c_len > c_target_len))
+ scm_out_of_range (FUNC_NAME, target_start);
+
+ memcpy (c_target + c_target_start,
+ c_source + c_source_start,
+ c_len);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0,
+ (SCM bv),
+ "Return a newly allocated copy of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_copy
+{
+ SCM copy;
+ unsigned c_len;
+ signed char *c_bv, *c_copy;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+
+ copy = make_bytevector (c_len);
+ c_copy = SCM_BYTEVECTOR_CONTENTS (copy);
+ memcpy (c_copy, c_bv, c_len);
+
+ return copy;
+}
+#undef FUNC_NAME
+
+
+/* Operations on bytes and octets. */
+
+SCM_DEFINE (scm_bytevector_u8_ref, "bytevector-u8-ref", 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the octet located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_u8_ref
+{
+ INTEGER_NATIVE_REF (8, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s8_ref, "bytevector-s8-ref", 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the byte located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_s8_ref
+{
+ INTEGER_NATIVE_REF (8, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u8_set_x, "bytevector-u8-set!", 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Return the octet located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_u8_set_x
+{
+ INTEGER_NATIVE_SET (8, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Return the octet located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_u8_set_x
+{
+ INTEGER_NATIVE_SET (8, signed);
+}
+#undef FUNC_NAME
+
+#undef OCTET_ACCESSOR_PROLOGUE
+
+
+SCM_DEFINE (scm_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0,
+ (SCM bv),
+ "Return a newly allocated list of octets containing the "
+ "contents of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_to_u8_list
+{
+ SCM lst, pair;
+ unsigned c_len, i;
+ unsigned char *c_bv;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ lst = scm_make_list (scm_from_uint (c_len), SCM_UNSPECIFIED);
+ for (i = 0, pair = lst;
+ i < c_len;
+ i++, pair = SCM_CDR (pair))
+ {
+ SCM_SETCAR (pair, SCM_I_MAKINUM (c_bv[i]));
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0,
+ (SCM lst),
+ "Turn @var{lst}, a list of octets, into a bytevector.")
+#define FUNC_NAME s_scm_u8_list_to_bytevector
+{
+ SCM bv, item;
+ long c_len, i;
+ unsigned char *c_bv;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);
+
+ bv = make_bytevector (c_len);
+ c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ for (i = 0; i < c_len; lst = SCM_CDR (lst), i++)
+ {
+ item = SCM_CAR (lst);
+
+ if (SCM_LIKELY (SCM_I_INUMP (item)))
+ {
+ long c_item;
+
+ c_item = SCM_I_INUM (item);
+ if (SCM_LIKELY ((c_item >= 0) && (c_item < 256)))
+ c_bv[i] = (unsigned char) c_item;
+ else
+ goto type_error;
+ }
+ else
+ goto type_error;
+ }
+
+ return bv;
+
+ type_error:
+ scm_wrong_type_arg (FUNC_NAME, 1, item);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+/* Compute the two's complement of VALUE (a positive integer) on SIZE octets
+ using (2^(SIZE * 8) - VALUE). */
+static inline void
+twos_complement (mpz_t value, size_t size)
+{
+ unsigned long bit_count;
+
+ /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
+ checking on SIZE performed earlier. */
+ bit_count = (unsigned long) size << 3UL;
+
+ if (SCM_LIKELY (bit_count < sizeof (unsigned long)))
+ mpz_ui_sub (value, 1UL << bit_count, value);
+ else
+ {
+ mpz_t max;
+
+ mpz_init (max);
+ mpz_ui_pow_ui (max, 2, bit_count);
+ mpz_sub (value, max, value);
+ mpz_clear (max);
+ }
+}
+
+static inline SCM
+bytevector_large_ref (const char *c_bv, size_t c_size, int signed_p,
+ SCM endianness)
+{
+ SCM result;
+ mpz_t c_mpz;
+ int c_endianness, negative_p = 0;
+
+ if (signed_p)
+ {
+ if (scm_is_eq (endianness, scm_sym_big))
+ negative_p = c_bv[0] & 0x80;
+ else
+ negative_p = c_bv[c_size - 1] & 0x80;
+ }
+
+ c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
+
+ mpz_init (c_mpz);
+ mpz_import (c_mpz, 1 /* 1 word */, 1 /* word order doesn't matter */,
+ c_size /* word is C_SIZE-byte long */,
+ c_endianness,
+ 0 /* nails */, c_bv);
+
+ if (signed_p && negative_p)
+ {
+ twos_complement (c_mpz, c_size);
+ mpz_neg (c_mpz, c_mpz);
+ }
+
+ result = scm_from_mpz (c_mpz);
+ mpz_clear (c_mpz); /* FIXME: Needed? */
+
+ return result;
+}
+
+static inline int
+bytevector_large_set (char *c_bv, size_t c_size, int signed_p,
+ SCM value, SCM endianness)
+{
+ mpz_t c_mpz;
+ int c_endianness, c_sign, err = 0;
+
+ c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
+
+ mpz_init (c_mpz);
+ scm_to_mpz (value, c_mpz);
+
+ c_sign = mpz_sgn (c_mpz);
+ if (c_sign < 0)
+ {
+ if (SCM_LIKELY (signed_p))
+ {
+ mpz_neg (c_mpz, c_mpz);
+ twos_complement (c_mpz, c_size);
+ }
+ else
+ {
+ err = -1;
+ goto finish;
+ }
+ }
+
+ if (c_sign == 0)
+ /* Zero. */
+ memset (c_bv, 0, c_size);
+ else
+ {
+ size_t word_count, value_size;
+
+ value_size = (mpz_sizeinbase (c_mpz, 2) + (8 * c_size)) / (8 * c_size);
+ if (SCM_UNLIKELY (value_size > c_size))
+ {
+ err = -2;
+ goto finish;
+ }
+
+
+ mpz_export (c_bv, &word_count, 1 /* word order doesn't matter */,
+ c_size, c_endianness,
+ 0 /* nails */, c_mpz);
+ if (SCM_UNLIKELY (word_count != 1))
+ /* Shouldn't happen since we already checked with VALUE_SIZE. */
+ abort ();
+ }
+
+ finish:
+ mpz_clear (c_mpz);
+
+ return err;
+}
+
+#define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \
+ unsigned long c_len, c_index, c_size; \
+ char *c_bv; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, bv); \
+ c_index = scm_to_ulong (index); \
+ c_size = scm_to_ulong (size); \
+ \
+ c_len = SCM_BYTEVECTOR_LENGTH (bv); \
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
+ \
+ /* C_SIZE must have its 3 higher bits set to zero so that \
+ multiplying it by 8 yields a number that fits in an \
+ unsigned long. */ \
+ if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
+ scm_out_of_range (FUNC_NAME, size); \
+ if (SCM_UNLIKELY (c_index + c_size > c_len)) \
+ scm_out_of_range (FUNC_NAME, index);
+
+
+/* Template of an integer reference function. */
+#define GENERIC_INTEGER_REF(_sign) \
+ SCM result; \
+ \
+ if (c_size < 3) \
+ { \
+ int swap; \
+ _sign int value; \
+ \
+ swap = !scm_is_eq (endianness, native_endianness); \
+ switch (c_size) \
+ { \
+ case 1: \
+ { \
+ _sign char c_value8; \
+ memcpy (&c_value8, c_bv, 1); \
+ value = c_value8; \
+ } \
+ break; \
+ case 2: \
+ { \
+ INT_TYPE (16, _sign) c_value16; \
+ memcpy (&c_value16, c_bv, 2); \
+ if (swap) \
+ value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \
+ else \
+ value = c_value16; \
+ } \
+ break; \
+ default: \
+ abort (); \
+ } \
+ \
+ result = SCM_I_MAKINUM ((_sign int) value); \
+ } \
+ else \
+ result = bytevector_large_ref ((char *) c_bv, \
+ c_size, SIGNEDNESS (_sign), \
+ endianness); \
+ \
+ return result;
+
+static inline SCM
+bytevector_signed_ref (const char *c_bv, size_t c_size, SCM endianness)
+{
+ GENERIC_INTEGER_REF (signed);
+}
+
+static inline SCM
+bytevector_unsigned_ref (const char *c_bv, size_t c_size, SCM endianness)
+{
+ GENERIC_INTEGER_REF (unsigned);
+}
+
+
+/* Template of an integer assignment function. */
+#define GENERIC_INTEGER_SET(_sign) \
+ if (c_size < 3) \
+ { \
+ _sign int c_value; \
+ \
+ if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
+ goto range_error; \
+ \
+ c_value = SCM_I_INUM (value); \
+ switch (c_size) \
+ { \
+ case 1: \
+ if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \
+ { \
+ _sign char c_value8; \
+ c_value8 = (_sign char) c_value; \
+ memcpy (c_bv, &c_value8, 1); \
+ } \
+ else \
+ goto range_error; \
+ break; \
+ \
+ case 2: \
+ if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \
+ { \
+ int swap; \
+ INT_TYPE (16, _sign) c_value16; \
+ \
+ swap = !scm_is_eq (endianness, native_endianness); \
+ \
+ if (swap) \
+ c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \
+ else \
+ c_value16 = c_value; \
+ \
+ memcpy (c_bv, &c_value16, 2); \
+ } \
+ else \
+ goto range_error; \
+ break; \
+ \
+ default: \
+ abort (); \
+ } \
+ } \
+ else \
+ { \
+ int err; \
+ \
+ err = bytevector_large_set (c_bv, c_size, \
+ SIGNEDNESS (_sign), \
+ value, endianness); \
+ if (err) \
+ goto range_error; \
+ } \
+ \
+ return; \
+ \
+ range_error: \
+ scm_out_of_range (FUNC_NAME, value); \
+ return;
+
+static inline void
+bytevector_signed_set (char *c_bv, size_t c_size,
+ SCM value, SCM endianness,
+ const char *func_name)
+#define FUNC_NAME func_name
+{
+ GENERIC_INTEGER_SET (signed);
+}
+#undef FUNC_NAME
+
+static inline void
+bytevector_unsigned_set (char *c_bv, size_t c_size,
+ SCM value, SCM endianness,
+ const char *func_name)
+#define FUNC_NAME func_name
+{
+ GENERIC_INTEGER_SET (unsigned);
+}
+#undef FUNC_NAME
+
+#undef GENERIC_INTEGER_SET
+#undef GENERIC_INTEGER_REF
+
+
+SCM_DEFINE (scm_bytevector_uint_ref, "bytevector-uint-ref", 4, 0, 0,
+ (SCM bv, SCM index, SCM endianness, SCM size),
+ "Return the @var{size}-octet long unsigned integer at index "
+ "@var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_uint_ref
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
+
+ return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_sint_ref, "bytevector-sint-ref", 4, 0, 0,
+ (SCM bv, SCM index, SCM endianness, SCM size),
+ "Return the @var{size}-octet long unsigned integer at index "
+ "@var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_sint_ref
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
+
+ return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_uint_set_x, "bytevector-uint-set!", 5, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
+ "Set the @var{size}-octet long unsigned integer at @var{index} "
+ "to @var{value}.")
+#define FUNC_NAME s_scm_bytevector_uint_set_x
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
+
+ bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness,
+ FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
+ "Set the @var{size}-octet long signed integer at @var{index} "
+ "to @var{value}.")
+#define FUNC_NAME s_scm_bytevector_sint_set_x
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
+
+ bytevector_signed_set (&c_bv[c_index], c_size, value, endianness,
+ FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+
+/* Operations on integers of arbitrary size. */
+
+#define INTEGERS_TO_LIST(_sign) \
+ SCM lst, pair; \
+ size_t i, c_len, c_size; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, bv); \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ c_size = scm_to_uint (size); \
+ \
+ c_len = SCM_BYTEVECTOR_LENGTH (bv); \
+ if (SCM_UNLIKELY (c_len == 0)) \
+ lst = SCM_EOL; \
+ else if (SCM_UNLIKELY (c_len < c_size)) \
+ scm_out_of_range (FUNC_NAME, size); \
+ else \
+ { \
+ const char *c_bv; \
+ \
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
+ \
+ lst = scm_make_list (scm_from_uint (c_len / c_size), \
+ SCM_UNSPECIFIED); \
+ for (i = 0, pair = lst; \
+ i <= c_len - c_size; \
+ i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
+ { \
+ SCM_SETCAR (pair, \
+ bytevector_ ## _sign ## _ref (c_bv, c_size, \
+ endianness)); \
+ } \
+ } \
+ \
+ return lst;
+
+SCM_DEFINE (scm_bytevector_to_sint_list, "bytevector->sint-list",
+ 3, 0, 0,
+ (SCM bv, SCM endianness, SCM size),
+ "Return a list of signed integers of @var{size} octets "
+ "representing the contents of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_to_sint_list
+{
+ INTEGERS_TO_LIST (signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list",
+ 3, 0, 0,
+ (SCM bv, SCM endianness, SCM size),
+ "Return a list of unsigned integers of @var{size} octets "
+ "representing the contents of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_to_uint_list
+{
+ INTEGERS_TO_LIST (unsigned);
+}
+#undef FUNC_NAME
+
+#undef INTEGER_TO_LIST
+
+
+#define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
+ SCM bv; \
+ long c_len; \
+ size_t c_size; \
+ char *c_bv, *c_bv_ptr; \
+ \
+ SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ c_size = scm_to_uint (size); \
+ \
+ if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
+ scm_out_of_range (FUNC_NAME, size); \
+ \
+ bv = make_bytevector (c_len * c_size); \
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
+ \
+ for (c_bv_ptr = c_bv; \
+ !scm_is_null (lst); \
+ lst = SCM_CDR (lst), c_bv_ptr += c_size) \
+ { \
+ bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
+ SCM_CAR (lst), endianness, \
+ FUNC_NAME); \
+ } \
+ \
+ return bv;
+
+
+SCM_DEFINE (scm_uint_list_to_bytevector, "uint-list->bytevector",
+ 3, 0, 0,
+ (SCM lst, SCM endianness, SCM size),
+ "Return a bytevector containing the unsigned integers "
+ "listed in @var{lst} and encoded on @var{size} octets "
+ "according to @var{endianness}.")
+#define FUNC_NAME s_scm_uint_list_to_bytevector
+{
+ INTEGER_LIST_TO_BYTEVECTOR (unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sint_list_to_bytevector, "sint-list->bytevector",
+ 3, 0, 0,
+ (SCM lst, SCM endianness, SCM size),
+ "Return a bytevector containing the signed integers "
+ "listed in @var{lst} and encoded on @var{size} octets "
+ "according to @var{endianness}.")
+#define FUNC_NAME s_scm_sint_list_to_bytevector
+{
+ INTEGER_LIST_TO_BYTEVECTOR (signed);
+}
+#undef FUNC_NAME
+
+#undef INTEGER_LIST_TO_BYTEVECTOR
+
+
+
+/* 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 = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
+ SIGNEDNESS (_sign), value, endianness); \
+ if (SCM_UNLIKELY (err)) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ return SCM_UNSPECIFIED;
+
+#define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
+ INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
+ return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
+ SIGNEDNESS (_sign), native_endianness));
+
+#define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
+ int err; \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ \
+ err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
+ SIGNEDNESS (_sign), value, \
+ native_endianness); \
+ if (SCM_UNLIKELY (err)) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ return SCM_UNSPECIFIED;
+
+
+SCM_DEFINE (scm_bytevector_u32_ref, "bytevector-u32-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the unsigned 32-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_u32_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_REF (32, unsigned);
+#else
+ LARGE_INTEGER_REF (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_ref, "bytevector-s32-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the signed 32-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_s32_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_REF (32, signed);
+#else
+ LARGE_INTEGER_REF (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u32_native_ref, "bytevector-u32-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 32-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u32_native_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_REF (32, unsigned);
+#else
+ LARGE_INTEGER_NATIVE_REF (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_native_ref, "bytevector-s32-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 32-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s32_native_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_REF (32, signed);
+#else
+ LARGE_INTEGER_NATIVE_REF (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u32_set_x, "bytevector-u32-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_u32_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_SET (32, unsigned);
+#else
+ LARGE_INTEGER_SET (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_set_x, "bytevector-s32-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_s32_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_SET (32, signed);
+#else
+ LARGE_INTEGER_SET (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u32_native_set_x, "bytevector-u32-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the unsigned integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u32_native_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_SET (32, unsigned);
+#else
+ LARGE_INTEGER_NATIVE_SET (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_native_set_x, "bytevector-s32-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the signed integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s32_native_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_SET (32, signed);
+#else
+ LARGE_INTEGER_NATIVE_SET (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+
+
+/* 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 <ieee754.h>.
+ However, in R6RS, when the endianness is `little', little endian is
+ assumed for both the byte order and the word order. This is clear from
+ Section 2.1 of R6RS-lib (in response to
+ http://www.r6rs.org/formal-comments/comment-187.txt). */
+
+
+/* Convert to/from a floating-point number with different endianness. This
+ method is probably not the most efficient but it should be portable. */
+
+static inline void
+float_to_foreign_endianness (union scm_ieee754_float *target,
+ float source)
+{
+ union scm_ieee754_float src;
+
+ src.f = source;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ target->little_endian.negative = src.big_endian.negative;
+ target->little_endian.exponent = src.big_endian.exponent;
+ target->little_endian.mantissa = src.big_endian.mantissa;
+#else
+ target->big_endian.negative = src.little_endian.negative;
+ target->big_endian.exponent = src.little_endian.exponent;
+ target->big_endian.mantissa = src.little_endian.mantissa;
+#endif
+}
+
+static inline float
+float_from_foreign_endianness (const union scm_ieee754_float *source)
+{
+ union scm_ieee754_float result;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ result.big_endian.negative = source->little_endian.negative;
+ result.big_endian.exponent = source->little_endian.exponent;
+ result.big_endian.mantissa = source->little_endian.mantissa;
+#else
+ result.little_endian.negative = source->big_endian.negative;
+ result.little_endian.exponent = source->big_endian.exponent;
+ result.little_endian.mantissa = source->big_endian.mantissa;
+#endif
+
+ return (result.f);
+}
+
+static inline void
+double_to_foreign_endianness (union scm_ieee754_double *target,
+ double source)
+{
+ union scm_ieee754_double src;
+
+ src.d = source;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ target->little_little_endian.negative = src.big_endian.negative;
+ target->little_little_endian.exponent = src.big_endian.exponent;
+ target->little_little_endian.mantissa0 = src.big_endian.mantissa0;
+ target->little_little_endian.mantissa1 = src.big_endian.mantissa1;
+#else
+ target->big_endian.negative = src.little_little_endian.negative;
+ target->big_endian.exponent = src.little_little_endian.exponent;
+ target->big_endian.mantissa0 = src.little_little_endian.mantissa0;
+ target->big_endian.mantissa1 = src.little_little_endian.mantissa1;
+#endif
+}
+
+static inline double
+double_from_foreign_endianness (const union scm_ieee754_double *source)
+{
+ union scm_ieee754_double result;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ result.big_endian.negative = source->little_little_endian.negative;
+ result.big_endian.exponent = source->little_little_endian.exponent;
+ result.big_endian.mantissa0 = source->little_little_endian.mantissa0;
+ result.big_endian.mantissa1 = source->little_little_endian.mantissa1;
+#else
+ result.little_little_endian.negative = source->big_endian.negative;
+ result.little_little_endian.exponent = source->big_endian.exponent;
+ result.little_little_endian.mantissa0 = source->big_endian.mantissa0;
+ result.little_little_endian.mantissa1 = source->big_endian.mantissa1;
+#endif
+
+ return (result.d);
+}
+
+/* Template macros to abstract over doubles and floats.
+ XXX: Guile can only convert to/from doubles. */
+#define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type
+#define IEEE754_TO_SCM(_c_type) scm_from_double
+#define IEEE754_FROM_SCM(_c_type) scm_to_double
+#define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
+ _c_type ## _from_foreign_endianness
+#define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
+ _c_type ## _to_foreign_endianness
+
+
+/* Templace getters and setters. */
+
+#define IEEE754_ACCESSOR_PROLOGUE(_type) \
+ INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
+
+#define IEEE754_REF(_type) \
+ _type c_result; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ if (scm_is_eq (endianness, native_endianness)) \
+ memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
+ else \
+ { \
+ IEEE754_UNION (_type) c_raw; \
+ \
+ memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
+ c_result = \
+ IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
+ } \
+ \
+ return (IEEE754_TO_SCM (_type) (c_result));
+
+#define IEEE754_NATIVE_REF(_type) \
+ _type c_result; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ \
+ memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
+ return (IEEE754_TO_SCM (_type) (c_result));
+
+#define IEEE754_SET(_type) \
+ _type c_value; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ SCM_VALIDATE_REAL (3, value); \
+ SCM_VALIDATE_SYMBOL (4, endianness); \
+ c_value = IEEE754_FROM_SCM (_type) (value); \
+ \
+ if (scm_is_eq (endianness, native_endianness)) \
+ memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
+ else \
+ { \
+ IEEE754_UNION (_type) c_raw; \
+ \
+ IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
+ memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
+ } \
+ \
+ return SCM_UNSPECIFIED;
+
+#define IEEE754_NATIVE_SET(_type) \
+ _type c_value; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ SCM_VALIDATE_REAL (3, value); \
+ c_value = IEEE754_FROM_SCM (_type) (value); \
+ \
+ memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
+ return SCM_UNSPECIFIED;
+
+
+/* Single precision. */
+
+SCM_DEFINE (scm_bytevector_ieee_single_ref,
+ "bytevector-ieee-single-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the IEEE-754 single from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_ref
+{
+ IEEE754_REF (float);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_single_native_ref,
+ "bytevector-ieee-single-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the IEEE-754 single from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_native_ref
+{
+ IEEE754_NATIVE_REF (float);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_single_set_x,
+ "bytevector-ieee-single-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store real @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_set_x
+{
+ IEEE754_SET (float);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_single_native_set_x,
+ "bytevector-ieee-single-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the real @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x
+{
+ IEEE754_NATIVE_SET (float);
+}
+#undef FUNC_NAME
+
+
+/* Double precision. */
+
+SCM_DEFINE (scm_bytevector_ieee_double_ref,
+ "bytevector-ieee-double-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the IEEE-754 double from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_ref
+{
+ IEEE754_REF (double);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_double_native_ref,
+ "bytevector-ieee-double-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the IEEE-754 double from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_native_ref
+{
+ IEEE754_NATIVE_REF (double);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_double_set_x,
+ "bytevector-ieee-double-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store real @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_set_x
+{
+ IEEE754_SET (double);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_double_native_set_x,
+ "bytevector-ieee-double-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the real @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x
+{
+ IEEE754_NATIVE_SET (double);
+}
+#undef FUNC_NAME
+
+
+#undef IEEE754_UNION
+#undef IEEE754_TO_SCM
+#undef IEEE754_FROM_SCM
+#undef IEEE754_FROM_FOREIGN_ENDIANNESS
+#undef IEEE754_TO_FOREIGN_ENDIANNESS
+#undef IEEE754_REF
+#undef IEEE754_NATIVE_REF
+#undef IEEE754_SET
+#undef IEEE754_NATIVE_SET
+
+
+/* Operations on strings. */
+
+
+/* Produce a function that returns the length of a UTF-encoded string. */
+#define UTF_STRLEN_FUNCTION(_utf_width) \
+static inline size_t \
+utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
+{ \
+ size_t len = 0; \
+ const uint ## _utf_width ## _t *ptr; \
+ for (ptr = str; \
+ *ptr != 0; \
+ ptr++) \
+ { \
+ len++; \
+ } \
+ \
+ return (len * ((_utf_width) / 8)); \
+}
+
+UTF_STRLEN_FUNCTION (8)
+
+
+/* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
+#define UTF_STRLEN(_utf_width, _str) \
+ utf ## _utf_width ## _strlen (_str)
+
+/* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
+ ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
+ encoding name). */
+static inline void
+utf_encoding_name (char *name, size_t utf_width, SCM endianness)
+{
+ strcpy (name, "UTF-");
+ strcat (name, ((utf_width == 8)
+ ? "8"
+ : ((utf_width == 16)
+ ? "16"
+ : ((utf_width == 32)
+ ? "32"
+ : "??"))));
+ strcat (name,
+ ((scm_is_eq (endianness, scm_sym_big))
+ ? "BE"
+ : ((scm_is_eq (endianness, scm_sym_little))
+ ? "LE"
+ : "unknown")));
+}
+
+/* Maximum length of a UTF encoding name. */
+#define MAX_UTF_ENCODING_NAME_LEN 16
+
+/* Produce the body of a `string->utf' function. */
+#define STRING_TO_UTF(_utf_width) \
+ SCM utf; \
+ int err; \
+ char *c_str; \
+ char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
+ char *c_utf = NULL, *c_locale; \
+ size_t c_strlen, c_raw_strlen, c_utf_len = 0; \
+ \
+ SCM_VALIDATE_STRING (1, str); \
+ if (endianness == SCM_UNDEFINED) \
+ endianness = scm_sym_big; \
+ else \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ \
+ c_strlen = scm_c_string_length (str); \
+ c_raw_strlen = c_strlen * ((_utf_width) / 8); \
+ do \
+ { \
+ c_str = (char *) alloca (c_raw_strlen + 1); \
+ c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \
+ } \
+ while (c_raw_strlen > c_strlen); \
+ c_str[c_raw_strlen] = '\0'; \
+ \
+ utf_encoding_name (c_utf_name, (_utf_width), endianness); \
+ \
+ c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
+ strcpy (c_locale, locale_charset ()); \
+ \
+ err = mem_iconveh (c_str, c_raw_strlen, \
+ c_locale, c_utf_name, \
+ iconveh_question_mark, NULL, \
+ &c_utf, &c_utf_len); \
+ if (SCM_UNLIKELY (err)) \
+ scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
+ scm_list_1 (str), err); \
+ else \
+ /* C_UTF is null-terminated. */ \
+ utf = scm_c_take_bytevector ((signed char *) c_utf, \
+ c_utf_len); \
+ \
+ return (utf);
+
+
+
+SCM_DEFINE (scm_string_to_utf8, "string->utf8",
+ 1, 0, 0,
+ (SCM str),
+ "Return a newly allocated bytevector that contains the UTF-8 "
+ "encoding of @var{str}.")
+#define FUNC_NAME s_scm_string_to_utf8
+{
+ SCM utf;
+ char *c_str;
+ uint8_t *c_utf;
+ size_t c_strlen, c_raw_strlen;
+
+ SCM_VALIDATE_STRING (1, str);
+
+ c_strlen = scm_c_string_length (str);
+ c_raw_strlen = c_strlen;
+ do
+ {
+ c_str = (char *) alloca (c_raw_strlen + 1);
+ c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen);
+ }
+ while (c_raw_strlen > c_strlen);
+ c_str[c_raw_strlen] = '\0';
+
+ c_utf = u8_strconv_from_locale (c_str);
+ if (SCM_UNLIKELY (c_utf == NULL))
+ scm_syserror (FUNC_NAME);
+ else
+ /* C_UTF is null-terminated. */
+ utf = scm_c_take_bytevector ((signed char *) c_utf,
+ UTF_STRLEN (8, c_utf));
+
+ return (utf);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_to_utf16, "string->utf16",
+ 1, 1, 0,
+ (SCM str, SCM endianness),
+ "Return a newly allocated bytevector that contains the UTF-16 "
+ "encoding of @var{str}.")
+#define FUNC_NAME s_scm_string_to_utf16
+{
+ STRING_TO_UTF (16);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_to_utf32, "string->utf32",
+ 1, 1, 0,
+ (SCM str, SCM endianness),
+ "Return a newly allocated bytevector that contains the UTF-32 "
+ "encoding of @var{str}.")
+#define FUNC_NAME s_scm_string_to_utf32
+{
+ STRING_TO_UTF (32);
+}
+#undef FUNC_NAME
+
+
+/* Produce the body of a function that converts a UTF-encoded bytevector to a
+ string. */
+#define UTF_TO_STRING(_utf_width) \
+ SCM str = SCM_BOOL_F; \
+ int err; \
+ char *c_str = NULL, *c_locale; \
+ char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
+ const char *c_utf; \
+ size_t c_strlen = 0, c_utf_len; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, utf); \
+ if (endianness == SCM_UNDEFINED) \
+ endianness = scm_sym_big; \
+ else \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ \
+ c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \
+ c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
+ utf_encoding_name (c_utf_name, (_utf_width), endianness); \
+ \
+ c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
+ strcpy (c_locale, locale_charset ()); \
+ \
+ err = mem_iconveh (c_utf, c_utf_len, \
+ c_utf_name, c_locale, \
+ iconveh_question_mark, NULL, \
+ &c_str, &c_strlen); \
+ if (SCM_UNLIKELY (err)) \
+ scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
+ scm_list_1 (utf), err); \
+ else \
+ /* C_STR is null-terminated. */ \
+ str = scm_take_locale_stringn (c_str, c_strlen); \
+ \
+ return (str);
+
+
+SCM_DEFINE (scm_utf8_to_string, "utf8->string",
+ 1, 0, 0,
+ (SCM utf),
+ "Return a newly allocate string that contains from the UTF-8-"
+ "encoded contents of bytevector @var{utf}.")
+#define FUNC_NAME s_scm_utf8_to_string
+{
+ SCM str;
+ int err;
+ char *c_str = NULL, *c_locale;
+ const char *c_utf;
+ size_t c_utf_len, c_strlen = 0;
+
+ SCM_VALIDATE_BYTEVECTOR (1, utf);
+
+ c_utf_len = SCM_BYTEVECTOR_LENGTH (utf);
+
+ c_locale = (char *) alloca (strlen (locale_charset ()) + 1);
+ strcpy (c_locale, locale_charset ());
+
+ c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf);
+ err = mem_iconveh (c_utf, c_utf_len,
+ "UTF-8", c_locale,
+ iconveh_question_mark, NULL,
+ &c_str, &c_strlen);
+ if (SCM_UNLIKELY (err))
+ scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A",
+ scm_list_1 (utf), err);
+ else
+ /* C_STR is null-terminated. */
+ str = scm_take_locale_stringn (c_str, c_strlen);
+
+ return (str);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_utf16_to_string, "utf16->string",
+ 1, 1, 0,
+ (SCM utf, SCM endianness),
+ "Return a newly allocate string that contains from the UTF-16-"
+ "encoded contents of bytevector @var{utf}.")
+#define FUNC_NAME s_scm_utf16_to_string
+{
+ UTF_TO_STRING (16);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_utf32_to_string, "utf32->string",
+ 1, 1, 0,
+ (SCM utf, SCM endianness),
+ "Return a newly allocate string that contains from the UTF-32-"
+ "encoded contents of bytevector @var{utf}.")
+#define FUNC_NAME s_scm_utf32_to_string
+{
+ UTF_TO_STRING (32);
+}
+#undef FUNC_NAME
+
+
+
+/* Initialization. */
+
+void
+scm_init_bytevectors (void)
+{
+#include "libguile/bytevectors.x"
+
+#ifdef WORDS_BIGENDIAN
+ native_endianness = scm_sym_big;
+#else
+ native_endianness = scm_sym_little;
+#endif
+
+ scm_endianness_big = scm_sym_big;
+ scm_endianness_little = scm_sym_little;
+
+ scm_null_bytevector =
+ scm_gc_protect_object (make_bytevector_from_buffer (0, NULL));
+}
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
new file mode 100644
index 000000000..98c38aca2
--- /dev/null
+++ b/libguile/bytevectors.h
@@ -0,0 +1,133 @@
+#ifndef SCM_BYTEVECTORS_H
+#define SCM_BYTEVECTORS_H
+
+/* Copyright (C) 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+
+#include "libguile/__scm.h"
+
+
+/* R6RS bytevectors. */
+
+#define SCM_BYTEVECTOR_LENGTH(_bv) \
+ ((unsigned) SCM_SMOB_DATA (_bv))
+#define SCM_BYTEVECTOR_CONTENTS(_bv) \
+ (SCM_BYTEVECTOR_INLINE_P (_bv) \
+ ? (signed char *) SCM_SMOB_OBJECT_2_LOC (_bv) \
+ : (signed char *) SCM_SMOB_DATA_2 (_bv))
+
+
+SCM_API SCM scm_endianness_big;
+SCM_API SCM scm_endianness_little;
+
+SCM_API SCM scm_make_bytevector (SCM, SCM);
+SCM_API SCM scm_c_make_bytevector (unsigned);
+SCM_API SCM scm_native_endianness (void);
+SCM_API SCM scm_bytevector_p (SCM);
+SCM_API SCM scm_bytevector_length (SCM);
+SCM_API SCM scm_bytevector_eq_p (SCM, SCM);
+SCM_API SCM scm_bytevector_fill_x (SCM, SCM);
+SCM_API SCM scm_bytevector_copy_x (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_copy (SCM);
+
+SCM_API SCM scm_bytevector_to_u8_list (SCM);
+SCM_API SCM scm_u8_list_to_bytevector (SCM);
+SCM_API SCM scm_uint_list_to_bytevector (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_to_uint_list (SCM, SCM, SCM);
+SCM_API SCM scm_sint_list_to_bytevector (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_to_sint_list (SCM, SCM, SCM);
+
+SCM_API SCM scm_bytevector_u16_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s16_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_u32_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s32_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_u64_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s64_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_u8_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s8_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_uint_ref (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_sint_ref (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u16_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s16_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u32_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s32_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u64_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s64_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u16_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s16_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u32_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s32_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u64_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s64_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u8_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s8_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_uint_set_x (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_sint_set_x (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u16_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s16_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u32_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s32_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u64_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s64_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_string_to_utf8 (SCM);
+SCM_API SCM scm_string_to_utf16 (SCM, SCM);
+SCM_API SCM scm_string_to_utf32 (SCM, SCM);
+SCM_API SCM scm_utf8_to_string (SCM);
+SCM_API SCM scm_utf16_to_string (SCM, SCM);
+SCM_API SCM scm_utf32_to_string (SCM, SCM);
+
+
+
+/* Internal API. */
+
+/* The threshold (in octets) under which bytevectors are stored "in-line",
+ i.e., without allocating memory beside the SMOB itself (a double cell).
+ This optimization is necessary since small bytevectors are expected to be
+ common. */
+#define SCM_BYTEVECTOR_INLINE_THRESHOLD (2 * sizeof (SCM))
+#define SCM_BYTEVECTOR_INLINEABLE_SIZE_P(_size) \
+ ((_size) <= SCM_BYTEVECTOR_INLINE_THRESHOLD)
+#define SCM_BYTEVECTOR_INLINE_P(_bv) \
+ (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (SCM_BYTEVECTOR_LENGTH (_bv)))
+
+/* Hint that is passed to `scm_gc_malloc ()' and friends. */
+#define SCM_GC_BYTEVECTOR "bytevector"
+
+SCM_API void scm_init_bytevectors (void);
+
+SCM_INTERNAL scm_t_bits scm_tc16_bytevector;
+SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, unsigned);
+
+#define scm_c_shrink_bytevector(_bv, _len) \
+ (SCM_BYTEVECTOR_INLINE_P (_bv) \
+ ? (_bv) \
+ : scm_i_shrink_bytevector ((_bv), (_len)))
+
+SCM_INTERNAL SCM scm_i_shrink_bytevector (SCM, unsigned);
+SCM_INTERNAL SCM scm_null_bytevector;
+
+#endif /* SCM_BYTEVECTORS_H */
diff --git a/libguile/eval.c b/libguile/eval.c
index 19ac0b155..05af5a1c5 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -2140,6 +2140,25 @@ unmemoize_at_call_with_values (const SCM expr, const SCM env)
unmemoize_exprs (SCM_CDR (expr), env));
}
+SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when);
+SCM_GLOBAL_SYMBOL (scm_sym_eval_when, s_eval_when);
+SCM_SYMBOL (sym_eval, "eval");
+SCM_SYMBOL (sym_load, "load");
+
+
+SCM
+scm_m_eval_when (SCM expr, SCM env SCM_UNUSED)
+{
+ ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
+
+ if (scm_is_true (scm_memq (sym_eval, scm_cadr (expr)))
+ || scm_is_true (scm_memq (sym_load, scm_cadr (expr))))
+ return scm_cons (SCM_IM_BEGIN, scm_cddr (expr));
+
+ return scm_list_1 (SCM_IM_BEGIN);
+}
+
#if 0
/* See futures.h for a comment why futures are not enabled.
diff --git a/libguile/eval.h b/libguile/eval.h
index f3ec2e19c..b017f2e02 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -100,6 +100,7 @@ SCM_API SCM scm_sym_atapply;
SCM_API SCM scm_sym_atcall_cc;
SCM_API SCM scm_sym_at_call_with_values;
SCM_API SCM scm_sym_delay;
+SCM_API SCM scm_sym_eval_when;
SCM_API SCM scm_sym_arrow;
SCM_API SCM scm_sym_else;
SCM_API SCM scm_sym_apply;
@@ -146,6 +147,7 @@ SCM_API SCM scm_m_atslot_ref (SCM xorig, SCM env);
SCM_API SCM scm_m_atslot_set_x (SCM xorig, SCM env);
SCM_API SCM scm_m_atdispatch (SCM xorig, SCM env);
SCM_API SCM scm_m_at_call_with_values (SCM xorig, SCM env);
+SCM_API SCM scm_m_eval_when (SCM xorig, SCM env);
SCM_API int scm_badargsp (SCM formals, SCM args);
SCM_API SCM scm_call_0 (SCM proc);
SCM_API SCM scm_call_1 (SCM proc, SCM arg1);
diff --git a/libguile/frames.c b/libguile/frames.c
index f53cade95..c08fd3134 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * 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, 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 software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * 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.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#if HAVE_CONFIG_H
# include <config.h>
@@ -45,6 +21,7 @@
#include <stdlib.h>
#include <string.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "frames.h"
diff --git a/libguile/frames.h b/libguile/frames.h
index 836763700..d74476ac8 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 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 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, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
+ * 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#ifndef _SCM_FRAMES_H_
#define _SCM_FRAMES_H_
@@ -97,7 +73,7 @@
* Heap frames
*/
-extern scm_t_bits scm_tc16_vm_frame;
+SCM_API scm_t_bits scm_tc16_vm_frame;
struct scm_vm_frame
{
@@ -118,24 +94,24 @@ struct scm_vm_frame
#define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
/* FIXME rename scm_byte_t */
-extern SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
+SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
scm_byte_t *ip, scm_t_ptrdiff offset);
-extern SCM scm_vm_frame_p (SCM obj);
-extern SCM scm_vm_frame_program (SCM frame);
-extern SCM scm_vm_frame_arguments (SCM frame);
-extern SCM scm_vm_frame_source (SCM frame);
-extern SCM scm_vm_frame_local_ref (SCM frame, SCM index);
-extern SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
-extern SCM scm_vm_frame_return_address (SCM frame);
-extern SCM scm_vm_frame_mv_return_address (SCM frame);
-extern SCM scm_vm_frame_dynamic_link (SCM frame);
-extern SCM scm_vm_frame_external_link (SCM frame);
-extern SCM scm_vm_frame_stack (SCM frame);
-
-extern SCM scm_c_vm_frame_prev (SCM frame);
-
-extern void scm_bootstrap_frames (void);
-extern void scm_init_frames (void);
+SCM_API SCM scm_vm_frame_p (SCM obj);
+SCM_API SCM scm_vm_frame_program (SCM frame);
+SCM_API SCM scm_vm_frame_arguments (SCM frame);
+SCM_API SCM scm_vm_frame_source (SCM frame);
+SCM_API SCM scm_vm_frame_local_ref (SCM frame, SCM index);
+SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
+SCM_API SCM scm_vm_frame_return_address (SCM frame);
+SCM_API SCM scm_vm_frame_mv_return_address (SCM frame);
+SCM_API SCM scm_vm_frame_dynamic_link (SCM frame);
+SCM_API SCM scm_vm_frame_external_link (SCM frame);
+SCM_API SCM scm_vm_frame_stack (SCM frame);
+
+SCM_API SCM scm_c_vm_frame_prev (SCM frame);
+
+SCM_INTERNAL void scm_bootstrap_frames (void);
+SCM_INTERNAL void scm_init_frames (void);
#endif /* _SCM_FRAMES_H_ */
diff --git a/libguile/ieee-754.h b/libguile/ieee-754.h
new file mode 100644
index 000000000..e345efaae
--- /dev/null
+++ b/libguile/ieee-754.h
@@ -0,0 +1,90 @@
+/* Copyright (C) 1992, 1995, 1996, 1999 Free Software Foundation, Inc.
+ This file is part of the GNU C Library.
+
+ The GNU C Library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
+
+ The GNU C Library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with the GNU C Library; if not, write to the Free
+ Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+ 02111-1307 USA. */
+
+#ifndef SCM_IEEE_754_H
+#define SCM_IEEE_754_H 1
+
+/* Based on glibc's <ieee754.h> and modified by Ludovic Courtès to include
+ all possible IEEE-754 double-precision representations. */
+
+
+/* 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/instructions.c b/libguile/instructions.c
index 4f504f0a2..f0f52e422 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -1,49 +1,27 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * 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, 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 software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * 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.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#if HAVE_CONFIG_H
# include <config.h>
#endif
#include <string.h>
+
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "instructions.h"
diff --git a/libguile/instructions.h b/libguile/instructions.h
index 4968671b5..f4f45b371 100644
--- a/libguile/instructions.h
+++ b/libguile/instructions.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * 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, 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 software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * 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.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#ifndef _SCM_INSTRUCTIONS_H_
#define _SCM_INSTRUCTIONS_H_
@@ -57,16 +33,16 @@ enum scm_opcode {
scm_op_last = SCM_VM_NUM_INSTRUCTIONS
};
-extern SCM scm_instruction_list (void);
-extern SCM scm_instruction_p (SCM obj);
-extern SCM scm_instruction_length (SCM inst);
-extern SCM scm_instruction_pops (SCM inst);
-extern SCM scm_instruction_pushes (SCM inst);
-extern SCM scm_instruction_to_opcode (SCM inst);
-extern SCM scm_opcode_to_instruction (SCM op);
+SCM_API SCM scm_instruction_list (void);
+SCM_API SCM scm_instruction_p (SCM obj);
+SCM_API SCM scm_instruction_length (SCM inst);
+SCM_API SCM scm_instruction_pops (SCM inst);
+SCM_API SCM scm_instruction_pushes (SCM inst);
+SCM_API SCM scm_instruction_to_opcode (SCM inst);
+SCM_API SCM scm_opcode_to_instruction (SCM op);
-extern void scm_bootstrap_instructions (void);
-extern void scm_init_instructions (void);
+SCM_INTERNAL void scm_bootstrap_instructions (void);
+SCM_INTERNAL void scm_init_instructions (void);
#endif /* _SCM_INSTRUCTIONS_H_ */
diff --git a/libguile/macros.c b/libguile/macros.c
index d132c0159..ca3e83e29 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -48,10 +48,13 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
|| scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
macro, port, pstate)))
{
+ scm_puts ("#<", port);
+
+ if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro))
+ scm_puts ("extended-", port);
+
if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code))
- scm_puts ("#<primitive-", port);
- else
- scm_puts ("#<", port);
+ scm_puts ("primitive-", port);
if (SCM_MACRO_TYPE (macro) == 0)
scm_puts ("syntax", port);
@@ -63,6 +66,8 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
scm_puts ("macro!", port);
if (SCM_MACRO_TYPE (macro) == 3)
scm_puts ("builtin-macro!", port);
+ if (SCM_MACRO_TYPE (macro) == 4)
+ scm_puts ("syncase-macro", port);
scm_putc (' ', port);
scm_iprin1 (scm_macro_name (macro), port, pstate);
@@ -77,6 +82,14 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
scm_iprin1 (src, port, pstate);
}
+ if (SCM_MACRO_IS_EXTENDED (macro))
+ {
+ scm_putc (' ', port);
+ scm_write (SCM_SMOB_OBJECT_2 (macro), port);
+ scm_putc (' ', port);
+ scm_write (SCM_SMOB_OBJECT_3 (macro), port);
+ }
+
scm_putc ('>', port);
}
@@ -84,6 +97,16 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
}
static SCM
+macro_mark (SCM macro)
+{
+ if (SCM_MACRO_IS_EXTENDED (macro))
+ { scm_gc_mark (SCM_SMOB_OBJECT_2 (macro));
+ scm_gc_mark (SCM_SMOB_OBJECT_3 (macro));
+ }
+ return SCM_SMOB_OBJECT (macro);
+}
+
+static SCM
makmac (SCM code, scm_t_bits flags)
{
SCM z;
@@ -164,11 +187,45 @@ SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0,
#endif
+SCM_DEFINE (scm_make_syncase_macro, "make-syncase-macro", 2, 0, 0,
+ (SCM type, SCM binding),
+ "Return a @dfn{macro} that requires expansion by syntax-case.\n"
+ "While users should not call this function, it is useful to know\n"
+ "that syntax-case macros are represented as Guile primitive macros.")
+#define FUNC_NAME s_scm_make_syncase_macro
+{
+ SCM z;
+ SCM_VALIDATE_SYMBOL (1, type);
+
+ SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_UNPACK (binding), SCM_UNPACK (type),
+ SCM_UNPACK (binding));
+ SCM_SET_SMOB_FLAGS (z, 4 | SCM_F_MACRO_EXTENDED);
+ return z;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_extended_syncase_macro, "make-extended-syncase-macro", 3, 0, 0,
+ (SCM m, SCM type, SCM binding),
+ "Extend a core macro @var{m} with a syntax-case binding.")
+#define FUNC_NAME s_scm_make_extended_syncase_macro
+{
+ SCM z;
+ SCM_VALIDATE_SMOB (1, m, macro);
+ SCM_VALIDATE_SYMBOL (2, type);
+
+ SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_SMOB_DATA (m), SCM_UNPACK (type),
+ SCM_UNPACK (binding));
+ SCM_SET_SMOB_FLAGS (z, SCM_SMOB_FLAGS (m) | SCM_F_MACRO_EXTENDED);
+ return z;
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0,
(SCM obj),
- "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a\n"
- "syntax transformer.")
+ "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro, a\n"
+ "syntax transformer, or a syntax-case macro.")
#define FUNC_NAME s_scm_macro_p
{
return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_macro, obj));
@@ -182,14 +239,15 @@ SCM_SYMBOL (scm_sym_macro, "macro");
#endif
SCM_SYMBOL (scm_sym_mmacro, "macro!");
SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!");
+SCM_SYMBOL (scm_sym_syncase_macro, "syncase-macro");
SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
(SCM m),
- "Return one of the symbols @code{syntax}, @code{macro} or\n"
- "@code{macro!}, depending on whether @var{m} is a syntax\n"
- "transformer, a regular macro, or a memoizing macro,\n"
- "respectively. If @var{m} is not a macro, @code{#f} is\n"
- "returned.")
+ "Return one of the symbols @code{syntax}, @code{macro},\n"
+ "@code{macro!}, or @code{syntax-case}, depending on whether\n"
+ "@var{m} is a syntax transformer, a regular macro, a memoizing\n"
+ "macro, or a syntax-case macro, respectively. If @var{m} is\n"
+ "not a macro, @code{#f} is returned.")
#define FUNC_NAME s_scm_macro_type
{
if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m))
@@ -202,6 +260,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
#endif
case 2: return scm_sym_mmacro;
case 3: return scm_sym_bimacro;
+ case 4: return scm_sym_syncase_macro;
default: scm_wrong_type_arg (FUNC_NAME, 1, m);
}
}
@@ -214,7 +273,9 @@ SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0,
#define FUNC_NAME s_scm_macro_name
{
SCM_VALIDATE_SMOB (1, m, macro);
- return scm_procedure_name (SCM_PACK (SCM_SMOB_DATA (m)));
+ if (scm_is_true (scm_procedure_p (SCM_SMOB_OBJECT (m))))
+ return scm_procedure_name (SCM_SMOB_OBJECT (m));
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -236,6 +297,34 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_syncase_macro_type, "syncase-macro-type", 1, 0, 0,
+ (SCM m),
+ "Return the type of the macro @var{m}.")
+#define FUNC_NAME s_scm_syncase_macro_type
+{
+ SCM_VALIDATE_SMOB (1, m, macro);
+
+ if (SCM_MACRO_IS_EXTENDED (m))
+ return SCM_SMOB_OBJECT_2 (m);
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_syncase_macro_binding, "syncase-macro-binding", 1, 0, 0,
+ (SCM m),
+ "Return the binding of the macro @var{m}.")
+#define FUNC_NAME s_scm_syncase_macro_binding
+{
+ SCM_VALIDATE_SMOB (1, m, macro);
+
+ if (SCM_MACRO_IS_EXTENDED (m))
+ return SCM_SMOB_OBJECT_3 (m);
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
SCM
scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() )
{
@@ -249,7 +338,7 @@ void
scm_init_macros ()
{
scm_tc16_macro = scm_make_smob_type ("macro", 0);
- scm_set_smob_mark (scm_tc16_macro, scm_markcdr);
+ scm_set_smob_mark (scm_tc16_macro, macro_mark);
scm_set_smob_print (scm_tc16_macro, macro_print);
#include "libguile/macros.x"
}
diff --git a/libguile/macros.h b/libguile/macros.h
index e1de77ff9..5e3d64a55 100644
--- a/libguile/macros.h
+++ b/libguile/macros.h
@@ -29,9 +29,15 @@
#define SCM_ASSYNT(_cond, _msg, _subr) \
if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL);
+#define SCM_MACRO_TYPE_BITS (3)
+#define SCM_MACRO_TYPE_MASK ((1<<SCM_MACRO_TYPE_BITS)-1)
+#define SCM_F_MACRO_EXTENDED (1<<SCM_MACRO_TYPE_BITS)
+
#define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x))
-#define SCM_MACRO_TYPE(m) SCM_SMOB_FLAGS (m)
+#define SCM_MACRO_TYPE(m) (SCM_SMOB_FLAGS (m) & SCM_MACRO_TYPE_MASK)
+#define SCM_MACRO_IS_EXTENDED(m) (SCM_SMOB_FLAGS (m) & SCM_F_MACRO_EXTENDED)
#define SCM_BUILTIN_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 3)
+#define SCM_SYNCASE_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 4)
#define SCM_MACRO_CODE(m) SCM_SMOB_OBJECT (m)
SCM_API scm_t_bits scm_tc16_macro;
@@ -39,10 +45,15 @@ SCM_API scm_t_bits scm_tc16_macro;
SCM_INTERNAL SCM scm_i_makbimacro (SCM code);
SCM_API SCM scm_makmmacro (SCM code);
SCM_API SCM scm_makacro (SCM code);
+SCM_API SCM scm_make_syncase_macro (SCM type, SCM binding);
+SCM_API SCM scm_make_extended_syncase_macro (SCM builtin, SCM type,
+ SCM binding);
SCM_API SCM scm_macro_p (SCM obj);
SCM_API SCM scm_macro_type (SCM m);
SCM_API SCM scm_macro_name (SCM m);
SCM_API SCM scm_macro_transformer (SCM m);
+SCM_API SCM scm_syncase_macro_type (SCM m);
+SCM_API SCM scm_syncase_macro_binding (SCM m);
SCM_API SCM scm_make_synt (const char *name,
SCM (*macroizer) (SCM),
SCM (*fcn) ());
diff --git a/libguile/modules.c b/libguile/modules.c
index 2cb8a7620..689510ce6 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -412,13 +412,13 @@ SCM_DEFINE (scm_module_local_variable, "module-local-variable", 2, 0, 0,
register SCM b;
- /* SCM_MODULE_TAG is not initialized yet when `boot-9.scm' is being
- evaluated. */
if (scm_module_system_booted_p)
SCM_VALIDATE_MODULE (1, module);
SCM_VALIDATE_SYMBOL (2, sym);
+ if (scm_is_false (module))
+ return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED);
/* 1. Check module obarray */
b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 8bc203dda..6a0a11b29 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * 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, 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 software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * 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.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#if HAVE_CONFIG_H
# include <config.h>
@@ -51,6 +27,7 @@
#include <sys/types.h>
#include <assert.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "programs.h"
#include "objcodes.h"
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 222691668..acd43a600 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 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 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, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
+ * 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#ifndef _SCM_OBJCODES_H_
#define _SCM_OBJCODES_H_
@@ -60,7 +36,7 @@ struct scm_objcode {
#define SCM_F_OBJCODE_IS_U8VECTOR (1<<1)
#define SCM_F_OBJCODE_IS_SLICE (1<<2)
-extern scm_t_bits scm_tc16_objcode;
+SCM_API scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x))
#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x))
@@ -80,15 +56,15 @@ extern scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE)
SCM scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr);
-extern SCM scm_load_objcode (SCM file);
-extern SCM scm_objcode_p (SCM obj);
-extern SCM scm_objcode_meta (SCM objcode);
-extern SCM scm_bytecode_to_objcode (SCM bytecode);
-extern SCM scm_objcode_to_bytecode (SCM objcode);
-extern SCM scm_write_objcode (SCM objcode, SCM port);
+SCM_API SCM scm_load_objcode (SCM file);
+SCM_API SCM scm_objcode_p (SCM obj);
+SCM_API SCM scm_objcode_meta (SCM objcode);
+SCM_API SCM scm_bytecode_to_objcode (SCM bytecode);
+SCM_API SCM scm_objcode_to_bytecode (SCM objcode);
+SCM_API SCM scm_write_objcode (SCM objcode, SCM port);
-extern void scm_bootstrap_objcodes (void);
-extern void scm_init_objcodes (void);
+SCM_INTERNAL void scm_bootstrap_objcodes (void);
+SCM_INTERNAL void scm_init_objcodes (void);
#endif /* _SCM_OBJCODES_H_ */
diff --git a/libguile/posix.c b/libguile/posix.c
index 2799209d9..5e6f05fb7 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -101,8 +101,6 @@ extern char *ttyname();
#include <signal.h>
-extern char ** environ;
-
#ifdef HAVE_GRP_H
#include <grp.h>
#endif
@@ -140,10 +138,6 @@ extern char ** environ;
#include <sys/file.h> /* from Gnulib */
-#if HAVE_CRT_EXTERNS_H
-#include <crt_externs.h> /* for Darwin _NSGetEnviron */
-#endif
-
/* Some Unix systems don't define these. CPP hair is dangerous, but
this seems safe enough... */
#ifndef R_OK
@@ -196,13 +190,6 @@ int sethostname (char *name, size_t namelen);
-/* On Apple Darwin in a shared library there's no "environ" to access
- directly, instead the address of that variable must be obtained with
- _NSGetEnviron(). */
-#if HAVE__NSGETENVIRON && defined (PIC)
-#define environ (*_NSGetEnviron())
-#endif
-
/* Two often used patterns
diff --git a/libguile/programs.c b/libguile/programs.c
index 8e8982994..68e0b8541 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -1,49 +1,26 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * 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, 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 software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * 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.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#if HAVE_CONFIG_H
# include <config.h>
#endif
#include <string.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "instructions.h"
#include "modules.h"
diff --git a/libguile/programs.h b/libguile/programs.h
index 68a6936a2..ae819ef85 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * 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, 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 software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * 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.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#ifndef _SCM_PROGRAMS_H_
#define _SCM_PROGRAMS_H_
@@ -51,7 +27,7 @@
typedef unsigned char scm_byte_t;
-extern scm_t_bits scm_tc16_program;
+SCM_API scm_t_bits scm_tc16_program;
#define SCM_F_PROGRAM_IS_BOOT (1<<0)
@@ -63,27 +39,27 @@ extern scm_t_bits scm_tc16_program;
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
#define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT)
-extern SCM scm_make_program (SCM objcode, SCM objtable, SCM externals);
+SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM externals);
-extern SCM scm_program_p (SCM obj);
-extern SCM scm_program_base (SCM program);
-extern SCM scm_program_arity (SCM program);
-extern SCM scm_program_meta (SCM program);
-extern SCM scm_program_bindings (SCM program);
-extern SCM scm_program_sources (SCM program);
-extern SCM scm_program_source (SCM program, SCM ip);
-extern SCM scm_program_properties (SCM program);
-extern SCM scm_program_name (SCM program);
-extern SCM scm_program_objects (SCM program);
-extern SCM scm_program_module (SCM program);
-extern SCM scm_program_external (SCM program);
-extern SCM scm_program_external_set_x (SCM program, SCM external);
-extern SCM scm_program_objcode (SCM program);
+SCM_API SCM scm_program_p (SCM obj);
+SCM_API SCM scm_program_base (SCM program);
+SCM_API SCM scm_program_arity (SCM program);
+SCM_API SCM scm_program_meta (SCM program);
+SCM_API SCM scm_program_bindings (SCM program);
+SCM_API SCM scm_program_sources (SCM program);
+SCM_API SCM scm_program_source (SCM program, SCM ip);
+SCM_API SCM scm_program_properties (SCM program);
+SCM_API SCM scm_program_name (SCM program);
+SCM_API SCM scm_program_objects (SCM program);
+SCM_API SCM scm_program_module (SCM program);
+SCM_API SCM scm_program_external (SCM program);
+SCM_API SCM scm_program_external_set_x (SCM program, SCM external);
+SCM_API SCM scm_program_objcode (SCM program);
-extern SCM scm_c_program_source (SCM program, size_t ip);
+SCM_API SCM scm_c_program_source (SCM program, size_t ip);
-extern void scm_bootstrap_programs (void);
-extern void scm_init_programs (void);
+SCM_INTERNAL void scm_bootstrap_programs (void);
+SCM_INTERNAL void scm_init_programs (void);
#endif /* _SCM_PROGRAMS_H_ */
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
new file mode 100644
index 000000000..a07636fce
--- /dev/null
+++ b/libguile/r6rs-ports.c
@@ -0,0 +1,1118 @@
+/* Copyright (C) 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+# include <unistd.h>
+#endif
+
+#include <string.h>
+#include <stdio.h>
+#include <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/bytevectors.h"
+#include "libguile/chars.h"
+#include "libguile/eval.h"
+#include "libguile/r6rs-ports.h"
+#include "libguile/strings.h"
+#include "libguile/validate.h"
+#include "libguile/values.h"
+#include "libguile/vectors.h"
+
+
+
+/* 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 = 0;
+
+static inline SCM
+make_bip (SCM bv)
+{
+ SCM port;
+ char *c_bv;
+ unsigned c_len;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
+
+ port = scm_new_port_table_entry (bytevector_input_port_type);
+
+ /* Prevent BV from being GC'd. */
+ SCM_SETSTREAM (port, SCM_UNPACK (bv));
+
+ /* Have the port directly access the bytevector. */
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
+ c_port->read_end = (unsigned char *) c_bv + c_len;
+ c_port->read_buf_size = c_len;
+
+ /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
+ SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits);
+
+ return port;
+}
+
+static SCM
+bip_mark (SCM port)
+{
+ /* Mark the underlying bytevector. */
+ return (SCM_PACK (SCM_STREAM (port)));
+}
+
+static int
+bip_fill_input (SCM port)
+{
+ int result;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ if (c_port->read_pos >= c_port->read_end)
+ result = EOF;
+ else
+ result = (int) *c_port->read_pos;
+
+ return result;
+}
+
+static off_t
+bip_seek (SCM port, off_t offset, int whence)
+#define FUNC_NAME "bip_seek"
+{
+ off_t c_result = 0;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ switch (whence)
+ {
+ case SEEK_CUR:
+ offset += c_port->read_pos - c_port->read_buf;
+ /* Fall through. */
+
+ case SEEK_SET:
+ if (c_port->read_buf + offset < c_port->read_end)
+ {
+ c_port->read_pos = c_port->read_buf + offset;
+ c_result = offset;
+ }
+ else
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ break;
+
+ case SEEK_END:
+ if (c_port->read_end - offset >= c_port->read_buf)
+ {
+ c_port->read_pos = c_port->read_end - offset;
+ c_result = c_port->read_pos - c_port->read_buf;
+ }
+ else
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ break;
+
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "invalid `seek' parameter");
+ }
+
+ return c_result;
+}
+#undef FUNC_NAME
+
+
+/* Instantiate the bytevector input port type. */
+static inline void
+initialize_bytevector_input_ports (void)
+{
+ bytevector_input_port_type =
+ scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input,
+ NULL);
+
+ scm_set_port_mark (bytevector_input_port_type, bip_mark);
+ scm_set_port_seek (bytevector_input_port_type, bip_seek);
+}
+
+
+SCM_DEFINE (scm_open_bytevector_input_port,
+ "open-bytevector-input-port", 1, 1, 0,
+ (SCM bv, SCM transcoder),
+ "Return an input port whose contents are drawn from "
+ "bytevector @var{bv}.")
+#define FUNC_NAME s_scm_open_bytevector_input_port
+{
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+ if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
+ transcoders_not_implemented ();
+
+ return (make_bip (bv));
+}
+#undef FUNC_NAME
+
+
+/* Custom binary ports. The following routines are shared by input and
+ output custom binary ports. */
+
+#define SCM_CBP_GET_POSITION_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
+#define SCM_CBP_SET_POSITION_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
+#define SCM_CBP_CLOSE_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
+
+static SCM
+cbp_mark (SCM port)
+{
+ /* Mark the underlying method and object vector. */
+ return (SCM_PACK (SCM_STREAM (port)));
+}
+
+static off_t
+cbp_seek (SCM port, off_t offset, int whence)
+#define FUNC_NAME "cbp_seek"
+{
+ SCM result;
+ off_t c_result = 0;
+
+ switch (whence)
+ {
+ case SEEK_CUR:
+ {
+ SCM get_position_proc;
+
+ get_position_proc = SCM_CBP_GET_POSITION_PROC (port);
+ if (SCM_LIKELY (scm_is_true (get_position_proc)))
+ result = scm_call_0 (get_position_proc);
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "R6RS custom binary port does not "
+ "support `port-position'");
+
+ offset += scm_to_int (result);
+ /* Fall through. */
+ }
+
+ case SEEK_SET:
+ {
+ SCM set_position_proc;
+
+ set_position_proc = SCM_CBP_SET_POSITION_PROC (port);
+ if (SCM_LIKELY (scm_is_true (set_position_proc)))
+ result = scm_call_1 (set_position_proc, scm_from_int (offset));
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "R6RS custom binary port does not "
+ "support `set-port-position!'");
+
+ /* Assuming setting the position succeeded. */
+ c_result = offset;
+ break;
+ }
+
+ default:
+ /* `SEEK_END' cannot be supported. */
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "R6RS custom binary ports do not "
+ "support `SEEK_END'");
+ }
+
+ return c_result;
+}
+#undef FUNC_NAME
+
+static int
+cbp_close (SCM port)
+{
+ SCM close_proc;
+
+ close_proc = SCM_CBP_CLOSE_PROC (port);
+ if (scm_is_true (close_proc))
+ /* Invoke the `close' thunk. */
+ scm_call_0 (close_proc);
+
+ return 1;
+}
+
+
+/* Custom binary input port ("cbip" for short). */
+
+static scm_t_bits custom_binary_input_port_type = 0;
+
+/* Size of the buffer embedded in custom binary input ports. */
+#define CBIP_BUFFER_SIZE 4096
+
+/* Return the bytevector associated with PORT. */
+#define SCM_CBIP_BYTEVECTOR(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
+
+/* Return the various procedures of PORT. */
+#define SCM_CBIP_READ_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
+
+
+static inline SCM
+make_cbip (SCM read_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc)
+{
+ SCM port, bv, method_vector;
+ char *c_bv;
+ unsigned c_len;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
+
+ /* Use a bytevector as the underlying buffer. */
+ c_len = CBIP_BUFFER_SIZE;
+ bv = scm_c_make_bytevector (c_len);
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ /* Store the various methods and bytevector in a vector. */
+ method_vector = scm_c_make_vector (5, SCM_BOOL_F);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 4, bv);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 0, read_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
+
+ port = scm_new_port_table_entry (custom_binary_input_port_type);
+
+ /* Attach it the method vector. */
+ SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
+
+ /* Have the port directly access the buffer (bytevector). */
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
+ c_port->read_end = (unsigned char *) c_bv;
+ c_port->read_buf_size = c_len;
+
+ /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
+ SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits);
+
+ return port;
+}
+
+static int
+cbip_fill_input (SCM port)
+#define FUNC_NAME "cbip_fill_input"
+{
+ int result;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ again:
+ if (c_port->read_pos >= c_port->read_end)
+ {
+ /* Invoke the user's `read!' procedure. */
+ unsigned c_octets;
+ SCM bv, read_proc, octets;
+
+ /* Use the bytevector associated with PORT as the buffer passed to the
+ `read!' procedure, thereby avoiding additional allocations. */
+ bv = SCM_CBIP_BYTEVECTOR (port);
+ read_proc = SCM_CBIP_READ_PROC (port);
+
+ /* The assumption here is that C_PORT's internal buffer wasn't changed
+ behind our back. */
+ assert (c_port->read_buf ==
+ (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv));
+ assert ((unsigned) c_port->read_buf_size
+ == SCM_BYTEVECTOR_LENGTH (bv));
+
+ octets = scm_call_3 (read_proc, bv, SCM_INUM0,
+ SCM_I_MAKINUM (CBIP_BUFFER_SIZE));
+ c_octets = scm_to_uint (octets);
+
+ c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ c_port->read_end = (unsigned char *) c_port->read_pos + c_octets;
+
+ if (c_octets > 0)
+ goto again;
+ else
+ result = EOF;
+ }
+ else
+ result = (int) *c_port->read_pos;
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_custom_binary_input_port,
+ "make-custom-binary-input-port", 5, 0, 0,
+ (SCM id, SCM read_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc),
+ "Return a new custom binary input port whose input is drained "
+ "by invoking @var{read_proc} and passing it a bytevector, an "
+ "index where octets should be written, and an octet count.")
+#define FUNC_NAME s_scm_make_custom_binary_input_port
+{
+ SCM_VALIDATE_STRING (1, id);
+ SCM_VALIDATE_PROC (2, read_proc);
+
+ if (!scm_is_false (get_position_proc))
+ SCM_VALIDATE_PROC (3, get_position_proc);
+
+ if (!scm_is_false (set_position_proc))
+ SCM_VALIDATE_PROC (4, set_position_proc);
+
+ if (!scm_is_false (close_proc))
+ SCM_VALIDATE_PROC (5, close_proc);
+
+ return (make_cbip (read_proc, get_position_proc, set_position_proc,
+ close_proc));
+}
+#undef FUNC_NAME
+
+
+/* Instantiate the custom binary input port type. */
+static inline void
+initialize_custom_binary_input_ports (void)
+{
+ custom_binary_input_port_type =
+ scm_make_port_type ("r6rs-custom-binary-input-port",
+ cbip_fill_input, NULL);
+
+ scm_set_port_mark (custom_binary_input_port_type, cbp_mark);
+ scm_set_port_seek (custom_binary_input_port_type, cbp_seek);
+ scm_set_port_close (custom_binary_input_port_type, cbp_close);
+}
+
+
+
+/* Binary input. */
+
+/* We currently don't support specific binary input ports. */
+#define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
+
+SCM_DEFINE (scm_get_u8, "get-u8", 1, 0, 0,
+ (SCM port),
+ "Read an octet from @var{port}, a binary input port, "
+ "blocking as necessary.")
+#define FUNC_NAME s_scm_get_u8
+{
+ SCM result;
+ int c_result;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ c_result = scm_getc (port);
+ if (c_result == EOF)
+ result = SCM_EOF_VAL;
+ else
+ result = SCM_I_MAKINUM ((unsigned char) c_result);
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_lookahead_u8, "lookahead-u8", 1, 0, 0,
+ (SCM port),
+ "Like @code{get-u8} but does not update @var{port} to "
+ "point past the octet.")
+#define FUNC_NAME s_scm_lookahead_u8
+{
+ SCM result;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ result = scm_peek_char (port);
+ if (SCM_CHARP (result))
+ result = SCM_I_MAKINUM ((signed char) SCM_CHAR (result));
+ else
+ result = SCM_EOF_VAL;
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0,
+ (SCM port, SCM count),
+ "Read @var{count} octets from @var{port}, blocking as "
+ "necessary and return a bytevector containing the octets "
+ "read. If fewer bytes are available, a bytevector smaller "
+ "than @var{count} is returned.")
+#define FUNC_NAME s_scm_get_bytevector_n
+{
+ SCM result;
+ char *c_bv;
+ unsigned c_count;
+ size_t c_read;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+ c_count = scm_to_uint (count);
+
+ result = scm_c_make_bytevector (c_count);
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (result);
+
+ if (SCM_LIKELY (c_count > 0))
+ /* XXX: `scm_c_read ()' does not update the port position. */
+ c_read = scm_c_read (port, c_bv, c_count);
+ else
+ /* Don't invoke `scm_c_read ()' since it may block. */
+ c_read = 0;
+
+ if ((c_read == 0) && (c_count > 0))
+ {
+ if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
+ result = SCM_EOF_VAL;
+ else
+ result = scm_null_bytevector;
+ }
+ else
+ {
+ if (c_read < c_count)
+ result = scm_c_shrink_bytevector (result, c_read);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0,
+ (SCM port, SCM bv, SCM start, SCM count),
+ "Read @var{count} bytes from @var{port} and store them "
+ "in @var{bv} starting at index @var{start}. Return either "
+ "the number of bytes actually read or the end-of-file "
+ "object.")
+#define FUNC_NAME s_scm_get_bytevector_n_x
+{
+ SCM result;
+ char *c_bv;
+ unsigned c_start, c_count, c_len;
+ size_t c_read;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+ SCM_VALIDATE_BYTEVECTOR (2, bv);
+ c_start = scm_to_uint (start);
+ c_count = scm_to_uint (count);
+
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ if (SCM_UNLIKELY (c_start + c_count > c_len))
+ scm_out_of_range (FUNC_NAME, count);
+
+ if (SCM_LIKELY (c_count > 0))
+ c_read = scm_c_read (port, c_bv + c_start, c_count);
+ else
+ /* Don't invoke `scm_c_read ()' since it may block. */
+ c_read = 0;
+
+ if ((c_read == 0) && (c_count > 0))
+ {
+ if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
+ result = SCM_EOF_VAL;
+ else
+ result = SCM_I_MAKINUM (0);
+ }
+ else
+ result = scm_from_size_t (c_read);
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
+ (SCM port),
+ "Read from @var{port}, blocking as necessary, until data "
+ "are available or and end-of-file is reached. Return either "
+ "a new bytevector containing the data read or the "
+ "end-of-file object.")
+#define FUNC_NAME s_scm_get_bytevector_some
+{
+ /* Read at least one byte, unless the end-of-file is already reached, and
+ read while characters are available (buffered). */
+
+ SCM result;
+ char *c_bv;
+ unsigned c_len;
+ size_t c_total;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ c_len = 4096;
+ c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
+ c_total = 0;
+
+ do
+ {
+ int c_chr;
+
+ if (c_total + 1 > c_len)
+ {
+ /* Grow the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
+ SCM_GC_BYTEVECTOR);
+ c_len *= 2;
+ }
+
+ /* We can't use `scm_c_read ()' since it blocks. */
+ c_chr = scm_getc (port);
+ if (c_chr != EOF)
+ {
+ c_bv[c_total] = (char) c_chr;
+ c_total++;
+ }
+ }
+ while ((scm_is_true (scm_char_ready_p (port)))
+ && (!SCM_EOF_OBJECT_P (scm_peek_char (port))));
+
+ if (c_total == 0)
+ {
+ result = SCM_EOF_VAL;
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ {
+ if (c_len > c_total)
+ {
+ /* Shrink the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
+ SCM_GC_BYTEVECTOR);
+ c_len = (unsigned) c_total;
+ }
+
+ result = scm_c_take_bytevector ((signed char *) c_bv, c_len);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
+ (SCM port),
+ "Read from @var{port}, blocking as necessary, until "
+ "the end-of-file is reached. Return either "
+ "a new bytevector containing the data read or the "
+ "end-of-file object (if no data were available).")
+#define FUNC_NAME s_scm_get_bytevector_all
+{
+ SCM result;
+ char *c_bv;
+ unsigned c_len, c_count;
+ size_t c_read, c_total;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ c_len = c_count = 4096;
+ c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
+ c_total = c_read = 0;
+
+ do
+ {
+ if (c_total + c_read > c_len)
+ {
+ /* Grow the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
+ SCM_GC_BYTEVECTOR);
+ c_count = c_len;
+ c_len *= 2;
+ }
+
+ /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
+ reached. */
+ c_read = scm_c_read (port, c_bv + c_total, c_count);
+ c_total += c_read, c_count -= c_read;
+ }
+ while (!SCM_EOF_OBJECT_P (scm_peek_char (port)));
+
+ if (c_total == 0)
+ {
+ result = SCM_EOF_VAL;
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ {
+ if (c_len > c_total)
+ {
+ /* Shrink the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
+ SCM_GC_BYTEVECTOR);
+ c_len = (unsigned) c_total;
+ }
+
+ result = scm_c_take_bytevector ((signed char *) c_bv, c_len);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+
+/* Binary output. */
+
+/* We currently don't support specific binary input ports. */
+#define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
+
+
+SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0,
+ (SCM port, SCM octet),
+ "Write @var{octet} to binary port @var{port}.")
+#define FUNC_NAME s_scm_put_u8
+{
+ scm_t_uint8 c_octet;
+
+ SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
+ c_octet = scm_to_uint8 (octet);
+
+ scm_putc ((char) c_octet, port);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0,
+ (SCM port, SCM bv, SCM start, SCM count),
+ "Write the contents of @var{bv} to @var{port}, optionally "
+ "starting at index @var{start} and limiting to @var{count} "
+ "octets.")
+#define FUNC_NAME s_scm_put_bytevector
+{
+ char *c_bv;
+ unsigned c_start, c_count, c_len;
+
+ SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
+ SCM_VALIDATE_BYTEVECTOR (2, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ if (start != SCM_UNDEFINED)
+ {
+ c_start = scm_to_uint (start);
+
+ if (count != SCM_UNDEFINED)
+ {
+ c_count = scm_to_uint (count);
+ if (SCM_UNLIKELY (c_start + c_count > c_len))
+ scm_out_of_range (FUNC_NAME, count);
+ }
+ else
+ {
+ if (SCM_UNLIKELY (c_start >= c_len))
+ scm_out_of_range (FUNC_NAME, start);
+ else
+ c_count = c_len - c_start;
+ }
+ }
+ else
+ c_start = 0, c_count = c_len;
+
+ scm_c_write (port, c_bv + c_start, c_count);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+
+/* Bytevector output port ("bop" for short). */
+
+/* Implementation of "bops".
+
+ Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
+ it. The procedure returned along with the output port is actually an
+ applicable SMOB. The SMOB holds a reference to the port. When applied,
+ the SMOB swallows the port's internal buffer, turning it into a
+ bytevector, and resets it.
+
+ XXX: Access to a bop's internal buffer is not thread-safe. */
+
+static scm_t_bits bytevector_output_port_type = 0;
+
+SCM_SMOB (bytevector_output_port_procedure,
+ "r6rs-bytevector-output-port-procedure",
+ 0);
+
+#define SCM_GC_BOP "r6rs-bytevector-output-port"
+#define SCM_BOP_BUFFER_INITIAL_SIZE 4096
+
+/* Representation of a bop's internal buffer. */
+typedef struct
+{
+ size_t total_len;
+ size_t len;
+ size_t pos;
+ char *buffer;
+} scm_t_bop_buffer;
+
+
+/* Accessing a bop's buffer. */
+#define SCM_BOP_BUFFER(_port) \
+ ((scm_t_bop_buffer *) SCM_STREAM (_port))
+#define SCM_SET_BOP_BUFFER(_port, _buf) \
+ (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
+
+
+static inline void
+bop_buffer_init (scm_t_bop_buffer *buf)
+{
+ buf->total_len = buf->len = buf->pos = 0;
+ buf->buffer = NULL;
+}
+
+static inline void
+bop_buffer_grow (scm_t_bop_buffer *buf, size_t min_size)
+{
+ char *new_buf;
+ size_t new_size;
+
+ for (new_size = buf->total_len
+ ? buf->total_len : SCM_BOP_BUFFER_INITIAL_SIZE;
+ new_size < min_size;
+ new_size *= 2);
+
+ if (buf->buffer)
+ new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len,
+ new_size, SCM_GC_BOP);
+ else
+ new_buf = scm_gc_malloc (new_size, SCM_GC_BOP);
+
+ buf->buffer = new_buf;
+ buf->total_len = new_size;
+}
+
+static inline SCM
+make_bop (void)
+{
+ SCM port, bop_proc;
+ scm_t_port *c_port;
+ scm_t_bop_buffer *buf;
+ const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
+
+ port = scm_new_port_table_entry (bytevector_output_port_type);
+
+ buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
+ bop_buffer_init (buf);
+
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
+ c_port->write_buf_size = 0;
+
+ SCM_SET_BOP_BUFFER (port, buf);
+
+ /* Mark PORT as open and writable. */
+ SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
+
+ /* Make the bop procedure. */
+ SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure,
+ SCM_PACK (port));
+
+ return (scm_values (scm_list_2 (port, bop_proc)));
+}
+
+static size_t
+bop_free (SCM port)
+{
+ /* The port itself is necessarily freed _after_ the bop proc, since the bop
+ proc holds a reference to it. Thus we can safely free the internal
+ buffer when the bop becomes unreferenced. */
+ scm_t_bop_buffer *buf;
+
+ buf = SCM_BOP_BUFFER (port);
+ if (buf->buffer)
+ scm_gc_free (buf->buffer, buf->total_len, SCM_GC_BOP);
+
+ scm_gc_free (buf, sizeof (* buf), SCM_GC_BOP);
+
+ return 0;
+}
+
+/* Write SIZE octets from DATA to PORT. */
+static void
+bop_write (SCM port, const void *data, size_t size)
+{
+ scm_t_bop_buffer *buf;
+
+ buf = SCM_BOP_BUFFER (port);
+
+ if (buf->pos + size > buf->total_len)
+ bop_buffer_grow (buf, buf->pos + size);
+
+ memcpy (buf->buffer + buf->pos, data, size);
+ buf->pos += size;
+ buf->len = (buf->len > buf->pos) ? buf->len : buf->pos;
+}
+
+static off_t
+bop_seek (SCM port, off_t offset, int whence)
+#define FUNC_NAME "bop_seek"
+{
+ scm_t_bop_buffer *buf;
+
+ buf = SCM_BOP_BUFFER (port);
+ switch (whence)
+ {
+ case SEEK_CUR:
+ offset += (off_t) buf->pos;
+ /* Fall through. */
+
+ case SEEK_SET:
+ if (offset < 0 || (unsigned) offset > buf->len)
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ else
+ buf->pos = offset;
+ break;
+
+ case SEEK_END:
+ if (offset < 0 || (unsigned) offset >= buf->len)
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ else
+ buf->pos = buf->len - (offset + 1);
+ break;
+
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "invalid `seek' parameter");
+ }
+
+ return buf->pos;
+}
+#undef FUNC_NAME
+
+/* Fetch data from a bop. */
+SCM_SMOB_APPLY (bytevector_output_port_procedure,
+ bop_proc_apply, 0, 0, 0, (SCM bop_proc))
+{
+ SCM port, bv;
+ scm_t_bop_buffer *buf, result_buf;
+
+ port = SCM_PACK (SCM_SMOB_DATA (bop_proc));
+ buf = SCM_BOP_BUFFER (port);
+
+ result_buf = *buf;
+ bop_buffer_init (buf);
+
+ if (result_buf.len == 0)
+ bv = scm_c_take_bytevector (NULL, 0);
+ else
+ {
+ if (result_buf.total_len > result_buf.len)
+ /* Shrink the buffer. */
+ result_buf.buffer = scm_gc_realloc ((void *) result_buf.buffer,
+ result_buf.total_len,
+ result_buf.len,
+ SCM_GC_BOP);
+
+ bv = scm_c_take_bytevector ((signed char *) result_buf.buffer,
+ result_buf.len);
+ }
+
+ return bv;
+}
+
+SCM_SMOB_MARK (bytevector_output_port_procedure, bop_proc_mark,
+ bop_proc)
+{
+ /* Mark the port associated with BOP_PROC. */
+ return (SCM_PACK (SCM_SMOB_DATA (bop_proc)));
+}
+
+
+SCM_DEFINE (scm_open_bytevector_output_port,
+ "open-bytevector-output-port", 0, 1, 0,
+ (SCM transcoder),
+ "Return two values: an output port and a procedure. The latter "
+ "should be called with zero arguments to obtain a bytevector "
+ "containing the data accumulated by the port.")
+#define FUNC_NAME s_scm_open_bytevector_output_port
+{
+ if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
+ transcoders_not_implemented ();
+
+ return (make_bop ());
+}
+#undef FUNC_NAME
+
+static inline void
+initialize_bytevector_output_ports (void)
+{
+ bytevector_output_port_type =
+ scm_make_port_type ("r6rs-bytevector-output-port",
+ NULL, bop_write);
+
+ scm_set_port_seek (bytevector_output_port_type, bop_seek);
+ scm_set_port_free (bytevector_output_port_type, bop_free);
+}
+
+
+/* Custom binary output port ("cbop" for short). */
+
+static scm_t_bits custom_binary_output_port_type;
+
+/* Return the various procedures of PORT. */
+#define SCM_CBOP_WRITE_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
+
+
+static inline SCM
+make_cbop (SCM write_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc)
+{
+ SCM port, method_vector;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
+
+ /* Store the various methods and bytevector in a vector. */
+ method_vector = scm_c_make_vector (4, SCM_BOOL_F);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 0, write_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
+
+ port = scm_new_port_table_entry (custom_binary_output_port_type);
+
+ /* Attach it the method vector. */
+ SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
+
+ /* Have the port directly access the buffer (bytevector). */
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
+ c_port->write_buf_size = c_port->read_buf_size = 0;
+
+ /* Mark PORT as open, writable and unbuffered. */
+ SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits);
+
+ return port;
+}
+
+/* Write SIZE octets from DATA to PORT. */
+static void
+cbop_write (SCM port, const void *data, size_t size)
+#define FUNC_NAME "cbop_write"
+{
+ long int c_result;
+ size_t c_written;
+ SCM bv, write_proc, result;
+
+ /* XXX: Allocating a new bytevector at each `write' call is inefficient,
+ but necessary since (1) we don't control the lifetime of the buffer
+ pointed to by DATA, and (2) the `write!' procedure could capture the
+ bytevector it is passed. */
+ bv = scm_c_make_bytevector (size);
+ memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size);
+
+ write_proc = SCM_CBOP_WRITE_PROC (port);
+
+ /* Since the `write' procedure of Guile's ports has type `void', it must
+ try hard to write exactly SIZE bytes, regardless of how many bytes the
+ sink can handle. */
+ for (c_written = 0;
+ c_written < size;
+ c_written += c_result)
+ {
+ result = scm_call_3 (write_proc, bv,
+ scm_from_size_t (c_written),
+ scm_from_size_t (size - c_written));
+
+ c_result = scm_to_long (result);
+ if (SCM_UNLIKELY (c_result < 0
+ || (size_t) c_result > (size - c_written)))
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, result,
+ "R6RS custom binary output port `write!' "
+ "returned a incorrect integer");
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_custom_binary_output_port,
+ "make-custom-binary-output-port", 5, 0, 0,
+ (SCM id, SCM write_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc),
+ "Return a new custom binary output port whose output is drained "
+ "by invoking @var{write_proc} and passing it a bytevector, an "
+ "index where octets should be written, and an octet count.")
+#define FUNC_NAME s_scm_make_custom_binary_output_port
+{
+ SCM_VALIDATE_STRING (1, id);
+ SCM_VALIDATE_PROC (2, write_proc);
+
+ if (!scm_is_false (get_position_proc))
+ SCM_VALIDATE_PROC (3, get_position_proc);
+
+ if (!scm_is_false (set_position_proc))
+ SCM_VALIDATE_PROC (4, set_position_proc);
+
+ if (!scm_is_false (close_proc))
+ SCM_VALIDATE_PROC (5, close_proc);
+
+ return (make_cbop (write_proc, get_position_proc, set_position_proc,
+ close_proc));
+}
+#undef FUNC_NAME
+
+
+/* Instantiate the custom binary output port type. */
+static inline void
+initialize_custom_binary_output_ports (void)
+{
+ custom_binary_output_port_type =
+ scm_make_port_type ("r6rs-custom-binary-output-port",
+ NULL, cbop_write);
+
+ scm_set_port_mark (custom_binary_output_port_type, cbp_mark);
+ scm_set_port_seek (custom_binary_output_port_type, cbp_seek);
+ scm_set_port_close (custom_binary_output_port_type, cbp_close);
+}
+
+
+/* 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 000000000..e29d96200
--- /dev/null
+++ b/libguile/r6rs-ports.h
@@ -0,0 +1,43 @@
+#ifndef SCM_R6RS_PORTS_H
+#define SCM_R6RS_PORTS_H
+
+/* Copyright (C) 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+
+#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/read.c b/libguile/read.c
index 61806f263..3493ba03f 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -182,6 +182,7 @@ static SCM *scm_read_hash_procedures;
/* Read an SCSH block comment. */
static inline SCM scm_read_scsh_block_comment (int chr, SCM port);
+static SCM scm_read_commented_expression (int chr, SCM port);
/* Read from PORT until a delimiter (e.g., a whitespace) is read. Return
zero if the whole token fits in BUF, non-zero otherwise. */
@@ -257,6 +258,9 @@ flush_ws (SCM port, const char *eoferr)
case '!':
scm_read_scsh_block_comment (c, port);
break;
+ case ';':
+ scm_read_commented_expression (c, port);
+ break;
default:
scm_ungetc (c, port);
return '#';
@@ -700,6 +704,65 @@ scm_read_quote (int chr, SCM port)
return p;
}
+SCM_SYMBOL (sym_syntax, "syntax");
+SCM_SYMBOL (sym_quasisyntax, "quasisyntax");
+SCM_SYMBOL (sym_unsyntax, "unsyntax");
+SCM_SYMBOL (sym_unsyntax_splicing, "unsyntax-splicing");
+
+static SCM
+scm_read_syntax (int chr, SCM port)
+{
+ SCM p;
+ long line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
+
+ switch (chr)
+ {
+ case '`':
+ p = sym_quasisyntax;
+ break;
+
+ case '\'':
+ p = sym_syntax;
+ break;
+
+ case ',':
+ {
+ int c;
+
+ c = scm_getc (port);
+ if ('@' == c)
+ p = sym_unsyntax_splicing;
+ else
+ {
+ scm_ungetc (c, port);
+ p = sym_unsyntax;
+ }
+ break;
+ }
+
+ default:
+ fprintf (stderr, "%s: unhandled syntax character (%i)\n",
+ "scm_read_syntax", chr);
+ abort ();
+ }
+
+ p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
+ if (SCM_RECORD_POSITIONS_P)
+ scm_whash_insert (scm_source_whash, p,
+ scm_make_srcprops (line, column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? (scm_cons2 (SCM_CAR (p),
+ SCM_CAR (SCM_CDR (p)),
+ SCM_EOL))
+ : SCM_UNDEFINED,
+ SCM_EOL));
+
+
+ return p;
+}
+
static inline SCM
scm_read_semicolon_comment (int chr, SCM port)
{
@@ -863,6 +926,20 @@ scm_read_scsh_block_comment (int chr, SCM port)
}
static SCM
+scm_read_commented_expression (int chr, SCM port)
+{
+ int c;
+
+ c = flush_ws (port, (char *) NULL);
+ if (EOF == c)
+ scm_i_input_error ("read_commented_expression", port,
+ "no expression after #; comment", SCM_EOL);
+ scm_ungetc (c, port);
+ scm_read_expression (port);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
scm_read_extended_symbol (int chr, SCM port)
{
/* Guile's extended symbol read syntax looks like this:
@@ -1023,6 +1100,12 @@ scm_read_sharp (int chr, SCM port)
return (scm_read_extended_symbol (chr, port));
case '!':
return (scm_read_scsh_block_comment (chr, port));
+ case ';':
+ return (scm_read_commented_expression (chr, port));
+ case '`':
+ case '\'':
+ case ',':
+ return (scm_read_syntax (chr, port));
default:
result = scm_read_sharp_extension (chr, port);
if (scm_is_eq (result, SCM_UNSPECIFIED))
diff --git a/libguile/stime.c b/libguile/stime.c
index 34c8a98fa..5384783e3 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -77,10 +77,6 @@
# include <sys/timeb.h>
#endif
-#if HAVE_CRT_EXTERNS_H
-#include <crt_externs.h> /* for Darwin _NSGetEnviron */
-#endif
-
#ifndef tzname /* For SGI. */
extern char *tzname[]; /* RS6000 and others reject char **tzname. */
#endif
@@ -98,15 +94,6 @@ extern char *strptime ();
# define timet long
#endif
-extern char ** environ;
-
-/* On Apple Darwin in a shared library there's no "environ" to access
- directly, instead the address of that variable must be obtained with
- _NSGetEnviron(). */
-#if HAVE__NSGETENVIRON && defined (PIC)
-#define environ (*_NSGetEnviron())
-#endif
-
#ifdef HAVE_TIMES
static
diff --git a/libguile/threads.c b/libguile/threads.c
index bb874e230..d63c6197e 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -1161,6 +1161,16 @@ SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 2, 0,
scm_i_pthread_mutex_unlock (&t->admin_mutex);
SCM_TICK;
scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
+
+ /* Check for exit again, since we just released and
+ reacquired the admin mutex, before the next block_self
+ call (which would block forever if t has already
+ exited). */
+ if (t->exited)
+ {
+ res = t->result;
+ break;
+ }
}
}
@@ -1491,6 +1501,7 @@ fat_mutex_unlock (SCM mutex, SCM cond,
{
if (relock)
scm_lock_mutex_timed (mutex, SCM_UNDEFINED, owner);
+ t->block_asyncs--;
break;
}
diff --git a/libguile/validate.h b/libguile/validate.h
index e05b7dd83..c362c02f3 100644
--- a/libguile/validate.h
+++ b/libguile/validate.h
@@ -3,7 +3,7 @@
#ifndef SCM_VALIDATE_H
#define SCM_VALIDATE_H
-/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007 Free Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@@ -150,6 +150,9 @@
cvar = scm_to_bool (flag); \
} while (0)
+#define SCM_VALIDATE_BYTEVECTOR(_pos, _obj) \
+ SCM_VALIDATE_SMOB ((_pos), (_obj), bytevector)
+
#define SCM_VALIDATE_CHAR(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, CHARP, "character")
#define SCM_VALIDATE_CHAR_COPY(pos, scm, cvar) \
diff --git a/libguile/vm-bootstrap.h b/libguile/vm-bootstrap.h
index beecf0fc2..587766a67 100644
--- a/libguile/vm-bootstrap.h
+++ b/libguile/vm-bootstrap.h
@@ -1,48 +1,24 @@
/* Copyright (C) 2001 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 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, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
+ * 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#ifndef _SCM_VM_BOOTSTRAP_H_
#define _SCM_VM_BOOTSTRAP_H_
-extern void scm_bootstrap_vm (void);
+SCM_INTERNAL void scm_bootstrap_vm (void);
#endif /* _SCM_VM_BOOTSTRAP_H_ */
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 45251fd70..f43f8c7fe 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * 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, 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 software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * 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.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
/* This file is included in vm.c multiple times */
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 6bb235401..8c919f630 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * 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, 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 software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * 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.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
/* This file is included in vm_engine.c */
@@ -147,8 +123,12 @@
#ifdef VM_ENABLE_PARANOID_ASSERTIONS
#define CHECK_IP() \
do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
+#define ASSERT_BOUND(x) \
+ do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \
+ } while (0)
#else
#define CHECK_IP()
+#define ASSERT_BOUND(x)
#endif
/* Get a local copy of the program's "object table" (i.e. the vector of
diff --git a/libguile/vm-expand.h b/libguile/vm-expand.h
index 7ad2b9da8..02dfbc4d0 100644
--- a/libguile/vm-expand.h
+++ b/libguile/vm-expand.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * 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, 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 software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * 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.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#ifndef VM_LABEL
#define VM_LABEL(tag) l_##tag
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 4af60265e..38dea32b9 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * 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, 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 software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * 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.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
/* This file is included in vm_engine.c */
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 5468604d2..42f2b1973 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -230,6 +230,7 @@ VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1)
VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1)
{
PUSH (LOCAL_REF (FETCH ()));
+ ASSERT_BOUND (*sp);
NEXT;
}
@@ -244,6 +245,7 @@ VM_DEFINE_INSTRUCTION (23, external_ref, "external-ref", 1, 0, 1)
}
CHECK_EXTERNAL(e);
PUSH (SCM_CAR (e));
+ ASSERT_BOUND (*sp);
NEXT;
}
@@ -408,12 +410,6 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (30, externals, "externals", 0, 0, 1)
-{
- PUSH (external);
- NEXT;
-}
-
/*
* branch and jump
diff --git a/libguile/vm.c b/libguile/vm.c
index 38d085c99..081a691ff 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * 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, 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 software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * 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.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#if HAVE_CONFIG_H
# include <config.h>
@@ -46,6 +22,7 @@
#include <stdlib.h>
#include <alloca.h>
#include <string.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "frames.h"
#include "instructions.h"
diff --git a/libguile/vm.h b/libguile/vm.h
index 5c38f9ffa..2f2b617ce 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 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 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, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
+ * 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#ifndef _SCM_VM_H_
#define _SCM_VM_H_
@@ -78,37 +54,37 @@ struct scm_vm {
SCM trace_frame; /* a frame being traced */
};
-extern SCM scm_the_vm_fluid;
+SCM_API SCM scm_the_vm_fluid;
#define SCM_VM_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm, x)
#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_SMOB_DATA (vm))
#define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P)
-extern SCM scm_the_vm ();
-extern SCM scm_make_vm (void);
-extern SCM scm_vm_apply (SCM vm, SCM program, SCM args);
-extern SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
-extern SCM scm_vm_option_ref (SCM vm, SCM key);
-extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
-
-extern SCM scm_vm_version (void);
-extern SCM scm_the_vm (void);
-extern SCM scm_vm_p (SCM obj);
-extern SCM scm_vm_ip (SCM vm);
-extern SCM scm_vm_sp (SCM vm);
-extern SCM scm_vm_fp (SCM vm);
-extern SCM scm_vm_boot_hook (SCM vm);
-extern SCM scm_vm_halt_hook (SCM vm);
-extern SCM scm_vm_next_hook (SCM vm);
-extern SCM scm_vm_break_hook (SCM vm);
-extern SCM scm_vm_enter_hook (SCM vm);
-extern SCM scm_vm_apply_hook (SCM vm);
-extern SCM scm_vm_exit_hook (SCM vm);
-extern SCM scm_vm_return_hook (SCM vm);
-extern SCM scm_vm_option (SCM vm, SCM key);
-extern SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
-extern SCM scm_vm_stats (SCM vm);
-extern SCM scm_vm_trace_frame (SCM vm);
+SCM_API SCM scm_the_vm ();
+SCM_API SCM scm_make_vm (void);
+SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args);
+SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
+SCM_API SCM scm_vm_option_ref (SCM vm, SCM key);
+SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
+
+SCM_API SCM scm_vm_version (void);
+SCM_API SCM scm_the_vm (void);
+SCM_API SCM scm_vm_p (SCM obj);
+SCM_API SCM scm_vm_ip (SCM vm);
+SCM_API SCM scm_vm_sp (SCM vm);
+SCM_API SCM scm_vm_fp (SCM vm);
+SCM_API SCM scm_vm_boot_hook (SCM vm);
+SCM_API SCM scm_vm_halt_hook (SCM vm);
+SCM_API SCM scm_vm_next_hook (SCM vm);
+SCM_API SCM scm_vm_break_hook (SCM vm);
+SCM_API SCM scm_vm_enter_hook (SCM vm);
+SCM_API SCM scm_vm_apply_hook (SCM vm);
+SCM_API SCM scm_vm_exit_hook (SCM vm);
+SCM_API SCM scm_vm_return_hook (SCM vm);
+SCM_API SCM scm_vm_option (SCM vm, SCM key);
+SCM_API SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
+SCM_API SCM scm_vm_stats (SCM vm);
+SCM_API SCM scm_vm_trace_frame (SCM vm);
struct scm_vm_cont {
scm_byte_t *ip;
@@ -119,16 +95,16 @@ struct scm_vm_cont {
scm_t_ptrdiff reloc;
};
-extern scm_t_bits scm_tc16_vm_cont;
+SCM_API scm_t_bits scm_tc16_vm_cont;
#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
-extern SCM scm_vm_capture_continuations (void);
-extern void scm_vm_reinstate_continuations (SCM conts);
+SCM_API SCM scm_vm_capture_continuations (void);
+SCM_API void scm_vm_reinstate_continuations (SCM conts);
-extern SCM scm_load_compiled_with_vm (SCM file);
+SCM_API SCM scm_load_compiled_with_vm (SCM file);
-extern void scm_init_vm (void);
+SCM_INTERNAL void scm_init_vm (void);
#endif /* _SCM_VM_H_ */