X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/476b894c71b436f3befb8af46b899aaf244763e2..574b7be0ba5dbbecfacf172ed81a5f22d1d5566e:/libguile/bytevectors.c diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 75028aee1..f01469774 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2009 Free Software Foundation, Inc. +/* Copyright (C) 2009, 2010, 2011 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 @@ -22,6 +22,7 @@ #endif #include +#include #include @@ -39,6 +40,7 @@ #include #include #include +#include #ifdef HAVE_LIMITS_H # include @@ -129,7 +131,7 @@ 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))) \ @@ -154,7 +156,7 @@ 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))) \ @@ -175,49 +177,109 @@ /* 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)) + +#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_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 >= (SCM_I_SIZE_MAX + / (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 = PTR2SCM (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); + } + + 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; - if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len)) - contents = (signed char *) scm_gc_malloc (len, SCM_GC_BYTEVECTOR); + ret = PTR2SCM (scm_gc_malloc (SCM_BYTEVECTOR_HEADER_BYTES, + SCM_GC_BYTEVECTOR)); - bv = make_bytevector_from_buffer (len, contents); + c_len = len * (scm_i_array_element_type_sizes[element_type] / 8); + + 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); } - 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 new bytevector of size LEN elements. */ +SCM +scm_i_make_typed_bytevector (size_t len, scm_t_array_element_type element_type) +{ + return make_bytevector (len, element_type); } /* Return a bytevector of size LEN made up of CONTENTS. The area pointed to @@ -225,62 +287,57 @@ scm_c_make_bytevector (size_t len) SCM scm_c_take_bytevector (signed char *contents, size_t 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 make_bytevector_from_buffer (len, contents, SCM_ARRAY_ELEMENT_TYPE_VU8); +} - return bv; +SCM +scm_c_take_typed_bytevector (signed char *contents, size_t len, + scm_t_array_element_type element_type) +{ + return make_bytevector_from_buffer (len, contents, element_type); } /* 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 @@ -331,66 +388,31 @@ scm_c_bytevector_set_x (SCM bv, size_t index, scm_t_uint8 value) } #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) + +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 ('#', port); + scm_write (scm_array_handle_element_type (&h), port); + scm_putc ('(', 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_write (scm_array_handle_ref (&h, i), port); } - scm_putc (')', port); - /* Make GCC think we use it. */ - scm_remember_upto_here ((SCM) pstate); - 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; -} - - /* General operations. */ @@ -450,7 +472,7 @@ SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0, c_fill = (signed char) value; } - bv = make_bytevector (c_len); + bv = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8); if (fill != SCM_UNDEFINED) { unsigned i; @@ -460,6 +482,8 @@ SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0, for (i = 0; i < c_len; i++) contents[i] = c_fill; } + else + memset (SCM_BYTEVECTOR_CONTENTS (bv), 0, c_len); return bv; } @@ -489,7 +513,8 @@ SCM_DEFINE (scm_bytevector_eq_p, "bytevector=?", 2, 0, 0, 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; @@ -576,7 +601,7 @@ SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0, 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); @@ -591,23 +616,31 @@ SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector", #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); @@ -695,7 +728,7 @@ SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0, 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++) @@ -704,7 +737,7 @@ SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0, 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))) @@ -920,7 +953,7 @@ bytevector_unsigned_ref (const char *c_bv, size_t c_size, SCM endianness) #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; \ @@ -1132,7 +1165,7 @@ SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list", 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; \ @@ -1631,6 +1664,12 @@ double_from_foreign_endianness (const union scm_ieee754_double *source) _c_type ## _to_foreign_endianness +/* FIXME: SCM_VALIDATE_REAL rejects integers, etc. grrr */ +#define VALIDATE_REAL(pos, v) \ + do { \ + SCM_ASSERT_TYPE (scm_is_true (scm_rational_p (v)), v, pos, FUNC_NAME, "real"); \ + } while (0) + /* Templace getters and setters. */ #define IEEE754_ACCESSOR_PROLOGUE(_type) \ @@ -1667,7 +1706,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source) _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); \ \ @@ -1687,7 +1726,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source) _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)); \ @@ -1860,48 +1899,50 @@ utf_encoding_name (char *name, size_t utf_width, SCM endianness) #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 (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)) \ + { \ + 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); \ + 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); \ + c_utf = u32_conv_to_encoding (c_utf_name, \ + iconveh_question_mark, \ + (scm_t_uint32 *) wbuf, \ + c_strlen, NULL, NULL, &c_utf_len); \ + 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); @@ -1913,29 +1954,33 @@ SCM_DEFINE (scm_string_to_utf8, "string->utf8", #define FUNC_NAME s_scm_string_to_utf8 { SCM utf; - char *c_str; uint8_t *c_utf; - size_t c_strlen, c_raw_strlen; + size_t c_strlen, c_utf_len = 0; SCM_VALIDATE_STRING (1, str); - c_strlen = scm_c_string_length (str); - c_raw_strlen = c_strlen; - do + c_strlen = scm_i_string_length (str); + if (scm_i_is_narrow_string (str)) + c_utf = u8_conv_from_encoding ("ISO-8859-1", iconveh_question_mark, + scm_i_string_chars (str), c_strlen, + NULL, NULL, &c_utf_len); + else { - c_str = (char *) alloca (c_raw_strlen + 1); - c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); + const scm_t_wchar *wbuf = scm_i_string_wide_chars (str); + c_utf = u32_to_u8 ((const uint32_t *) wbuf, c_strlen, NULL, &c_utf_len); } - 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)); + { + 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); } @@ -1969,10 +2014,10 @@ SCM_DEFINE (scm_string_to_utf32, "string->utf32", #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) \ @@ -1984,20 +2029,19 @@ SCM_DEFINE (scm_string_to_utf32, "string->utf32", 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, \ + c_utf_name, "UTF-8", \ 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_str, c_strlen, "UTF-8", \ + SCM_FAILED_CONVERSION_ERROR); \ + free (c_str); \ + } \ return (str); @@ -2009,29 +2053,15 @@ SCM_DEFINE (scm_utf8_to_string, "utf8->string", #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); } @@ -2059,20 +2089,111 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string", } #undef FUNC_NAME - /* Bytevectors as generalized vectors & arrays. */ + +static SCM +bytevector_ref_c32 (SCM bv, SCM idx) +{ /* FIXME add some checks */ + const float *contents = (const float*)SCM_BYTEVECTOR_CONTENTS (bv); + size_t i = scm_to_size_t (idx); + return scm_c_make_rectangular (contents[i/4], contents[i/4 + 1]); +} + +static SCM +bytevector_ref_c64 (SCM bv, SCM idx) +{ /* FIXME add some checks */ + const double *contents = (const double*)SCM_BYTEVECTOR_CONTENTS (bv); + size_t i = scm_to_size_t (idx); + return scm_c_make_rectangular (contents[i/8], contents[i/8 + 1]); +} + +typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM); + +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); +} + +/* FIXME add checks!!! */ +static SCM +bytevector_set_c32 (SCM bv, SCM idx, SCM val) +{ float *contents = (float*)SCM_BYTEVECTOR_CONTENTS (bv); + size_t i = scm_to_size_t (idx); + contents[i/4] = scm_c_real_part (val); + contents[i/4 + 1] = scm_c_imag_part (val); + return SCM_UNSPECIFIED; } +static SCM +bytevector_set_c64 (SCM bv, SCM idx, SCM val) +{ double *contents = (double*)SCM_BYTEVECTOR_CONTENTS (bv); + size_t i = scm_to_size_t (idx); + contents[i/8] = scm_c_real_part (val); + contents[i/8 + 1] = scm_c_imag_part (val); + return SCM_UNSPECIFIED; +} + +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 @@ -2082,9 +2203,9 @@ bytevector_get_handle (SCM v, scm_t_array_handle *h) 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); } @@ -2094,35 +2215,34 @@ bytevector_get_handle (SCM v, scm_t_array_handle *h) 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; scm_i_register_array_implementation (&impl); + scm_i_register_vector_constructor + (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8], + scm_make_bytevector); } }