-/* Copyright (C) 2009-2014 Free Software Foundation, Inc.
+/* Copyright (C) 2009-2015 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
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) \
if (SCM_UNLIKELY (element_type > SCM_ARRAY_ELEMENT_TYPE_LAST
|| scm_i_array_element_type_sizes[element_type] < 8
- || len >= (SCM_I_SIZE_MAX
+ || len >= (((size_t) -1)
/ (scm_i_array_element_type_sizes[element_type]/8))))
/* This would be an internal Guile programming error */
abort ();
contents = scm_gc_malloc_pointerless (SCM_BYTEVECTOR_HEADER_BYTES + c_len,
SCM_GC_BYTEVECTOR);
- ret = PTR2SCM (contents);
+ 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;
{
size_t c_len;
- ret = PTR2SCM (scm_gc_malloc (SCM_BYTEVECTOR_HEADER_BYTES,
+ ret = SCM_PACK_POINTER (scm_gc_malloc (SCM_BYTEVECTOR_HEADER_BYTES,
SCM_GC_BYTEVECTOR));
c_len = len * (scm_i_array_element_type_sizes[element_type] / 8);
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 ret;
return make_bytevector (len, element_type);
}
-/* 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 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_c_take_gc_bytevector (signed char *contents, size_t len, SCM parent)
{
- return make_bytevector_from_buffer (len, contents, SCM_ARRAY_ELEMENT_TYPE_VU8);
+ SCM ret;
+
+ ret = make_bytevector_from_buffer (len, contents, SCM_ARRAY_ELEMENT_TYPE_VU8);
+ SCM_BYTEVECTOR_SET_PARENT (ret, parent);
+
+ return ret;
}
SCM
scm_c_take_typed_bytevector (signed char *contents, size_t len,
- scm_t_array_element_type element_type)
+ scm_t_array_element_type element_type, SCM parent)
{
- return make_bytevector_from_buffer (len, contents, element_type);
+ 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
scm_array_get_handle (bv, &h);
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
scm_write (scm_array_handle_element_type (&h), port);
- scm_putc ('(', 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_putc_unlocked (' ', port);
scm_write (scm_array_handle_ref (&h, i), port);
}
- scm_putc (')', port);
+ scm_putc_unlocked (')', port);
return 1;
}
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;
+ /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
+ units. */
+ byte_len = ((len * sz + 31) / 32) * 4;
else
/* an internal guile error, really */
SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL);
/* C_SIZE must have its 3 higher bits set to zero so that \
multiplying it by 8 yields a number that fits in a \
size_t. */ \
- if (SCM_UNLIKELY (c_size == 0 || c_size >= (SCM_I_SIZE_MAX >> 3))) \
+ if (SCM_UNLIKELY (c_size == 0 || c_size >= (SIZE_MAX >> 3))) \
scm_out_of_range (FUNC_NAME, size); \
if (SCM_UNLIKELY (c_index + c_size > c_len)) \
scm_out_of_range (FUNC_NAME, index);
c_size = scm_to_unsigned_integer (size, 1, (size_t) -1); \
\
c_len = SCM_BYTEVECTOR_LENGTH (bv); \
- if (SCM_UNLIKELY (c_len < c_size)) \
+ if (SCM_UNLIKELY (c_len % c_size != 0)) \
+ scm_wrong_type_arg_msg \
+ (FUNC_NAME, 0, size, \
+ "an exact positive integer that divides the bytevector length"); \
+ else if (SCM_UNLIKELY (c_len == 0)) \
lst = SCM_EOL; \
else \
{ \
SCM_VALIDATE_SYMBOL (2, endianness); \
c_size = scm_to_size_t (size); \
\
- if (SCM_UNLIKELY (c_size == 0 || c_size >= (SCM_I_SIZE_MAX >> 3))) \
+ if (SCM_UNLIKELY (c_size == 0 || c_size >= (SIZE_MAX >> 3))) \
scm_out_of_range (FUNC_NAME, size); \
\
bv = make_bytevector (c_len * c_size, SCM_ARRAY_ELEMENT_TYPE_VU8); \
scm_list_1 (utf), err); \
else \
{ \
- str = scm_from_stringn (c_str, c_strlen, "UTF-8", \
- SCM_FAILED_CONVERSION_ERROR); \
+ str = scm_from_utf8_stringn (c_str, c_strlen); \
free (c_str); \
} \
return (str);
c_utf_len = SCM_BYTEVECTOR_LENGTH (utf);
c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf);
- str = scm_from_stringn (c_utf, c_utf_len, "UTF-8",
- SCM_FAILED_CONVERSION_ERROR);
+ str = scm_from_utf8_stringn (c_utf, c_utf_len);
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)
-{
- 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 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
-bytevector_get_handle (SCM v, scm_t_array_handle *h)
-{
- h->array = v;
- h->ndims = 1;
- h->dims = &h->dim0;
- h->dim0.lbnd = 0;
- h->dim0.ubnd = SCM_BYTEVECTOR_TYPED_LENGTH (v) - 1;
- h->dim0.inc = 1;
- h->element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (v);
- h->elements = h->writable_elements = SCM_BYTEVECTOR_CONTENTS (v);
-}
-
-\f
/* Initialization. */
void
(scm_t_extension_init_func) scm_init_bytevectors,
NULL);
- {
- scm_t_array_implementation impl;
-
- 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);
- }
+ scm_i_register_vector_constructor
+ (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8],
+ scm_make_bytevector);
}
void
HCoop / bpt / guile.git / blobdiff