-/* Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010, 2011, 2012, 2013 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
#include "libguile/bytevectors.h"
#include "libguile/strings.h"
#include "libguile/validate.h"
-#include "libguile/ieee-754.h"
#include "libguile/arrays.h"
#include "libguile/array-handle.h"
#include "libguile/uniform.h"
/* Bytevector type. */
#define SCM_BYTEVECTOR_HEADER_BYTES \
- (SCM_BYTEVECTOR_HEADER_SIZE * sizeof (SCM))
+ (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))
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_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 (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;
}
\
SCM_VALIDATE_BYTEVECTOR (1, bv); \
SCM_VALIDATE_SYMBOL (2, endianness); \
- c_size = scm_to_uint (size); \
+ c_size = scm_to_unsigned_integer (size, 1, (size_t) -1); \
\
c_len = SCM_BYTEVECTOR_LENGTH (bv); \
- if (SCM_UNLIKELY (c_len == 0)) \
+ if (SCM_UNLIKELY (c_len < c_size)) \
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), \
+ lst = scm_make_list (scm_from_size_t (c_len / c_size), \
SCM_UNSPECIFIED); \
for (i = 0, pair = lst; \
i <= c_len - c_size; \
Section 2.1 of R6RS-lib (in response to
http://www.r6rs.org/formal-comments/comment-187.txt). */
+union scm_ieee754_float
+{
+ float f;
+ scm_t_uint32 i;
+};
+
+union scm_ieee754_double
+{
+ double d;
+ scm_t_uint64 i;
+};
+
/* Convert to/from a floating-point number with different endianness. This
method is probably not the most efficient but it should be portable. */
float_to_foreign_endianness (union scm_ieee754_float *target,
float source)
{
- union scm_ieee754_float src;
-
- src.f = source;
+ union scm_ieee754_float input;
-#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
+ input.f = source;
+ target->i = bswap_32 (input.i);
}
static inline float
{
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
+ result.i = bswap_32 (source->i);
return (result.f);
}
double_to_foreign_endianness (union scm_ieee754_double *target,
double source)
{
- union scm_ieee754_double src;
+ union scm_ieee754_double input;
- 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
+ input.d = source;
+ target->i = bswap_64 (input.i);
}
static inline double
{
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
+ result.i = bswap_64 (source->i);
return (result.d);
}
#define FUNC_NAME s_scm_string_to_utf8
{
SCM utf;
- uint8_t *c_utf;
- size_t c_strlen, c_utf_len = 0;
+ scm_t_uint8 *c_utf;
+ size_t c_utf_len = 0;
SCM_VALIDATE_STRING (1, str);
- 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
- {
- 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);
- }
- if (SCM_UNLIKELY (c_utf == NULL))
- scm_syserror (FUNC_NAME);
- else
- {
- 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 ();
- }
+ 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
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);
}
HCoop / bpt / guile.git / blobdiff