-/* Copyright (C) 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010, 2011, 2012 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
#endif
#include <alloca.h>
+#include <assert.h>
#include <gmp.h>
#include <byteswap.h>
#include <striconveh.h>
#include <uniconv.h>
+#include <unistr.h>
#ifdef HAVE_LIMITS_H
# include <limits.h>
SCM_VALIDATE_SYMBOL (3, endianness); \
\
{ \
- _sign long c_value; \
+ scm_t_signed_bits c_value; \
INT_TYPE (_len, _sign) c_value_short; \
\
if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
\
{ \
- _sign long c_value; \
+ scm_t_signed_bits c_value; \
INT_TYPE (_len, _sign) c_value_short; \
\
if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
\f
/* Bytevector type. */
-scm_t_bits scm_tc16_bytevector;
-
-#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))
+#define SCM_BYTEVECTOR_HEADER_BYTES \
+ (SCM_BYTEVECTOR_HEADER_SIZE * sizeof (scm_t_bits))
+
+#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
+ SCM_SET_CELL_WORD_1 ((_bv), (scm_t_bits) (_len))
+#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _contents) \
+ SCM_SET_CELL_WORD_2 ((_bv), (scm_t_bits) (_contents))
+#define SCM_BYTEVECTOR_SET_CONTIGUOUS_P(bv, contiguous_p) \
+ SCM_SET_BYTEVECTOR_FLAGS ((bv), \
+ SCM_BYTEVECTOR_ELEMENT_TYPE (bv) \
+ | ((contiguous_p) << 8UL))
+
+#define SCM_BYTEVECTOR_SET_ELEMENT_TYPE(bv, hint) \
+ SCM_SET_BYTEVECTOR_FLAGS ((bv), \
+ (hint) \
+ | (SCM_BYTEVECTOR_CONTIGUOUS_P (bv) << 8UL))
+#define SCM_BYTEVECTOR_SET_PARENT(_bv, _parent) \
+ SCM_SET_CELL_OBJECT_3 ((_bv), (_parent))
+
+#define SCM_BYTEVECTOR_TYPE_SIZE(var) \
+ (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
+#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
+ (SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var))
/* The empty bytevector. */
SCM scm_null_bytevector = SCM_UNSPECIFIED;
static inline SCM
-make_bytevector_from_buffer (size_t len, signed char *contents)
+make_bytevector (size_t len, scm_t_array_element_type element_type)
{
- /* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */
- SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector, len, contents);
+ SCM ret;
+ size_t c_len;
+
+ if (SCM_UNLIKELY (element_type > SCM_ARRAY_ELEMENT_TYPE_LAST
+ || scm_i_array_element_type_sizes[element_type] < 8
+ || len >= (((size_t) -1)
+ / (scm_i_array_element_type_sizes[element_type]/8))))
+ /* This would be an internal Guile programming error */
+ abort ();
+
+ if (SCM_UNLIKELY (len == 0 && element_type == SCM_ARRAY_ELEMENT_TYPE_VU8
+ && SCM_BYTEVECTOR_P (scm_null_bytevector)))
+ ret = scm_null_bytevector;
+ else
+ {
+ signed char *contents;
+
+ c_len = len * (scm_i_array_element_type_sizes[element_type] / 8);
+
+ contents = scm_gc_malloc_pointerless (SCM_BYTEVECTOR_HEADER_BYTES + c_len,
+ SCM_GC_BYTEVECTOR);
+ ret = SCM_PACK_POINTER (contents);
+ contents += SCM_BYTEVECTOR_HEADER_BYTES;
+
+ SCM_BYTEVECTOR_SET_LENGTH (ret, c_len);
+ SCM_BYTEVECTOR_SET_CONTENTS (ret, contents);
+ SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret, 1);
+ SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
+ SCM_BYTEVECTOR_SET_PARENT (ret, SCM_BOOL_F);
+ }
+
+ return ret;
}
+/* Return a bytevector of LEN elements of type ELEMENT_TYPE, with element
+ values taken from CONTENTS. Assume that the storage for CONTENTS will be
+ automatically reclaimed when it becomes unreachable. */
static inline SCM
-make_bytevector (size_t len)
+make_bytevector_from_buffer (size_t len, void *contents,
+ scm_t_array_element_type element_type)
{
- SCM bv;
+ SCM ret;
if (SCM_UNLIKELY (len == 0))
- bv = scm_null_bytevector;
+ ret = make_bytevector (len, element_type);
else
{
- signed char *contents = NULL;
+ size_t c_len;
+
+ ret = SCM_PACK_POINTER (scm_gc_malloc (SCM_BYTEVECTOR_HEADER_BYTES,
+ SCM_GC_BYTEVECTOR));
- if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len))
- contents = (signed char *) scm_gc_malloc (len, SCM_GC_BYTEVECTOR);
+ c_len = len * (scm_i_array_element_type_sizes[element_type] / 8);
- bv = make_bytevector_from_buffer (len, contents);
+ SCM_BYTEVECTOR_SET_LENGTH (ret, c_len);
+ SCM_BYTEVECTOR_SET_CONTENTS (ret, contents);
+ SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret, 0);
+ SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
+ SCM_BYTEVECTOR_SET_PARENT (ret, SCM_BOOL_F);
}
- return bv;
+ return ret;
}
+
/* Return a new bytevector of size LEN octets. */
SCM
scm_c_make_bytevector (size_t len)
{
- return (make_bytevector (len));
+ return make_bytevector (len, SCM_ARRAY_ELEMENT_TYPE_VU8);
}
-/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
- by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
+/* Return a new bytevector of size LEN elements. */
SCM
-scm_c_take_bytevector (signed char *contents, size_t len)
+scm_i_make_typed_bytevector (size_t len, scm_t_array_element_type element_type)
{
- SCM bv;
+ return make_bytevector (len, element_type);
+}
- if (SCM_UNLIKELY (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len)))
- {
- /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */
- signed char *c_bv;
+/* Return a bytevector of size LEN made up of CONTENTS. The area
+ pointed to by CONTENTS must be protected from GC somehow: either
+ because it was allocated using `scm_gc_malloc ()', or because it is
+ part of PARENT. */
+SCM
+scm_c_take_gc_bytevector (signed char *contents, size_t len, SCM parent)
+{
+ SCM ret;
- 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);
+ ret = make_bytevector_from_buffer (len, contents, SCM_ARRAY_ELEMENT_TYPE_VU8);
+ SCM_BYTEVECTOR_SET_PARENT (ret, parent);
- return bv;
+ return ret;
+}
+
+SCM
+scm_c_take_typed_bytevector (signed char *contents, size_t len,
+ scm_t_array_element_type element_type, SCM parent)
+{
+ SCM ret;
+
+ ret = make_bytevector_from_buffer (len, contents, element_type);
+ SCM_BYTEVECTOR_SET_PARENT (ret, parent);
+
+ return ret;
}
/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
- size) and return BV. */
+ size) and return the new bytevector (possibly different from BV). */
SCM
-scm_i_shrink_bytevector (SCM bv, size_t c_new_len)
+scm_c_shrink_bytevector (SCM bv, size_t c_new_len)
{
- if (!SCM_BYTEVECTOR_INLINE_P (bv))
- {
- size_t c_len;
- signed char *c_bv, *c_new_bv;
+ SCM new_bv;
+ size_t c_len;
- c_len = SCM_BYTEVECTOR_LENGTH (bv);
- c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+ if (SCM_UNLIKELY (c_new_len % SCM_BYTEVECTOR_TYPE_SIZE (bv)))
+ /* This would be an internal Guile programming error */
+ abort ();
- SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ if (SCM_UNLIKELY (c_new_len > c_len))
+ abort ();
- 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);
- }
+ SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
+
+ if (SCM_BYTEVECTOR_CONTIGUOUS_P (bv))
+ new_bv = PTR2SCM (scm_gc_realloc (SCM2PTR (bv),
+ c_len + SCM_BYTEVECTOR_HEADER_BYTES,
+ c_new_len + SCM_BYTEVECTOR_HEADER_BYTES,
+ SCM_GC_BYTEVECTOR));
+ else
+ {
+ signed char *c_bv;
+
+ c_bv = scm_gc_realloc (SCM_BYTEVECTOR_CONTENTS (bv),
+ c_len, c_new_len, SCM_GC_BYTEVECTOR);
+ SCM_BYTEVECTOR_SET_CONTENTS (bv, c_bv);
+
+ new_bv = bv;
}
- return bv;
+ return new_bv;
}
int
scm_is_bytevector (SCM obj)
{
- return SCM_SMOB_PREDICATE (scm_tc16_bytevector, obj);
+ return SCM_BYTEVECTOR_P (obj);
}
size_t
}
#undef FUNC_NAME
-/* This procedure is used by `scm_c_generalized_vector_set_x ()'. */
-void
-scm_i_bytevector_generalized_set_x (SCM bv, size_t index, SCM value)
-#define FUNC_NAME "scm_i_bytevector_generalized_set_x"
-{
- scm_c_bytevector_set_x (bv, index, scm_to_uint8 (value));
-}
-#undef FUNC_NAME
-static int
-print_bytevector (SCM bv, SCM port, scm_print_state *pstate)
+\f
+int
+scm_i_print_bytevector (SCM bv, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- unsigned c_len, i;
- unsigned char *c_bv;
-
- c_len = SCM_BYTEVECTOR_LENGTH (bv);
- c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ ssize_t ubnd, inc, i;
+ scm_t_array_handle h;
+
+ scm_array_get_handle (bv, &h);
- scm_puts ("#vu8(", port);
- for (i = 0; i < c_len; i++)
+ scm_putc_unlocked ('#', port);
+ scm_write (scm_array_handle_element_type (&h), port);
+ scm_putc_unlocked ('(', port);
+ for (i = h.dims[0].lbnd, ubnd = h.dims[0].ubnd, inc = h.dims[0].inc;
+ i <= ubnd; i += inc)
{
if (i > 0)
- scm_putc (' ', port);
-
- scm_uintprint (c_bv[i], 10, port);
+ scm_putc_unlocked (' ', port);
+ scm_write (scm_array_handle_ref (&h, i), port);
}
-
- scm_putc (')', port);
-
- /* Make GCC think we use it. */
- scm_remember_upto_here ((SCM) pstate);
+ scm_putc_unlocked (')', port);
return 1;
}
-static SCM
-bytevector_equal_p (SCM bv1, SCM bv2)
-{
- return scm_bytevector_eq_p (bv1, bv2);
-}
-
-static size_t
-free_bytevector (SCM bv)
-{
-
- if (!SCM_BYTEVECTOR_INLINE_P (bv))
- {
- unsigned c_len;
- signed char *c_bv;
-
- c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
- c_len = SCM_BYTEVECTOR_LENGTH (bv);
-
- scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
- }
-
- return 0;
-}
-
-
\f
/* General operations. */
signed char c_fill = '\0';
SCM_VALIDATE_UINT_COPY (1, len, c_len);
- if (fill != SCM_UNDEFINED)
+ if (!scm_is_eq (fill, SCM_UNDEFINED))
{
int value;
c_fill = (signed char) value;
}
- bv = make_bytevector (c_len);
- if (fill != SCM_UNDEFINED)
+ bv = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
+ if (!scm_is_eq (fill, SCM_UNDEFINED))
{
unsigned i;
signed char *contents;
for (i = 0; i < c_len; i++)
contents[i] = c_fill;
}
+ else
+ memset (SCM_BYTEVECTOR_CONTENTS (bv), 0, c_len);
return bv;
}
c_len1 = SCM_BYTEVECTOR_LENGTH (bv1);
c_len2 = SCM_BYTEVECTOR_LENGTH (bv2);
- if (c_len1 == c_len2)
+ if (c_len1 == c_len2 && (SCM_BYTEVECTOR_ELEMENT_TYPE (bv1)
+ == SCM_BYTEVECTOR_ELEMENT_TYPE (bv2)))
{
signed char *c_bv1, *c_bv2;
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);
+ memmove (c_target + c_target_start,
+ c_source + c_source_start,
+ c_len);
return SCM_UNSPECIFIED;
}
c_len = SCM_BYTEVECTOR_LENGTH (bv);
c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
- copy = make_bytevector (c_len);
+ copy = make_bytevector (c_len, SCM_BYTEVECTOR_ELEMENT_TYPE (bv));
c_copy = SCM_BYTEVECTOR_CONTENTS (copy);
memcpy (c_copy, c_bv, c_len);
#define FUNC_NAME s_scm_uniform_array_to_bytevector
{
SCM contents, ret;
- size_t len;
+ size_t len, sz, byte_len;
scm_t_array_handle h;
- const void *base;
- size_t sz;
+ const void *elts;
contents = scm_array_contents (array, SCM_BOOL_T);
if (scm_is_false (contents))
scm_wrong_type_arg_msg (FUNC_NAME, 0, array, "uniform contiguous array");
scm_array_get_handle (contents, &h);
+ assert (h.base == 0);
- base = scm_array_handle_uniform_elements (&h);
+ elts = h.elements;
len = h.dims->inc * (h.dims->ubnd - h.dims->lbnd + 1);
- sz = scm_array_handle_uniform_element_size (&h);
+ sz = scm_array_handle_uniform_element_bit_size (&h);
+ if (sz >= 8 && ((sz % 8) == 0))
+ byte_len = len * (sz / 8);
+ else if (sz < 8)
+ /* byte_len = ceil (len * sz / 8) */
+ byte_len = (len * sz + 7) / 8;
+ else
+ /* an internal guile error, really */
+ SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL);
- ret = make_bytevector (len * sz);
- memcpy (SCM_BYTEVECTOR_CONTENTS (ret), base, len * sz);
+ ret = make_bytevector (byte_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
+ memcpy (SCM_BYTEVECTOR_CONTENTS (ret), elts, byte_len);
scm_array_handle_release (&h);
SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);
- bv = make_bytevector (c_len);
+ bv = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
for (i = 0; i < c_len; lst = SCM_CDR (lst), i++)
if (SCM_LIKELY (SCM_I_INUMP (item)))
{
- long c_item;
+ scm_t_signed_bits c_item;
c_item = SCM_I_INUM (item);
if (SCM_LIKELY ((c_item >= 0) && (c_item < 256)))
#define GENERIC_INTEGER_SET(_sign) \
if (c_size < 3) \
{ \
- _sign int c_value; \
+ scm_t_signed_bits c_value; \
\
if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
goto range_error; \
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); \
+ bv = make_bytevector (c_len * c_size, SCM_ARRAY_ELEMENT_TYPE_VU8); \
c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
\
for (c_bv_ptr = c_bv; \
_c_type ## _to_foreign_endianness
+/* FIXME: SCM_VALIDATE_REAL rejects integers, etc. grrr */
+#define VALIDATE_REAL(pos, v) \
+ do { \
+ SCM_ASSERT_TYPE (scm_is_real (v), v, pos, FUNC_NAME, "real"); \
+ } while (0)
+
/* Templace getters and setters. */
#define IEEE754_ACCESSOR_PROLOGUE(_type) \
_type c_value; \
\
IEEE754_ACCESSOR_PROLOGUE (_type); \
- SCM_VALIDATE_REAL (3, value); \
+ VALIDATE_REAL (3, value); \
SCM_VALIDATE_SYMBOL (4, endianness); \
c_value = IEEE754_FROM_SCM (_type) (value); \
\
_type c_value; \
\
IEEE754_ACCESSOR_PROLOGUE (_type); \
- SCM_VALIDATE_REAL (3, value); \
+ VALIDATE_REAL (3, value); \
c_value = IEEE754_FROM_SCM (_type) (value); \
\
memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
#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);
+#define STRING_TO_UTF(_utf_width) \
+ SCM utf; \
+ int err; \
+ char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
+ char *c_utf = NULL; \
+ size_t c_strlen, c_utf_len = 0; \
+ \
+ SCM_VALIDATE_STRING (1, str); \
+ if (scm_is_eq (endianness, SCM_UNDEFINED)) \
+ endianness = scm_sym_big; \
+ else \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ \
+ utf_encoding_name (c_utf_name, (_utf_width), endianness); \
+ \
+ c_strlen = scm_i_string_length (str); \
+ if (scm_i_is_narrow_string (str)) \
+ { \
+ scm_i_lock_iconv (); \
+ err = mem_iconveh (scm_i_string_chars (str), c_strlen, \
+ "ISO-8859-1", c_utf_name, \
+ iconveh_question_mark, NULL, \
+ &c_utf, &c_utf_len); \
+ scm_i_unlock_iconv (); \
+ if (SCM_UNLIKELY (err)) \
+ scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
+ scm_list_1 (str), err); \
+ } \
+ else \
+ { \
+ const scm_t_wchar *wbuf = scm_i_string_wide_chars (str); \
+ scm_i_lock_iconv (); \
+ c_utf = u32_conv_to_encoding (c_utf_name, \
+ iconveh_question_mark, \
+ (scm_t_uint32 *) wbuf, \
+ c_strlen, NULL, NULL, &c_utf_len); \
+ scm_i_unlock_iconv (); \
+ if (SCM_UNLIKELY (c_utf == NULL)) \
+ scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
+ scm_list_1 (str), errno); \
+ } \
+ scm_dynwind_begin (0); \
+ scm_dynwind_free (c_utf); \
+ utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8); \
+ memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len); \
+ scm_dynwind_end (); \
+ \
+ return (utf);
#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_t_uint8 *c_utf;
+ size_t c_utf_len = 0;
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));
+ c_utf = (scm_t_uint8 *) scm_to_utf8_stringn (str, &c_utf_len);
+ utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
+ memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len);
+ free (c_utf);
return (utf);
}
}
#undef FUNC_NAME
+static void
+swap_u32 (scm_t_wchar *vals, size_t len)
+{
+ size_t n;
+ for (n = 0; n < len; n++)
+ vals[n] = bswap_32 (vals[n]);
+}
+
SCM_DEFINE (scm_string_to_utf32, "string->utf32",
1, 1, 0,
(SCM str, SCM endianness),
"encoding of @var{str}.")
#define FUNC_NAME s_scm_string_to_utf32
{
- STRING_TO_UTF (32);
+ SCM bv;
+ scm_t_wchar *wchars;
+ size_t wchar_len, bytes_len;
+
+ wchars = scm_to_utf32_stringn (str, &wchar_len);
+ bytes_len = wchar_len * sizeof (scm_t_wchar);
+ if (!scm_is_eq (SCM_UNBNDP (endianness) ? scm_endianness_big : endianness,
+ scm_i_native_endianness))
+ swap_u32 (wchars, wchar_len);
+
+ bv = make_bytevector (bytes_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
+ memcpy (SCM_BYTEVECTOR_CONTENTS (bv), wchars, bytes_len);
+ free (wchars);
+
+ return bv;
}
#undef FUNC_NAME
#define UTF_TO_STRING(_utf_width) \
SCM str = SCM_BOOL_F; \
int err; \
- char *c_str = NULL, *c_locale; \
+ char *c_str = NULL; \
char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
- const char *c_utf; \
- size_t c_strlen = 0, c_utf_len; \
+ char *c_utf; \
+ size_t c_strlen = 0, c_utf_len = 0; \
\
SCM_VALIDATE_BYTEVECTOR (1, utf); \
- if (endianness == SCM_UNDEFINED) \
+ if (scm_is_eq (endianness, SCM_UNDEFINED)) \
endianness = scm_sym_big; \
else \
SCM_VALIDATE_SYMBOL (2, endianness); \
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 ()); \
- \
+ scm_i_lock_iconv (); \
err = mem_iconveh (c_utf, c_utf_len, \
- c_utf_name, c_locale, \
+ c_utf_name, "UTF-8", \
iconveh_question_mark, NULL, \
&c_str, &c_strlen); \
+ scm_i_unlock_iconv (); \
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); \
- \
+ { \
+ str = scm_from_stringn (c_str, c_strlen, "UTF-8", \
+ SCM_FAILED_CONVERSION_ERROR); \
+ free (c_str); \
+ } \
return (str);
#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;
+ size_t c_utf_len = 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);
+ str = scm_from_stringn (c_utf, c_utf_len, "UTF-8",
+ SCM_FAILED_CONVERSION_ERROR);
return (str);
}
}
#undef FUNC_NAME
-
\f
/* Bytevectors as generalized vectors & arrays. */
+#define COMPLEX_ACCESSOR_PROLOGUE(_type) \
+ size_t c_len, c_index; \
+ char *c_bv; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, bv); \
+ c_index = scm_to_size_t (index); \
+ \
+ c_len = SCM_BYTEVECTOR_LENGTH (bv); \
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
+ \
+ if (SCM_UNLIKELY (c_index + 2 * sizeof (_type) - 1 >= c_len)) \
+ scm_out_of_range (FUNC_NAME, index);
+
+/* Template for native access to complex numbers of type TYPE. */
+#define COMPLEX_NATIVE_REF(_type) \
+ SCM result; \
+ \
+ COMPLEX_ACCESSOR_PROLOGUE (_type); \
+ \
+ { \
+ _type real, imag; \
+ \
+ memcpy (&real, &c_bv[c_index], sizeof (_type)); \
+ memcpy (&imag, &c_bv[c_index + sizeof (_type)], sizeof (_type)); \
+ \
+ result = scm_c_make_rectangular (real, imag); \
+ } \
+ \
+ return result;
+
+static SCM
+bytevector_ref_c32 (SCM bv, SCM index)
+#define FUNC_NAME "bytevector_ref_c32"
+{
+ COMPLEX_NATIVE_REF (float);
+}
+#undef FUNC_NAME
+
+static SCM
+bytevector_ref_c64 (SCM bv, SCM index)
+#define FUNC_NAME "bytevector_ref_c64"
+{
+ COMPLEX_NATIVE_REF (double);
+}
+#undef FUNC_NAME
+
+typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM);
+
+static const scm_t_bytevector_ref_fn
+bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
+{
+ NULL, /* SCM */
+ NULL, /* CHAR */
+ NULL, /* BIT */
+ scm_bytevector_u8_ref, /* VU8 */
+ scm_bytevector_u8_ref, /* U8 */
+ scm_bytevector_s8_ref,
+ scm_bytevector_u16_native_ref,
+ scm_bytevector_s16_native_ref,
+ scm_bytevector_u32_native_ref,
+ scm_bytevector_s32_native_ref,
+ scm_bytevector_u64_native_ref,
+ scm_bytevector_s64_native_ref,
+ scm_bytevector_ieee_single_native_ref,
+ scm_bytevector_ieee_double_native_ref,
+ bytevector_ref_c32,
+ bytevector_ref_c64
+};
+
static SCM
bv_handle_ref (scm_t_array_handle *h, size_t index)
{
- return SCM_I_MAKINUM (scm_c_bytevector_ref (h->array, index));
+ SCM byte_index;
+ scm_t_bytevector_ref_fn ref_fn;
+
+ ref_fn = bytevector_ref_fns[h->element_type];
+ byte_index =
+ scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
+ return ref_fn (h->array, byte_index);
}
+/* Template for native modification of complex numbers of type TYPE. */
+#define COMPLEX_NATIVE_SET(_type) \
+ COMPLEX_ACCESSOR_PROLOGUE (_type); \
+ \
+ { \
+ _type real, imag; \
+ real = scm_c_real_part (value); \
+ imag = scm_c_imag_part (value); \
+ \
+ memcpy (&c_bv[c_index], &real, sizeof (_type)); \
+ memcpy (&c_bv[c_index + sizeof (_type)], &imag, sizeof (_type)); \
+ } \
+ \
+ return SCM_UNSPECIFIED;
+
+static SCM
+bytevector_set_c32 (SCM bv, SCM index, SCM value)
+#define FUNC_NAME "bytevector_set_c32"
+{
+ COMPLEX_NATIVE_SET (float);
+}
+#undef FUNC_NAME
+
+static SCM
+bytevector_set_c64 (SCM bv, SCM index, SCM value)
+#define FUNC_NAME "bytevector_set_c64"
+{
+ COMPLEX_NATIVE_SET (double);
+}
+#undef FUNC_NAME
+
+typedef SCM (*scm_t_bytevector_set_fn)(SCM, SCM, SCM);
+
+const scm_t_bytevector_set_fn bytevector_set_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
+{
+ NULL, /* SCM */
+ NULL, /* CHAR */
+ NULL, /* BIT */
+ scm_bytevector_u8_set_x, /* VU8 */
+ scm_bytevector_u8_set_x, /* U8 */
+ scm_bytevector_s8_set_x,
+ scm_bytevector_u16_native_set_x,
+ scm_bytevector_s16_native_set_x,
+ scm_bytevector_u32_native_set_x,
+ scm_bytevector_s32_native_set_x,
+ scm_bytevector_u64_native_set_x,
+ scm_bytevector_s64_native_set_x,
+ scm_bytevector_ieee_single_native_set_x,
+ scm_bytevector_ieee_double_native_set_x,
+ bytevector_set_c32,
+ bytevector_set_c64
+};
+
static void
bv_handle_set_x (scm_t_array_handle *h, size_t index, SCM val)
{
- scm_c_bytevector_set_x (h->array, index, scm_to_uint8 (val));
+ SCM byte_index;
+ scm_t_bytevector_set_fn set_fn;
+
+ set_fn = bytevector_set_fns[h->element_type];
+ byte_index =
+ scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
+ set_fn (h->array, byte_index, val);
}
static void
h->ndims = 1;
h->dims = &h->dim0;
h->dim0.lbnd = 0;
- h->dim0.ubnd = SCM_BYTEVECTOR_LENGTH (v) - 1;
+ h->dim0.ubnd = SCM_BYTEVECTOR_TYPED_LENGTH (v) - 1;
h->dim0.inc = 1;
- h->element_type = SCM_ARRAY_ELEMENT_TYPE_VU8;
+ h->element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (v);
h->elements = h->writable_elements = SCM_BYTEVECTOR_CONTENTS (v);
}
void
scm_bootstrap_bytevectors (void)
{
- /* The SMOB type must be instantiated here because the
- generalized-vector API may want to access bytevectors even though
- `(rnrs bytevector)' hasn't been loaded. */
- scm_tc16_bytevector = scm_make_smob_type ("bytevector", 0);
- scm_set_smob_free (scm_tc16_bytevector, free_bytevector);
- scm_set_smob_print (scm_tc16_bytevector, print_bytevector);
- scm_set_smob_equalp (scm_tc16_bytevector, bytevector_equal_p);
-
- scm_null_bytevector =
- scm_gc_protect_object (make_bytevector_from_buffer (0, NULL));
+ /* This must be instantiated here because the generalized-vector API may
+ want to access bytevectors even though `(rnrs bytevectors)' hasn't been
+ loaded. */
+ scm_null_bytevector = make_bytevector (0, SCM_ARRAY_ELEMENT_TYPE_VU8);
#ifdef WORDS_BIGENDIAN
- scm_i_native_endianness = scm_permanent_object (scm_from_locale_symbol ("big"));
+ scm_i_native_endianness = scm_from_latin1_symbol ("big");
#else
- scm_i_native_endianness = scm_permanent_object (scm_from_locale_symbol ("little"));
+ scm_i_native_endianness = scm_from_latin1_symbol ("little");
#endif
- scm_c_register_extension ("libguile", "scm_init_bytevectors",
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_bytevectors",
(scm_t_extension_init_func) scm_init_bytevectors,
NULL);
{
scm_t_array_implementation impl;
-
- impl.tag = scm_tc16_bytevector;
- impl.mask = 0xffff;
+
+ impl.tag = scm_tc7_bytevector;
+ impl.mask = 0x7f;
impl.vref = bv_handle_ref;
impl.vset = bv_handle_set_x;
impl.get_handle = bytevector_get_handle;