diff options
author | Julian Graham <julian@transmetropolitan.(none)> | 2009-06-02 09:35:02 -0400 |
---|---|---|
committer | Julian Graham <julian@transmetropolitan.(none)> | 2009-06-02 09:35:02 -0400 |
commit | 2f9ae9b1040e1b9339bb0bc8b0013a5346622c44 (patch) | |
tree | 8dc3105cc05ddd5509edc4559a69d32d2acddfab /libguile | |
parent | 922d417bf4a7c4eb7d956d340161ad6407545ae7 (diff) | |
parent | 938d46a35d39ec5d7b5fa858a8783136ce24d10d (diff) | |
download | guile-2f9ae9b1040e1b9339bb0bc8b0013a5346622c44.tar.gz |
Merge branch 'master' of git://git.savannah.gnu.org/guile
Diffstat (limited to 'libguile')
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_ */ |