1 /* Copyright (C) 2009-2015 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
29 #include "libguile/_scm.h"
30 #include "libguile/extensions.h"
31 #include "libguile/bytevectors.h"
32 #include "libguile/strings.h"
33 #include "libguile/validate.h"
34 #include "libguile/arrays.h"
35 #include "libguile/array-handle.h"
36 #include "libguile/uniform.h"
37 #include "libguile/srfi-4.h"
40 #include <striconveh.h>
54 /* Convenience macros. These are used by the various templates (macros) that
55 are parameterized by integer signedness. */
56 #define INT8_T_signed scm_t_int8
57 #define INT8_T_unsigned scm_t_uint8
58 #define INT16_T_signed scm_t_int16
59 #define INT16_T_unsigned scm_t_uint16
60 #define INT32_T_signed scm_t_int32
61 #define INT32_T_unsigned scm_t_uint32
62 #define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L))
63 #define is_unsigned_int8(_x) ((_x) <= 255UL)
64 #define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
65 #define is_unsigned_int16(_x) ((_x) <= 65535UL)
66 #define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L))
67 #define is_unsigned_int32(_x) ((_x) <= 4294967295UL)
68 #define SIGNEDNESS_signed 1
69 #define SIGNEDNESS_unsigned 0
71 #define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign
72 #define INT_SWAP(_size) bswap_ ## _size
73 #define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
74 #define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
77 #define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \
78 size_t c_len, c_index; \
81 SCM_VALIDATE_BYTEVECTOR (1, bv); \
82 c_index = scm_to_uint (index); \
84 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
85 c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \
87 if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
88 scm_out_of_range (FUNC_NAME, index);
90 /* Template for fixed-size integer access (only 8, 16 or 32-bit). */
91 #define INTEGER_REF(_len, _sign) \
94 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
95 SCM_VALIDATE_SYMBOL (3, endianness); \
98 INT_TYPE (_len, _sign) c_result; \
100 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
101 if (!scm_is_eq (endianness, scm_i_native_endianness)) \
102 c_result = INT_SWAP (_len) (c_result); \
104 result = SCM_I_MAKINUM (c_result); \
109 /* Template for fixed-size integer access using the native endianness. */
110 #define INTEGER_NATIVE_REF(_len, _sign) \
113 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
116 INT_TYPE (_len, _sign) c_result; \
118 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
119 result = SCM_I_MAKINUM (c_result); \
124 /* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
125 #define INTEGER_SET(_len, _sign) \
126 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
127 SCM_VALIDATE_SYMBOL (3, endianness); \
130 scm_t_signed_bits c_value; \
131 INT_TYPE (_len, _sign) c_value_short; \
133 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
134 scm_wrong_type_arg (FUNC_NAME, 3, value); \
136 c_value = SCM_I_INUM (value); \
137 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
138 scm_out_of_range (FUNC_NAME, value); \
140 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
141 if (!scm_is_eq (endianness, scm_i_native_endianness)) \
142 c_value_short = INT_SWAP (_len) (c_value_short); \
144 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
147 return SCM_UNSPECIFIED;
149 /* Template for fixed-size integer modification using the native
151 #define INTEGER_NATIVE_SET(_len, _sign) \
152 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
155 scm_t_signed_bits c_value; \
156 INT_TYPE (_len, _sign) c_value_short; \
158 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
159 scm_wrong_type_arg (FUNC_NAME, 3, value); \
161 c_value = SCM_I_INUM (value); \
162 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
163 scm_out_of_range (FUNC_NAME, value); \
165 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
167 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
170 return SCM_UNSPECIFIED;
174 /* Bytevector type. */
176 #define SCM_BYTEVECTOR_HEADER_BYTES \
177 (SCM_BYTEVECTOR_HEADER_SIZE * sizeof (scm_t_bits))
179 #define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
180 SCM_SET_CELL_WORD_1 ((_bv), (scm_t_bits) (_len))
181 #define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _contents) \
182 SCM_SET_CELL_WORD_2 ((_bv), (scm_t_bits) (_contents))
183 #define SCM_BYTEVECTOR_SET_CONTIGUOUS_P(bv, contiguous_p) \
184 SCM_SET_BYTEVECTOR_FLAGS ((bv), \
185 SCM_BYTEVECTOR_ELEMENT_TYPE (bv) \
186 | ((contiguous_p) << 8UL))
188 #define SCM_BYTEVECTOR_SET_ELEMENT_TYPE(bv, hint) \
189 SCM_SET_BYTEVECTOR_FLAGS ((bv), \
191 | (SCM_BYTEVECTOR_CONTIGUOUS_P (bv) << 8UL))
192 #define SCM_BYTEVECTOR_SET_PARENT(_bv, _parent) \
193 SCM_SET_CELL_OBJECT_3 ((_bv), (_parent))
195 #define SCM_BYTEVECTOR_TYPE_SIZE(var) \
196 (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
197 #define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
198 (SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var))
200 /* The empty bytevector. */
201 SCM scm_null_bytevector
= SCM_UNSPECIFIED
;
205 make_bytevector (size_t len
, scm_t_array_element_type element_type
)
210 if (SCM_UNLIKELY (element_type
> SCM_ARRAY_ELEMENT_TYPE_LAST
211 || scm_i_array_element_type_sizes
[element_type
] < 8
212 || len
>= (((size_t) -1)
213 / (scm_i_array_element_type_sizes
[element_type
]/8))))
214 /* This would be an internal Guile programming error */
217 if (SCM_UNLIKELY (len
== 0 && element_type
== SCM_ARRAY_ELEMENT_TYPE_VU8
218 && SCM_BYTEVECTOR_P (scm_null_bytevector
)))
219 ret
= scm_null_bytevector
;
222 signed char *contents
;
224 c_len
= len
* (scm_i_array_element_type_sizes
[element_type
] / 8);
226 contents
= scm_gc_malloc_pointerless (SCM_BYTEVECTOR_HEADER_BYTES
+ c_len
,
228 ret
= SCM_PACK_POINTER (contents
);
229 contents
+= SCM_BYTEVECTOR_HEADER_BYTES
;
231 SCM_BYTEVECTOR_SET_LENGTH (ret
, c_len
);
232 SCM_BYTEVECTOR_SET_CONTENTS (ret
, contents
);
233 SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret
, 1);
234 SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret
, element_type
);
235 SCM_BYTEVECTOR_SET_PARENT (ret
, SCM_BOOL_F
);
241 /* Return a bytevector of LEN elements of type ELEMENT_TYPE, with element
242 values taken from CONTENTS. Assume that the storage for CONTENTS will be
243 automatically reclaimed when it becomes unreachable. */
245 make_bytevector_from_buffer (size_t len
, void *contents
,
246 scm_t_array_element_type element_type
)
250 if (SCM_UNLIKELY (len
== 0))
251 ret
= make_bytevector (len
, element_type
);
256 ret
= SCM_PACK_POINTER (scm_gc_malloc (SCM_BYTEVECTOR_HEADER_BYTES
,
259 c_len
= len
* (scm_i_array_element_type_sizes
[element_type
] / 8);
261 SCM_BYTEVECTOR_SET_LENGTH (ret
, c_len
);
262 SCM_BYTEVECTOR_SET_CONTENTS (ret
, contents
);
263 SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret
, 0);
264 SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret
, element_type
);
265 SCM_BYTEVECTOR_SET_PARENT (ret
, SCM_BOOL_F
);
272 /* Return a new bytevector of size LEN octets. */
274 scm_c_make_bytevector (size_t len
)
276 return make_bytevector (len
, SCM_ARRAY_ELEMENT_TYPE_VU8
);
279 /* Return a new bytevector of size LEN elements. */
281 scm_i_make_typed_bytevector (size_t len
, scm_t_array_element_type element_type
)
283 return make_bytevector (len
, element_type
);
286 /* Return a bytevector of size LEN made up of CONTENTS. The area
287 pointed to by CONTENTS must be protected from GC somehow: either
288 because it was allocated using `scm_gc_malloc ()', or because it is
291 scm_c_take_gc_bytevector (signed char *contents
, size_t len
, SCM parent
)
295 ret
= make_bytevector_from_buffer (len
, contents
, SCM_ARRAY_ELEMENT_TYPE_VU8
);
296 SCM_BYTEVECTOR_SET_PARENT (ret
, parent
);
302 scm_c_take_typed_bytevector (signed char *contents
, size_t len
,
303 scm_t_array_element_type element_type
, SCM parent
)
307 ret
= make_bytevector_from_buffer (len
, contents
, element_type
);
308 SCM_BYTEVECTOR_SET_PARENT (ret
, parent
);
313 /* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
314 size) and return the new bytevector (possibly different from BV). */
316 scm_c_shrink_bytevector (SCM bv
, size_t c_new_len
)
321 if (SCM_UNLIKELY (c_new_len
% SCM_BYTEVECTOR_TYPE_SIZE (bv
)))
322 /* This would be an internal Guile programming error */
325 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
326 if (SCM_UNLIKELY (c_new_len
> c_len
))
329 SCM_BYTEVECTOR_SET_LENGTH (bv
, c_new_len
);
331 if (SCM_BYTEVECTOR_CONTIGUOUS_P (bv
))
335 c_bv
= scm_gc_realloc (SCM2PTR (bv
),
336 c_len
+ SCM_BYTEVECTOR_HEADER_BYTES
,
337 c_new_len
+ SCM_BYTEVECTOR_HEADER_BYTES
,
339 new_bv
= PTR2SCM (c_bv
);
340 SCM_BYTEVECTOR_SET_CONTENTS (new_bv
, c_bv
+ SCM_BYTEVECTOR_HEADER_BYTES
);
346 c_bv
= scm_gc_realloc (SCM_BYTEVECTOR_CONTENTS (bv
),
347 c_len
, c_new_len
, SCM_GC_BYTEVECTOR
);
348 SCM_BYTEVECTOR_SET_CONTENTS (bv
, c_bv
);
357 scm_is_bytevector (SCM obj
)
359 return SCM_BYTEVECTOR_P (obj
);
363 scm_c_bytevector_length (SCM bv
)
364 #define FUNC_NAME "scm_c_bytevector_length"
366 SCM_VALIDATE_BYTEVECTOR (1, bv
);
368 return SCM_BYTEVECTOR_LENGTH (bv
);
373 scm_c_bytevector_ref (SCM bv
, size_t index
)
374 #define FUNC_NAME "scm_c_bytevector_ref"
377 const scm_t_uint8
*c_bv
;
379 SCM_VALIDATE_BYTEVECTOR (1, bv
);
381 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
382 c_bv
= (scm_t_uint8
*) SCM_BYTEVECTOR_CONTENTS (bv
);
384 if (SCM_UNLIKELY (index
>= c_len
))
385 scm_out_of_range (FUNC_NAME
, scm_from_size_t (index
));
392 scm_c_bytevector_set_x (SCM bv
, size_t index
, scm_t_uint8 value
)
393 #define FUNC_NAME "scm_c_bytevector_set_x"
398 SCM_VALIDATE_BYTEVECTOR (1, bv
);
400 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
401 c_bv
= (scm_t_uint8
*) SCM_BYTEVECTOR_CONTENTS (bv
);
403 if (SCM_UNLIKELY (index
>= c_len
))
404 scm_out_of_range (FUNC_NAME
, scm_from_size_t (index
));
413 scm_i_print_bytevector (SCM bv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
415 ssize_t ubnd
, inc
, i
;
416 scm_t_array_handle h
;
418 scm_array_get_handle (bv
, &h
);
420 scm_putc_unlocked ('#', port
);
421 scm_write (scm_array_handle_element_type (&h
), port
);
422 scm_putc_unlocked ('(', port
);
423 for (i
= h
.dims
[0].lbnd
, ubnd
= h
.dims
[0].ubnd
, inc
= h
.dims
[0].inc
;
427 scm_putc_unlocked (' ', port
);
428 scm_write (scm_array_handle_ref (&h
, i
), port
);
430 scm_putc_unlocked (')', port
);
436 /* General operations. */
438 SCM_SYMBOL (scm_sym_big
, "big");
439 SCM_SYMBOL (scm_sym_little
, "little");
441 SCM scm_endianness_big
, scm_endianness_little
;
443 /* Host endianness (a symbol). */
444 SCM scm_i_native_endianness
= SCM_UNSPECIFIED
;
448 # define bswap_24(_x) \
449 ((((_x) & 0xff0000) >> 16) | \
450 (((_x) & 0x00ff00)) | \
451 (((_x) & 0x0000ff) << 16))
455 SCM_DEFINE (scm_native_endianness
, "native-endianness", 0, 0, 0,
457 "Return a symbol denoting the machine's native endianness.")
458 #define FUNC_NAME s_scm_native_endianness
460 return scm_i_native_endianness
;
464 SCM_DEFINE (scm_bytevector_p
, "bytevector?", 1, 0, 0,
466 "Return true if @var{obj} is a bytevector.")
467 #define FUNC_NAME s_scm_bytevector_p
469 return scm_from_bool (scm_is_bytevector (obj
));
473 SCM_DEFINE (scm_make_bytevector
, "make-bytevector", 1, 1, 0,
475 "Return a newly allocated bytevector of @var{len} bytes, "
476 "optionally filled with @var{fill}.")
477 #define FUNC_NAME s_scm_make_bytevector
481 scm_t_uint8 c_fill
= 0;
483 SCM_VALIDATE_SIZE_COPY (1, len
, c_len
);
484 if (!scm_is_eq (fill
, SCM_UNDEFINED
))
488 value
= scm_to_int (fill
);
489 if (SCM_UNLIKELY ((value
< -128) || (value
> 255)))
490 scm_out_of_range (FUNC_NAME
, fill
);
491 c_fill
= (scm_t_uint8
) value
;
494 bv
= make_bytevector (c_len
, SCM_ARRAY_ELEMENT_TYPE_VU8
);
495 if (!scm_is_eq (fill
, SCM_UNDEFINED
))
498 scm_t_uint8
*contents
;
500 contents
= (scm_t_uint8
*) SCM_BYTEVECTOR_CONTENTS (bv
);
501 for (i
= 0; i
< c_len
; i
++)
502 contents
[i
] = c_fill
;
505 memset (SCM_BYTEVECTOR_CONTENTS (bv
), 0, c_len
);
511 SCM_DEFINE (scm_bytevector_length
, "bytevector-length", 1, 0, 0,
513 "Return the length (in bytes) of @var{bv}.")
514 #define FUNC_NAME s_scm_bytevector_length
516 return scm_from_uint (scm_c_bytevector_length (bv
));
520 SCM_DEFINE (scm_bytevector_eq_p
, "bytevector=?", 2, 0, 0,
522 "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
523 "have the same length and contents.")
524 #define FUNC_NAME s_scm_bytevector_eq_p
526 SCM result
= SCM_BOOL_F
;
527 size_t c_len1
, c_len2
;
529 SCM_VALIDATE_BYTEVECTOR (1, bv1
);
530 SCM_VALIDATE_BYTEVECTOR (2, bv2
);
532 c_len1
= SCM_BYTEVECTOR_LENGTH (bv1
);
533 c_len2
= SCM_BYTEVECTOR_LENGTH (bv2
);
535 if (c_len1
== c_len2
&& (SCM_BYTEVECTOR_ELEMENT_TYPE (bv1
)
536 == SCM_BYTEVECTOR_ELEMENT_TYPE (bv2
)))
538 signed char *c_bv1
, *c_bv2
;
540 c_bv1
= SCM_BYTEVECTOR_CONTENTS (bv1
);
541 c_bv2
= SCM_BYTEVECTOR_CONTENTS (bv2
);
543 result
= scm_from_bool (!memcmp (c_bv1
, c_bv2
, c_len1
));
550 SCM_DEFINE (scm_bytevector_fill_x
, "bytevector-fill!", 2, 0, 0,
552 "Fill bytevector @var{bv} with @var{fill}, a byte.")
553 #define FUNC_NAME s_scm_bytevector_fill_x
556 scm_t_uint8
*c_bv
, c_fill
;
558 SCM_VALIDATE_BYTEVECTOR (1, bv
);
559 c_fill
= scm_to_int8 (fill
);
561 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
562 c_bv
= (scm_t_uint8
*) SCM_BYTEVECTOR_CONTENTS (bv
);
564 for (i
= 0; i
< c_len
; i
++)
567 return SCM_UNSPECIFIED
;
571 SCM_DEFINE (scm_bytevector_copy_x
, "bytevector-copy!", 5, 0, 0,
572 (SCM source
, SCM source_start
, SCM target
, SCM target_start
,
574 "Copy @var{len} bytes from @var{source} into @var{target}, "
575 "starting reading from @var{source_start} (a positive index "
576 "within @var{source}) and start writing at "
577 "@var{target_start}.")
578 #define FUNC_NAME s_scm_bytevector_copy_x
580 size_t c_len
, c_source_len
, c_target_len
;
581 size_t c_source_start
, c_target_start
;
582 signed char *c_source
, *c_target
;
584 SCM_VALIDATE_BYTEVECTOR (1, source
);
585 SCM_VALIDATE_BYTEVECTOR (3, target
);
587 c_len
= scm_to_size_t (len
);
588 c_source_start
= scm_to_size_t (source_start
);
589 c_target_start
= scm_to_size_t (target_start
);
591 c_source
= SCM_BYTEVECTOR_CONTENTS (source
);
592 c_target
= SCM_BYTEVECTOR_CONTENTS (target
);
593 c_source_len
= SCM_BYTEVECTOR_LENGTH (source
);
594 c_target_len
= SCM_BYTEVECTOR_LENGTH (target
);
596 if (SCM_UNLIKELY (c_source_start
+ c_len
> c_source_len
))
597 scm_out_of_range (FUNC_NAME
, source_start
);
598 if (SCM_UNLIKELY (c_target_start
+ c_len
> c_target_len
))
599 scm_out_of_range (FUNC_NAME
, target_start
);
601 memmove (c_target
+ c_target_start
,
602 c_source
+ c_source_start
,
605 return SCM_UNSPECIFIED
;
609 SCM_DEFINE (scm_bytevector_copy
, "bytevector-copy", 1, 0, 0,
611 "Return a newly allocated copy of @var{bv}.")
612 #define FUNC_NAME s_scm_bytevector_copy
616 signed char *c_bv
, *c_copy
;
618 SCM_VALIDATE_BYTEVECTOR (1, bv
);
620 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
621 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
623 copy
= make_bytevector (c_len
, SCM_ARRAY_ELEMENT_TYPE_VU8
);
624 c_copy
= SCM_BYTEVECTOR_CONTENTS (copy
);
625 memcpy (c_copy
, c_bv
, c_len
);
631 SCM_DEFINE (scm_uniform_array_to_bytevector
, "uniform-array->bytevector",
632 1, 0, 0, (SCM array
),
633 "Return a newly allocated bytevector whose contents\n"
634 "will be copied from the uniform array @var{array}.")
635 #define FUNC_NAME s_scm_uniform_array_to_bytevector
638 size_t len
, sz
, byte_len
;
639 scm_t_array_handle h
;
642 contents
= scm_array_contents (array
, SCM_BOOL_T
);
643 if (scm_is_false (contents
))
644 scm_wrong_type_arg_msg (FUNC_NAME
, 0, array
, "uniform contiguous array");
646 scm_array_get_handle (contents
, &h
);
647 assert (h
.base
== 0);
650 len
= h
.dims
->inc
* (h
.dims
->ubnd
- h
.dims
->lbnd
+ 1);
651 sz
= scm_array_handle_uniform_element_bit_size (&h
);
652 if (sz
>= 8 && ((sz
% 8) == 0))
653 byte_len
= len
* (sz
/ 8);
655 /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
657 byte_len
= ((len
* sz
+ 31) / 32) * 4;
659 /* an internal guile error, really */
660 SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL
);
662 ret
= make_bytevector (byte_len
, SCM_ARRAY_ELEMENT_TYPE_VU8
);
663 memcpy (SCM_BYTEVECTOR_CONTENTS (ret
), elts
, byte_len
);
665 scm_array_handle_release (&h
);
672 /* Operations on bytes and octets. */
674 SCM_DEFINE (scm_bytevector_u8_ref
, "bytevector-u8-ref", 2, 0, 0,
676 "Return the octet located at @var{index} in @var{bv}.")
677 #define FUNC_NAME s_scm_bytevector_u8_ref
679 INTEGER_NATIVE_REF (8, unsigned);
683 SCM_DEFINE (scm_bytevector_s8_ref
, "bytevector-s8-ref", 2, 0, 0,
685 "Return the byte located at @var{index} in @var{bv}.")
686 #define FUNC_NAME s_scm_bytevector_s8_ref
688 INTEGER_NATIVE_REF (8, signed);
692 SCM_DEFINE (scm_bytevector_u8_set_x
, "bytevector-u8-set!", 3, 0, 0,
693 (SCM bv
, SCM index
, SCM value
),
694 "Return the octet located at @var{index} in @var{bv}.")
695 #define FUNC_NAME s_scm_bytevector_u8_set_x
697 INTEGER_NATIVE_SET (8, unsigned);
701 SCM_DEFINE (scm_bytevector_s8_set_x
, "bytevector-s8-set!", 3, 0, 0,
702 (SCM bv
, SCM index
, SCM value
),
703 "Return the octet located at @var{index} in @var{bv}.")
704 #define FUNC_NAME s_scm_bytevector_s8_set_x
706 INTEGER_NATIVE_SET (8, signed);
710 #undef OCTET_ACCESSOR_PROLOGUE
713 SCM_DEFINE (scm_bytevector_to_u8_list
, "bytevector->u8-list", 1, 0, 0,
715 "Return a newly allocated list of octets containing the "
716 "contents of @var{bv}.")
717 #define FUNC_NAME s_scm_bytevector_to_u8_list
723 SCM_VALIDATE_BYTEVECTOR (1, bv
);
725 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
726 c_bv
= (scm_t_uint8
*) SCM_BYTEVECTOR_CONTENTS (bv
);
728 lst
= scm_make_list (scm_from_size_t (c_len
), SCM_UNSPECIFIED
);
729 for (i
= 0, pair
= lst
;
731 i
++, pair
= SCM_CDR (pair
))
733 SCM_SETCAR (pair
, SCM_I_MAKINUM (c_bv
[i
]));
740 SCM_DEFINE (scm_u8_list_to_bytevector
, "u8-list->bytevector", 1, 0, 0,
742 "Turn @var{lst}, a list of octets, into a bytevector.")
743 #define FUNC_NAME s_scm_u8_list_to_bytevector
749 SCM_VALIDATE_LIST_COPYLEN (1, lst
, c_len
);
751 bv
= make_bytevector (c_len
, SCM_ARRAY_ELEMENT_TYPE_VU8
);
752 c_bv
= (scm_t_uint8
*) SCM_BYTEVECTOR_CONTENTS (bv
);
754 for (i
= 0; i
< c_len
; lst
= SCM_CDR (lst
), i
++)
756 item
= SCM_CAR (lst
);
758 if (SCM_LIKELY (SCM_I_INUMP (item
)))
760 scm_t_signed_bits c_item
;
762 c_item
= SCM_I_INUM (item
);
763 if (SCM_LIKELY ((c_item
>= 0) && (c_item
< 256)))
764 c_bv
[i
] = (scm_t_uint8
) c_item
;
775 scm_wrong_type_arg (FUNC_NAME
, 1, item
);
781 /* Compute the two's complement of VALUE (a positive integer) on SIZE octets
782 using (2^(SIZE * 8) - VALUE). */
784 twos_complement (mpz_t value
, size_t size
)
786 unsigned long bit_count
;
788 /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
789 checking on SIZE performed earlier. */
790 bit_count
= (unsigned long) size
<< 3UL;
792 if (SCM_LIKELY (bit_count
< sizeof (unsigned long)))
793 mpz_ui_sub (value
, 1UL << bit_count
, value
);
799 mpz_ui_pow_ui (max
, 2, bit_count
);
800 mpz_sub (value
, max
, value
);
806 bytevector_large_ref (const char *c_bv
, size_t c_size
, int signed_p
,
811 int c_endianness
, negative_p
= 0;
815 if (scm_is_eq (endianness
, scm_sym_big
))
816 negative_p
= c_bv
[0] & 0x80;
818 negative_p
= c_bv
[c_size
- 1] & 0x80;
821 c_endianness
= scm_is_eq (endianness
, scm_sym_big
) ? 1 : -1;
824 mpz_import (c_mpz
, 1 /* 1 word */, 1 /* word order doesn't matter */,
825 c_size
/* word is C_SIZE-byte long */,
827 0 /* nails */, c_bv
);
829 if (signed_p
&& negative_p
)
831 twos_complement (c_mpz
, c_size
);
832 mpz_neg (c_mpz
, c_mpz
);
835 result
= scm_from_mpz (c_mpz
);
836 mpz_clear (c_mpz
); /* FIXME: Needed? */
842 bytevector_large_set (char *c_bv
, size_t c_size
, int signed_p
,
843 SCM value
, SCM endianness
)
846 int c_endianness
, c_sign
, err
= 0;
848 c_endianness
= scm_is_eq (endianness
, scm_sym_big
) ? 1 : -1;
851 scm_to_mpz (value
, c_mpz
);
853 c_sign
= mpz_sgn (c_mpz
);
856 if (SCM_LIKELY (signed_p
))
858 mpz_neg (c_mpz
, c_mpz
);
859 twos_complement (c_mpz
, c_size
);
870 memset (c_bv
, 0, c_size
);
873 size_t word_count
, value_size
;
875 value_size
= (mpz_sizeinbase (c_mpz
, 2) + (8 * c_size
)) / (8 * c_size
);
876 if (SCM_UNLIKELY (value_size
> c_size
))
883 mpz_export (c_bv
, &word_count
, 1 /* word order doesn't matter */,
884 c_size
, c_endianness
,
885 0 /* nails */, c_mpz
);
886 if (SCM_UNLIKELY (word_count
!= 1))
887 /* Shouldn't happen since we already checked with VALUE_SIZE. */
897 #define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \
898 size_t c_len, c_index, c_size; \
901 SCM_VALIDATE_BYTEVECTOR (1, bv); \
902 c_index = scm_to_size_t (index); \
903 c_size = scm_to_size_t (size); \
905 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
906 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
908 /* C_SIZE must have its 3 higher bits set to zero so that \
909 multiplying it by 8 yields a number that fits in a \
911 if (SCM_UNLIKELY (c_size == 0 || c_size >= (SIZE_MAX >> 3))) \
912 scm_out_of_range (FUNC_NAME, size); \
913 if (SCM_UNLIKELY (c_index + c_size > c_len)) \
914 scm_out_of_range (FUNC_NAME, index);
917 /* Template of an integer reference function. */
918 #define GENERIC_INTEGER_REF(_sign) \
926 swap = !scm_is_eq (endianness, scm_i_native_endianness); \
931 _sign char c_value8; \
932 memcpy (&c_value8, c_bv, 1); \
938 INT_TYPE (16, _sign) c_value16; \
939 memcpy (&c_value16, c_bv, 2); \
941 value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \
950 result = SCM_I_MAKINUM ((_sign int) value); \
953 result = bytevector_large_ref ((char *) c_bv, \
954 c_size, SIGNEDNESS (_sign), \
960 bytevector_signed_ref (const char *c_bv
, size_t c_size
, SCM endianness
)
962 GENERIC_INTEGER_REF (signed);
966 bytevector_unsigned_ref (const char *c_bv
, size_t c_size
, SCM endianness
)
968 GENERIC_INTEGER_REF (unsigned);
972 /* Template of an integer assignment function. */
973 #define GENERIC_INTEGER_SET(_sign) \
976 scm_t_signed_bits c_value; \
978 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
981 c_value = SCM_I_INUM (value); \
985 if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \
987 _sign char c_value8; \
988 c_value8 = (_sign char) c_value; \
989 memcpy (c_bv, &c_value8, 1); \
996 if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \
999 INT_TYPE (16, _sign) c_value16; \
1001 swap = !scm_is_eq (endianness, scm_i_native_endianness); \
1004 c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \
1006 c_value16 = c_value; \
1008 memcpy (c_bv, &c_value16, 2); \
1022 err = bytevector_large_set (c_bv, c_size, \
1023 SIGNEDNESS (_sign), \
1024 value, endianness); \
1032 scm_out_of_range (FUNC_NAME, value); \
1036 bytevector_signed_set (char *c_bv
, size_t c_size
,
1037 SCM value
, SCM endianness
,
1038 const char *func_name
)
1039 #define FUNC_NAME func_name
1041 GENERIC_INTEGER_SET (signed);
1046 bytevector_unsigned_set (char *c_bv
, size_t c_size
,
1047 SCM value
, SCM endianness
,
1048 const char *func_name
)
1049 #define FUNC_NAME func_name
1051 GENERIC_INTEGER_SET (unsigned);
1055 #undef GENERIC_INTEGER_SET
1056 #undef GENERIC_INTEGER_REF
1059 SCM_DEFINE (scm_bytevector_uint_ref
, "bytevector-uint-ref", 4, 0, 0,
1060 (SCM bv
, SCM index
, SCM endianness
, SCM size
),
1061 "Return the @var{size}-octet long unsigned integer at index "
1062 "@var{index} in @var{bv}.")
1063 #define FUNC_NAME s_scm_bytevector_uint_ref
1065 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
1067 return (bytevector_unsigned_ref (&c_bv
[c_index
], c_size
, endianness
));
1071 SCM_DEFINE (scm_bytevector_sint_ref
, "bytevector-sint-ref", 4, 0, 0,
1072 (SCM bv
, SCM index
, SCM endianness
, SCM size
),
1073 "Return the @var{size}-octet long unsigned integer at index "
1074 "@var{index} in @var{bv}.")
1075 #define FUNC_NAME s_scm_bytevector_sint_ref
1077 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
1079 return (bytevector_signed_ref (&c_bv
[c_index
], c_size
, endianness
));
1083 SCM_DEFINE (scm_bytevector_uint_set_x
, "bytevector-uint-set!", 5, 0, 0,
1084 (SCM bv
, SCM index
, SCM value
, SCM endianness
, SCM size
),
1085 "Set the @var{size}-octet long unsigned integer at @var{index} "
1087 #define FUNC_NAME s_scm_bytevector_uint_set_x
1089 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
1091 bytevector_unsigned_set (&c_bv
[c_index
], c_size
, value
, endianness
,
1094 return SCM_UNSPECIFIED
;
1098 SCM_DEFINE (scm_bytevector_sint_set_x
, "bytevector-sint-set!", 5, 0, 0,
1099 (SCM bv
, SCM index
, SCM value
, SCM endianness
, SCM size
),
1100 "Set the @var{size}-octet long signed integer at @var{index} "
1102 #define FUNC_NAME s_scm_bytevector_sint_set_x
1104 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
1106 bytevector_signed_set (&c_bv
[c_index
], c_size
, value
, endianness
,
1109 return SCM_UNSPECIFIED
;
1115 /* Operations on integers of arbitrary size. */
1117 #define INTEGERS_TO_LIST(_sign) \
1119 size_t i, c_len, c_size; \
1121 SCM_VALIDATE_BYTEVECTOR (1, bv); \
1122 SCM_VALIDATE_SYMBOL (2, endianness); \
1123 c_size = scm_to_unsigned_integer (size, 1, (size_t) -1); \
1125 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
1126 if (SCM_UNLIKELY (c_len % c_size != 0)) \
1127 scm_wrong_type_arg_msg \
1128 (FUNC_NAME, 0, size, \
1129 "an exact positive integer that divides the bytevector length"); \
1130 else if (SCM_UNLIKELY (c_len == 0)) \
1136 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1138 lst = scm_make_list (scm_from_size_t (c_len / c_size), \
1140 for (i = 0, pair = lst; \
1141 i <= c_len - c_size; \
1142 i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
1145 bytevector_ ## _sign ## _ref (c_bv, c_size, \
1152 SCM_DEFINE (scm_bytevector_to_sint_list
, "bytevector->sint-list",
1154 (SCM bv
, SCM endianness
, SCM size
),
1155 "Return a list of signed integers of @var{size} octets "
1156 "representing the contents of @var{bv}.")
1157 #define FUNC_NAME s_scm_bytevector_to_sint_list
1159 INTEGERS_TO_LIST (signed);
1163 SCM_DEFINE (scm_bytevector_to_uint_list
, "bytevector->uint-list",
1165 (SCM bv
, SCM endianness
, SCM size
),
1166 "Return a list of unsigned integers of @var{size} octets "
1167 "representing the contents of @var{bv}.")
1168 #define FUNC_NAME s_scm_bytevector_to_uint_list
1170 INTEGERS_TO_LIST (unsigned);
1174 #undef INTEGER_TO_LIST
1177 #define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
1181 char *c_bv, *c_bv_ptr; \
1183 SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
1184 SCM_VALIDATE_SYMBOL (2, endianness); \
1185 c_size = scm_to_size_t (size); \
1187 if (SCM_UNLIKELY (c_size == 0 || c_size >= (SIZE_MAX >> 3))) \
1188 scm_out_of_range (FUNC_NAME, size); \
1190 bv = make_bytevector (c_len * c_size, SCM_ARRAY_ELEMENT_TYPE_VU8); \
1191 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1193 for (c_bv_ptr = c_bv; \
1194 !scm_is_null (lst); \
1195 lst = SCM_CDR (lst), c_bv_ptr += c_size) \
1197 bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
1198 SCM_CAR (lst), endianness, \
1205 SCM_DEFINE (scm_uint_list_to_bytevector
, "uint-list->bytevector",
1207 (SCM lst
, SCM endianness
, SCM size
),
1208 "Return a bytevector containing the unsigned integers "
1209 "listed in @var{lst} and encoded on @var{size} octets "
1210 "according to @var{endianness}.")
1211 #define FUNC_NAME s_scm_uint_list_to_bytevector
1213 INTEGER_LIST_TO_BYTEVECTOR (unsigned);
1217 SCM_DEFINE (scm_sint_list_to_bytevector
, "sint-list->bytevector",
1219 (SCM lst
, SCM endianness
, SCM size
),
1220 "Return a bytevector containing the signed integers "
1221 "listed in @var{lst} and encoded on @var{size} octets "
1222 "according to @var{endianness}.")
1223 #define FUNC_NAME s_scm_sint_list_to_bytevector
1225 INTEGER_LIST_TO_BYTEVECTOR (signed);
1229 #undef INTEGER_LIST_TO_BYTEVECTOR
1233 /* Operations on 16-bit integers. */
1235 SCM_DEFINE (scm_bytevector_u16_ref
, "bytevector-u16-ref",
1237 (SCM bv
, SCM index
, SCM endianness
),
1238 "Return the unsigned 16-bit integer from @var{bv} at "
1240 #define FUNC_NAME s_scm_bytevector_u16_ref
1242 INTEGER_REF (16, unsigned);
1246 SCM_DEFINE (scm_bytevector_s16_ref
, "bytevector-s16-ref",
1248 (SCM bv
, SCM index
, SCM endianness
),
1249 "Return the signed 16-bit integer from @var{bv} at "
1251 #define FUNC_NAME s_scm_bytevector_s16_ref
1253 INTEGER_REF (16, signed);
1257 SCM_DEFINE (scm_bytevector_u16_native_ref
, "bytevector-u16-native-ref",
1259 (SCM bv
, SCM index
),
1260 "Return the unsigned 16-bit integer from @var{bv} at "
1261 "@var{index} using the native endianness.")
1262 #define FUNC_NAME s_scm_bytevector_u16_native_ref
1264 INTEGER_NATIVE_REF (16, unsigned);
1268 SCM_DEFINE (scm_bytevector_s16_native_ref
, "bytevector-s16-native-ref",
1270 (SCM bv
, SCM index
),
1271 "Return the unsigned 16-bit integer from @var{bv} at "
1272 "@var{index} using the native endianness.")
1273 #define FUNC_NAME s_scm_bytevector_s16_native_ref
1275 INTEGER_NATIVE_REF (16, signed);
1279 SCM_DEFINE (scm_bytevector_u16_set_x
, "bytevector-u16-set!",
1281 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1282 "Store @var{value} in @var{bv} at @var{index} according to "
1283 "@var{endianness}.")
1284 #define FUNC_NAME s_scm_bytevector_u16_set_x
1286 INTEGER_SET (16, unsigned);
1290 SCM_DEFINE (scm_bytevector_s16_set_x
, "bytevector-s16-set!",
1292 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1293 "Store @var{value} in @var{bv} at @var{index} according to "
1294 "@var{endianness}.")
1295 #define FUNC_NAME s_scm_bytevector_s16_set_x
1297 INTEGER_SET (16, signed);
1301 SCM_DEFINE (scm_bytevector_u16_native_set_x
, "bytevector-u16-native-set!",
1303 (SCM bv
, SCM index
, SCM value
),
1304 "Store the unsigned integer @var{value} at index @var{index} "
1305 "of @var{bv} using the native endianness.")
1306 #define FUNC_NAME s_scm_bytevector_u16_native_set_x
1308 INTEGER_NATIVE_SET (16, unsigned);
1312 SCM_DEFINE (scm_bytevector_s16_native_set_x
, "bytevector-s16-native-set!",
1314 (SCM bv
, SCM index
, SCM value
),
1315 "Store the signed integer @var{value} at index @var{index} "
1316 "of @var{bv} using the native endianness.")
1317 #define FUNC_NAME s_scm_bytevector_s16_native_set_x
1319 INTEGER_NATIVE_SET (16, signed);
1325 /* Operations on 32-bit integers. */
1327 /* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
1328 arbitrary 32-bit integers. Thus we fall back to using the
1329 `large_{ref,set}' variants on 32-bit machines. */
1331 #define LARGE_INTEGER_REF(_len, _sign) \
1332 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1333 SCM_VALIDATE_SYMBOL (3, endianness); \
1335 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1336 SIGNEDNESS (_sign), endianness));
1338 #define LARGE_INTEGER_SET(_len, _sign) \
1340 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1341 SCM_VALIDATE_SYMBOL (4, endianness); \
1343 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1344 SIGNEDNESS (_sign), value, endianness); \
1345 if (SCM_UNLIKELY (err)) \
1346 scm_out_of_range (FUNC_NAME, value); \
1348 return SCM_UNSPECIFIED;
1350 #define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
1351 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1352 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1353 SIGNEDNESS (_sign), scm_i_native_endianness));
1355 #define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
1357 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1359 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1360 SIGNEDNESS (_sign), value, \
1361 scm_i_native_endianness); \
1362 if (SCM_UNLIKELY (err)) \
1363 scm_out_of_range (FUNC_NAME, value); \
1365 return SCM_UNSPECIFIED;
1368 SCM_DEFINE (scm_bytevector_u32_ref
, "bytevector-u32-ref",
1370 (SCM bv
, SCM index
, SCM endianness
),
1371 "Return the unsigned 32-bit integer from @var{bv} at "
1373 #define FUNC_NAME s_scm_bytevector_u32_ref
1375 #if SIZEOF_VOID_P > 4
1376 INTEGER_REF (32, unsigned);
1378 LARGE_INTEGER_REF (32, unsigned);
1383 SCM_DEFINE (scm_bytevector_s32_ref
, "bytevector-s32-ref",
1385 (SCM bv
, SCM index
, SCM endianness
),
1386 "Return the signed 32-bit integer from @var{bv} at "
1388 #define FUNC_NAME s_scm_bytevector_s32_ref
1390 #if SIZEOF_VOID_P > 4
1391 INTEGER_REF (32, signed);
1393 LARGE_INTEGER_REF (32, signed);
1398 SCM_DEFINE (scm_bytevector_u32_native_ref
, "bytevector-u32-native-ref",
1400 (SCM bv
, SCM index
),
1401 "Return the unsigned 32-bit integer from @var{bv} at "
1402 "@var{index} using the native endianness.")
1403 #define FUNC_NAME s_scm_bytevector_u32_native_ref
1405 #if SIZEOF_VOID_P > 4
1406 INTEGER_NATIVE_REF (32, unsigned);
1408 LARGE_INTEGER_NATIVE_REF (32, unsigned);
1413 SCM_DEFINE (scm_bytevector_s32_native_ref
, "bytevector-s32-native-ref",
1415 (SCM bv
, SCM index
),
1416 "Return the unsigned 32-bit integer from @var{bv} at "
1417 "@var{index} using the native endianness.")
1418 #define FUNC_NAME s_scm_bytevector_s32_native_ref
1420 #if SIZEOF_VOID_P > 4
1421 INTEGER_NATIVE_REF (32, signed);
1423 LARGE_INTEGER_NATIVE_REF (32, signed);
1428 SCM_DEFINE (scm_bytevector_u32_set_x
, "bytevector-u32-set!",
1430 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1431 "Store @var{value} in @var{bv} at @var{index} according to "
1432 "@var{endianness}.")
1433 #define FUNC_NAME s_scm_bytevector_u32_set_x
1435 #if SIZEOF_VOID_P > 4
1436 INTEGER_SET (32, unsigned);
1438 LARGE_INTEGER_SET (32, unsigned);
1443 SCM_DEFINE (scm_bytevector_s32_set_x
, "bytevector-s32-set!",
1445 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1446 "Store @var{value} in @var{bv} at @var{index} according to "
1447 "@var{endianness}.")
1448 #define FUNC_NAME s_scm_bytevector_s32_set_x
1450 #if SIZEOF_VOID_P > 4
1451 INTEGER_SET (32, signed);
1453 LARGE_INTEGER_SET (32, signed);
1458 SCM_DEFINE (scm_bytevector_u32_native_set_x
, "bytevector-u32-native-set!",
1460 (SCM bv
, SCM index
, SCM value
),
1461 "Store the unsigned integer @var{value} at index @var{index} "
1462 "of @var{bv} using the native endianness.")
1463 #define FUNC_NAME s_scm_bytevector_u32_native_set_x
1465 #if SIZEOF_VOID_P > 4
1466 INTEGER_NATIVE_SET (32, unsigned);
1468 LARGE_INTEGER_NATIVE_SET (32, unsigned);
1473 SCM_DEFINE (scm_bytevector_s32_native_set_x
, "bytevector-s32-native-set!",
1475 (SCM bv
, SCM index
, SCM value
),
1476 "Store the signed integer @var{value} at index @var{index} "
1477 "of @var{bv} using the native endianness.")
1478 #define FUNC_NAME s_scm_bytevector_s32_native_set_x
1480 #if SIZEOF_VOID_P > 4
1481 INTEGER_NATIVE_SET (32, signed);
1483 LARGE_INTEGER_NATIVE_SET (32, signed);
1490 /* Operations on 64-bit integers. */
1492 /* For 64-bit integers, we use only the `large_{ref,set}' variant. */
1494 SCM_DEFINE (scm_bytevector_u64_ref
, "bytevector-u64-ref",
1496 (SCM bv
, SCM index
, SCM endianness
),
1497 "Return the unsigned 64-bit integer from @var{bv} at "
1499 #define FUNC_NAME s_scm_bytevector_u64_ref
1501 LARGE_INTEGER_REF (64, unsigned);
1505 SCM_DEFINE (scm_bytevector_s64_ref
, "bytevector-s64-ref",
1507 (SCM bv
, SCM index
, SCM endianness
),
1508 "Return the signed 64-bit integer from @var{bv} at "
1510 #define FUNC_NAME s_scm_bytevector_s64_ref
1512 LARGE_INTEGER_REF (64, signed);
1516 SCM_DEFINE (scm_bytevector_u64_native_ref
, "bytevector-u64-native-ref",
1518 (SCM bv
, SCM index
),
1519 "Return the unsigned 64-bit integer from @var{bv} at "
1520 "@var{index} using the native endianness.")
1521 #define FUNC_NAME s_scm_bytevector_u64_native_ref
1523 LARGE_INTEGER_NATIVE_REF (64, unsigned);
1527 SCM_DEFINE (scm_bytevector_s64_native_ref
, "bytevector-s64-native-ref",
1529 (SCM bv
, SCM index
),
1530 "Return the unsigned 64-bit integer from @var{bv} at "
1531 "@var{index} using the native endianness.")
1532 #define FUNC_NAME s_scm_bytevector_s64_native_ref
1534 LARGE_INTEGER_NATIVE_REF (64, signed);
1538 SCM_DEFINE (scm_bytevector_u64_set_x
, "bytevector-u64-set!",
1540 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1541 "Store @var{value} in @var{bv} at @var{index} according to "
1542 "@var{endianness}.")
1543 #define FUNC_NAME s_scm_bytevector_u64_set_x
1545 LARGE_INTEGER_SET (64, unsigned);
1549 SCM_DEFINE (scm_bytevector_s64_set_x
, "bytevector-s64-set!",
1551 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1552 "Store @var{value} in @var{bv} at @var{index} according to "
1553 "@var{endianness}.")
1554 #define FUNC_NAME s_scm_bytevector_s64_set_x
1556 LARGE_INTEGER_SET (64, signed);
1560 SCM_DEFINE (scm_bytevector_u64_native_set_x
, "bytevector-u64-native-set!",
1562 (SCM bv
, SCM index
, SCM value
),
1563 "Store the unsigned integer @var{value} at index @var{index} "
1564 "of @var{bv} using the native endianness.")
1565 #define FUNC_NAME s_scm_bytevector_u64_native_set_x
1567 LARGE_INTEGER_NATIVE_SET (64, unsigned);
1571 SCM_DEFINE (scm_bytevector_s64_native_set_x
, "bytevector-s64-native-set!",
1573 (SCM bv
, SCM index
, SCM value
),
1574 "Store the signed integer @var{value} at index @var{index} "
1575 "of @var{bv} using the native endianness.")
1576 #define FUNC_NAME s_scm_bytevector_s64_native_set_x
1578 LARGE_INTEGER_NATIVE_SET (64, signed);
1584 /* Operations on IEEE-754 numbers. */
1586 /* There are two possible word endians, visible in glibc's <ieee754.h>.
1587 However, in R6RS, when the endianness is `little', little endian is
1588 assumed for both the byte order and the word order. This is clear from
1589 Section 2.1 of R6RS-lib (in response to
1590 http://www.r6rs.org/formal-comments/comment-187.txt). */
1592 union scm_ieee754_float
1598 union scm_ieee754_double
1605 /* Convert to/from a floating-point number with different endianness. This
1606 method is probably not the most efficient but it should be portable. */
1609 float_to_foreign_endianness (union scm_ieee754_float
*target
,
1612 union scm_ieee754_float input
;
1615 target
->i
= bswap_32 (input
.i
);
1619 float_from_foreign_endianness (const union scm_ieee754_float
*source
)
1621 union scm_ieee754_float result
;
1623 result
.i
= bswap_32 (source
->i
);
1629 double_to_foreign_endianness (union scm_ieee754_double
*target
,
1632 union scm_ieee754_double input
;
1635 target
->i
= bswap_64 (input
.i
);
1638 static inline double
1639 double_from_foreign_endianness (const union scm_ieee754_double
*source
)
1641 union scm_ieee754_double result
;
1643 result
.i
= bswap_64 (source
->i
);
1648 /* Template macros to abstract over doubles and floats.
1649 XXX: Guile can only convert to/from doubles. */
1650 #define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type
1651 #define IEEE754_TO_SCM(_c_type) scm_from_double
1652 #define IEEE754_FROM_SCM(_c_type) scm_to_double
1653 #define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
1654 _c_type ## _from_foreign_endianness
1655 #define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
1656 _c_type ## _to_foreign_endianness
1659 /* FIXME: SCM_VALIDATE_REAL rejects integers, etc. grrr */
1660 #define VALIDATE_REAL(pos, v) \
1662 SCM_ASSERT_TYPE (scm_is_real (v), v, pos, FUNC_NAME, "real"); \
1665 /* Templace getters and setters. */
1667 #define IEEE754_ACCESSOR_PROLOGUE(_type) \
1668 INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
1670 #define IEEE754_REF(_type) \
1673 IEEE754_ACCESSOR_PROLOGUE (_type); \
1674 SCM_VALIDATE_SYMBOL (3, endianness); \
1676 if (scm_is_eq (endianness, scm_i_native_endianness)) \
1677 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1680 IEEE754_UNION (_type) c_raw; \
1682 memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
1684 IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
1687 return (IEEE754_TO_SCM (_type) (c_result));
1689 #define IEEE754_NATIVE_REF(_type) \
1692 IEEE754_ACCESSOR_PROLOGUE (_type); \
1694 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1695 return (IEEE754_TO_SCM (_type) (c_result));
1697 #define IEEE754_SET(_type) \
1700 IEEE754_ACCESSOR_PROLOGUE (_type); \
1701 VALIDATE_REAL (3, value); \
1702 SCM_VALIDATE_SYMBOL (4, endianness); \
1703 c_value = IEEE754_FROM_SCM (_type) (value); \
1705 if (scm_is_eq (endianness, scm_i_native_endianness)) \
1706 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1709 IEEE754_UNION (_type) c_raw; \
1711 IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
1712 memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
1715 return SCM_UNSPECIFIED;
1717 #define IEEE754_NATIVE_SET(_type) \
1720 IEEE754_ACCESSOR_PROLOGUE (_type); \
1721 VALIDATE_REAL (3, value); \
1722 c_value = IEEE754_FROM_SCM (_type) (value); \
1724 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1725 return SCM_UNSPECIFIED;
1728 /* Single precision. */
1730 SCM_DEFINE (scm_bytevector_ieee_single_ref
,
1731 "bytevector-ieee-single-ref",
1733 (SCM bv
, SCM index
, SCM endianness
),
1734 "Return the IEEE-754 single from @var{bv} at "
1736 #define FUNC_NAME s_scm_bytevector_ieee_single_ref
1738 IEEE754_REF (float);
1742 SCM_DEFINE (scm_bytevector_ieee_single_native_ref
,
1743 "bytevector-ieee-single-native-ref",
1745 (SCM bv
, SCM index
),
1746 "Return the IEEE-754 single from @var{bv} at "
1747 "@var{index} using the native endianness.")
1748 #define FUNC_NAME s_scm_bytevector_ieee_single_native_ref
1750 IEEE754_NATIVE_REF (float);
1754 SCM_DEFINE (scm_bytevector_ieee_single_set_x
,
1755 "bytevector-ieee-single-set!",
1757 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1758 "Store real @var{value} in @var{bv} at @var{index} according to "
1759 "@var{endianness}.")
1760 #define FUNC_NAME s_scm_bytevector_ieee_single_set_x
1762 IEEE754_SET (float);
1766 SCM_DEFINE (scm_bytevector_ieee_single_native_set_x
,
1767 "bytevector-ieee-single-native-set!",
1769 (SCM bv
, SCM index
, SCM value
),
1770 "Store the real @var{value} at index @var{index} "
1771 "of @var{bv} using the native endianness.")
1772 #define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x
1774 IEEE754_NATIVE_SET (float);
1779 /* Double precision. */
1781 SCM_DEFINE (scm_bytevector_ieee_double_ref
,
1782 "bytevector-ieee-double-ref",
1784 (SCM bv
, SCM index
, SCM endianness
),
1785 "Return the IEEE-754 double from @var{bv} at "
1787 #define FUNC_NAME s_scm_bytevector_ieee_double_ref
1789 IEEE754_REF (double);
1793 SCM_DEFINE (scm_bytevector_ieee_double_native_ref
,
1794 "bytevector-ieee-double-native-ref",
1796 (SCM bv
, SCM index
),
1797 "Return the IEEE-754 double from @var{bv} at "
1798 "@var{index} using the native endianness.")
1799 #define FUNC_NAME s_scm_bytevector_ieee_double_native_ref
1801 IEEE754_NATIVE_REF (double);
1805 SCM_DEFINE (scm_bytevector_ieee_double_set_x
,
1806 "bytevector-ieee-double-set!",
1808 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1809 "Store real @var{value} in @var{bv} at @var{index} according to "
1810 "@var{endianness}.")
1811 #define FUNC_NAME s_scm_bytevector_ieee_double_set_x
1813 IEEE754_SET (double);
1817 SCM_DEFINE (scm_bytevector_ieee_double_native_set_x
,
1818 "bytevector-ieee-double-native-set!",
1820 (SCM bv
, SCM index
, SCM value
),
1821 "Store the real @var{value} at index @var{index} "
1822 "of @var{bv} using the native endianness.")
1823 #define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x
1825 IEEE754_NATIVE_SET (double);
1830 #undef IEEE754_UNION
1831 #undef IEEE754_TO_SCM
1832 #undef IEEE754_FROM_SCM
1833 #undef IEEE754_FROM_FOREIGN_ENDIANNESS
1834 #undef IEEE754_TO_FOREIGN_ENDIANNESS
1836 #undef IEEE754_NATIVE_REF
1838 #undef IEEE754_NATIVE_SET
1841 /* Operations on strings. */
1844 /* Produce a function that returns the length of a UTF-encoded string. */
1845 #define UTF_STRLEN_FUNCTION(_utf_width) \
1846 static inline size_t \
1847 utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
1850 const uint ## _utf_width ## _t *ptr; \
1858 return (len * ((_utf_width) / 8)); \
1861 UTF_STRLEN_FUNCTION (8)
1864 /* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
1865 #define UTF_STRLEN(_utf_width, _str) \
1866 utf ## _utf_width ## _strlen (_str)
1868 /* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
1869 ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
1872 utf_encoding_name (char *name
, size_t utf_width
, SCM endianness
)
1874 strcpy (name
, "UTF-");
1875 strcat (name
, ((utf_width
== 8)
1877 : ((utf_width
== 16)
1879 : ((utf_width
== 32)
1883 ((scm_is_eq (endianness
, scm_sym_big
))
1885 : ((scm_is_eq (endianness
, scm_sym_little
))
1890 /* Maximum length of a UTF encoding name. */
1891 #define MAX_UTF_ENCODING_NAME_LEN 16
1893 /* Produce the body of a `string->utf' function. */
1894 #define STRING_TO_UTF(_utf_width) \
1897 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1898 char *c_utf = NULL; \
1899 size_t c_strlen, c_utf_len = 0; \
1901 SCM_VALIDATE_STRING (1, str); \
1902 if (scm_is_eq (endianness, SCM_UNDEFINED)) \
1903 endianness = scm_sym_big; \
1905 SCM_VALIDATE_SYMBOL (2, endianness); \
1907 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1909 c_strlen = scm_i_string_length (str); \
1910 if (scm_i_is_narrow_string (str)) \
1912 err = mem_iconveh (scm_i_string_chars (str), c_strlen, \
1913 "ISO-8859-1", c_utf_name, \
1914 iconveh_question_mark, NULL, \
1915 &c_utf, &c_utf_len); \
1916 if (SCM_UNLIKELY (err)) \
1917 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1918 scm_list_1 (str), err); \
1922 const scm_t_wchar *wbuf = scm_i_string_wide_chars (str); \
1923 c_utf = u32_conv_to_encoding (c_utf_name, \
1924 iconveh_question_mark, \
1925 (scm_t_uint32 *) wbuf, \
1926 c_strlen, NULL, NULL, &c_utf_len); \
1927 if (SCM_UNLIKELY (c_utf == NULL)) \
1928 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1929 scm_list_1 (str), errno); \
1931 scm_dynwind_begin (0); \
1932 scm_dynwind_free (c_utf); \
1933 utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8); \
1934 memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len); \
1935 scm_dynwind_end (); \
1941 SCM_DEFINE (scm_string_to_utf8
, "string->utf8",
1944 "Return a newly allocated bytevector that contains the UTF-8 "
1945 "encoding of @var{str}.")
1946 #define FUNC_NAME s_scm_string_to_utf8
1950 size_t c_utf_len
= 0;
1952 SCM_VALIDATE_STRING (1, str
);
1954 c_utf
= (scm_t_uint8
*) scm_to_utf8_stringn (str
, &c_utf_len
);
1955 utf
= make_bytevector (c_utf_len
, SCM_ARRAY_ELEMENT_TYPE_VU8
);
1956 memcpy (SCM_BYTEVECTOR_CONTENTS (utf
), c_utf
, c_utf_len
);
1963 SCM_DEFINE (scm_string_to_utf16
, "string->utf16",
1965 (SCM str
, SCM endianness
),
1966 "Return a newly allocated bytevector that contains the UTF-16 "
1967 "encoding of @var{str}.")
1968 #define FUNC_NAME s_scm_string_to_utf16
1975 swap_u32 (scm_t_wchar
*vals
, size_t len
)
1978 for (n
= 0; n
< len
; n
++)
1979 vals
[n
] = bswap_32 (vals
[n
]);
1982 SCM_DEFINE (scm_string_to_utf32
, "string->utf32",
1984 (SCM str
, SCM endianness
),
1985 "Return a newly allocated bytevector that contains the UTF-32 "
1986 "encoding of @var{str}.")
1987 #define FUNC_NAME s_scm_string_to_utf32
1990 scm_t_wchar
*wchars
;
1991 size_t wchar_len
, bytes_len
;
1993 wchars
= scm_to_utf32_stringn (str
, &wchar_len
);
1994 bytes_len
= wchar_len
* sizeof (scm_t_wchar
);
1995 if (!scm_is_eq (SCM_UNBNDP (endianness
) ? scm_endianness_big
: endianness
,
1996 scm_i_native_endianness
))
1997 swap_u32 (wchars
, wchar_len
);
1999 bv
= make_bytevector (bytes_len
, SCM_ARRAY_ELEMENT_TYPE_VU8
);
2000 memcpy (SCM_BYTEVECTOR_CONTENTS (bv
), wchars
, bytes_len
);
2008 /* Produce the body of a function that converts a UTF-encoded bytevector to a
2010 #define UTF_TO_STRING(_utf_width) \
2011 SCM str = SCM_BOOL_F; \
2013 char *c_str = NULL; \
2014 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
2016 size_t c_strlen = 0, c_utf_len = 0; \
2018 SCM_VALIDATE_BYTEVECTOR (1, utf); \
2019 if (scm_is_eq (endianness, SCM_UNDEFINED)) \
2020 endianness = scm_sym_big; \
2022 SCM_VALIDATE_SYMBOL (2, endianness); \
2024 c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \
2025 c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
2026 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
2028 err = mem_iconveh (c_utf, c_utf_len, \
2029 c_utf_name, "UTF-8", \
2030 iconveh_question_mark, NULL, \
2031 &c_str, &c_strlen); \
2032 if (SCM_UNLIKELY (err)) \
2033 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
2034 scm_list_1 (utf), err); \
2037 str = scm_from_utf8_stringn (c_str, c_strlen); \
2043 SCM_DEFINE (scm_utf8_to_string
, "utf8->string",
2046 "Return a newly allocate string that contains from the UTF-8-"
2047 "encoded contents of bytevector @var{utf}.")
2048 #define FUNC_NAME s_scm_utf8_to_string
2052 size_t c_utf_len
= 0;
2054 SCM_VALIDATE_BYTEVECTOR (1, utf
);
2056 c_utf_len
= SCM_BYTEVECTOR_LENGTH (utf
);
2057 c_utf
= (char *) SCM_BYTEVECTOR_CONTENTS (utf
);
2058 str
= scm_from_utf8_stringn (c_utf
, c_utf_len
);
2064 SCM_DEFINE (scm_utf16_to_string
, "utf16->string",
2066 (SCM utf
, SCM endianness
),
2067 "Return a newly allocate string that contains from the UTF-16-"
2068 "encoded contents of bytevector @var{utf}.")
2069 #define FUNC_NAME s_scm_utf16_to_string
2075 SCM_DEFINE (scm_utf32_to_string
, "utf32->string",
2077 (SCM utf
, SCM endianness
),
2078 "Return a newly allocate string that contains from the UTF-32-"
2079 "encoded contents of bytevector @var{utf}.")
2080 #define FUNC_NAME s_scm_utf32_to_string
2087 /* Initialization. */
2090 scm_bootstrap_bytevectors (void)
2092 /* This must be instantiated here because the generalized-vector API may
2093 want to access bytevectors even though `(rnrs bytevectors)' hasn't been
2095 scm_null_bytevector
= make_bytevector (0, SCM_ARRAY_ELEMENT_TYPE_VU8
);
2097 #ifdef WORDS_BIGENDIAN
2098 scm_i_native_endianness
= scm_from_latin1_symbol ("big");
2100 scm_i_native_endianness
= scm_from_latin1_symbol ("little");
2103 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
2104 "scm_init_bytevectors",
2105 (scm_t_extension_init_func
) scm_init_bytevectors
,
2108 scm_i_register_vector_constructor
2109 (scm_i_array_element_types
[SCM_ARRAY_ELEMENT_TYPE_VU8
],
2110 scm_make_bytevector
);
2114 scm_init_bytevectors (void)
2116 #include "libguile/bytevectors.x"
2118 scm_endianness_big
= scm_sym_big
;
2119 scm_endianness_little
= scm_sym_little
;