1 /* Copyright (C) 2009, 2010, 2011 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/ieee-754.h"
35 #include "libguile/arrays.h"
36 #include "libguile/array-handle.h"
37 #include "libguile/uniform.h"
38 #include "libguile/srfi-4.h"
41 #include <striconveh.h>
48 /* Assuming 32-bit longs. */
49 # define ULONG_MAX 4294967295UL
58 /* Convenience macros. These are used by the various templates (macros) that
59 are parameterized by integer signedness. */
60 #define INT8_T_signed scm_t_int8
61 #define INT8_T_unsigned scm_t_uint8
62 #define INT16_T_signed scm_t_int16
63 #define INT16_T_unsigned scm_t_uint16
64 #define INT32_T_signed scm_t_int32
65 #define INT32_T_unsigned scm_t_uint32
66 #define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L))
67 #define is_unsigned_int8(_x) ((_x) <= 255UL)
68 #define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
69 #define is_unsigned_int16(_x) ((_x) <= 65535UL)
70 #define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L))
71 #define is_unsigned_int32(_x) ((_x) <= 4294967295UL)
72 #define SIGNEDNESS_signed 1
73 #define SIGNEDNESS_unsigned 0
75 #define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign
76 #define INT_SWAP(_size) bswap_ ## _size
77 #define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
78 #define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
81 #define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \
82 size_t c_len, c_index; \
85 SCM_VALIDATE_BYTEVECTOR (1, bv); \
86 c_index = scm_to_uint (index); \
88 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
89 c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \
91 if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
92 scm_out_of_range (FUNC_NAME, index);
94 /* Template for fixed-size integer access (only 8, 16 or 32-bit). */
95 #define INTEGER_REF(_len, _sign) \
98 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
99 SCM_VALIDATE_SYMBOL (3, endianness); \
102 INT_TYPE (_len, _sign) c_result; \
104 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
105 if (!scm_is_eq (endianness, scm_i_native_endianness)) \
106 c_result = INT_SWAP (_len) (c_result); \
108 result = SCM_I_MAKINUM (c_result); \
113 /* Template for fixed-size integer access using the native endianness. */
114 #define INTEGER_NATIVE_REF(_len, _sign) \
117 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
120 INT_TYPE (_len, _sign) c_result; \
122 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
123 result = SCM_I_MAKINUM (c_result); \
128 /* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
129 #define INTEGER_SET(_len, _sign) \
130 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
131 SCM_VALIDATE_SYMBOL (3, endianness); \
134 scm_t_signed_bits c_value; \
135 INT_TYPE (_len, _sign) c_value_short; \
137 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
138 scm_wrong_type_arg (FUNC_NAME, 3, value); \
140 c_value = SCM_I_INUM (value); \
141 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
142 scm_out_of_range (FUNC_NAME, value); \
144 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
145 if (!scm_is_eq (endianness, scm_i_native_endianness)) \
146 c_value_short = INT_SWAP (_len) (c_value_short); \
148 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
151 return SCM_UNSPECIFIED;
153 /* Template for fixed-size integer modification using the native
155 #define INTEGER_NATIVE_SET(_len, _sign) \
156 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
159 scm_t_signed_bits c_value; \
160 INT_TYPE (_len, _sign) c_value_short; \
162 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
163 scm_wrong_type_arg (FUNC_NAME, 3, value); \
165 c_value = SCM_I_INUM (value); \
166 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
167 scm_out_of_range (FUNC_NAME, value); \
169 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
171 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
174 return SCM_UNSPECIFIED;
178 /* Bytevector type. */
180 #define SCM_BYTEVECTOR_HEADER_BYTES \
181 (SCM_BYTEVECTOR_HEADER_SIZE * sizeof (SCM))
183 #define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
184 SCM_SET_CELL_WORD_1 ((_bv), (scm_t_bits) (_len))
185 #define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _contents) \
186 SCM_SET_CELL_WORD_2 ((_bv), (scm_t_bits) (_contents))
187 #define SCM_BYTEVECTOR_SET_CONTIGUOUS_P(bv, contiguous_p) \
188 SCM_SET_BYTEVECTOR_FLAGS ((bv), \
189 SCM_BYTEVECTOR_ELEMENT_TYPE (bv) \
190 | ((contiguous_p) << 8UL))
192 #define SCM_BYTEVECTOR_SET_ELEMENT_TYPE(bv, hint) \
193 SCM_SET_BYTEVECTOR_FLAGS ((bv), \
195 | (SCM_BYTEVECTOR_CONTIGUOUS_P (bv) << 8UL))
196 #define SCM_BYTEVECTOR_TYPE_SIZE(var) \
197 (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
198 #define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
199 (SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var))
201 /* The empty bytevector. */
202 SCM scm_null_bytevector
= SCM_UNSPECIFIED
;
206 make_bytevector (size_t len
, scm_t_array_element_type element_type
)
211 if (SCM_UNLIKELY (element_type
> SCM_ARRAY_ELEMENT_TYPE_LAST
212 || scm_i_array_element_type_sizes
[element_type
] < 8
213 || len
>= (SCM_I_SIZE_MAX
214 / (scm_i_array_element_type_sizes
[element_type
]/8))))
215 /* This would be an internal Guile programming error */
218 if (SCM_UNLIKELY (len
== 0 && element_type
== SCM_ARRAY_ELEMENT_TYPE_VU8
219 && SCM_BYTEVECTOR_P (scm_null_bytevector
)))
220 ret
= scm_null_bytevector
;
223 signed char *contents
;
225 c_len
= len
* (scm_i_array_element_type_sizes
[element_type
] / 8);
227 contents
= scm_gc_malloc_pointerless (SCM_BYTEVECTOR_HEADER_BYTES
+ c_len
,
229 ret
= PTR2SCM (contents
);
230 contents
+= SCM_BYTEVECTOR_HEADER_BYTES
;
232 SCM_BYTEVECTOR_SET_LENGTH (ret
, c_len
);
233 SCM_BYTEVECTOR_SET_CONTENTS (ret
, contents
);
234 SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret
, 1);
235 SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret
, element_type
);
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
= PTR2SCM (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
);
271 /* Return a new bytevector of size LEN octets. */
273 scm_c_make_bytevector (size_t len
)
275 return make_bytevector (len
, SCM_ARRAY_ELEMENT_TYPE_VU8
);
278 /* Return a new bytevector of size LEN elements. */
280 scm_i_make_typed_bytevector (size_t len
, scm_t_array_element_type element_type
)
282 return make_bytevector (len
, element_type
);
285 /* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
286 by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
288 scm_c_take_bytevector (signed char *contents
, size_t len
)
290 return make_bytevector_from_buffer (len
, contents
, SCM_ARRAY_ELEMENT_TYPE_VU8
);
294 scm_c_take_typed_bytevector (signed char *contents
, size_t len
,
295 scm_t_array_element_type element_type
)
297 return make_bytevector_from_buffer (len
, contents
, element_type
);
300 /* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
301 size) and return the new bytevector (possibly different from BV). */
303 scm_c_shrink_bytevector (SCM bv
, size_t c_new_len
)
308 if (SCM_UNLIKELY (c_new_len
% SCM_BYTEVECTOR_TYPE_SIZE (bv
)))
309 /* This would be an internal Guile programming error */
312 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
313 if (SCM_UNLIKELY (c_new_len
> c_len
))
316 SCM_BYTEVECTOR_SET_LENGTH (bv
, c_new_len
);
318 if (SCM_BYTEVECTOR_CONTIGUOUS_P (bv
))
319 new_bv
= PTR2SCM (scm_gc_realloc (SCM2PTR (bv
),
320 c_len
+ SCM_BYTEVECTOR_HEADER_BYTES
,
321 c_new_len
+ SCM_BYTEVECTOR_HEADER_BYTES
,
327 c_bv
= scm_gc_realloc (SCM_BYTEVECTOR_CONTENTS (bv
),
328 c_len
, c_new_len
, SCM_GC_BYTEVECTOR
);
329 SCM_BYTEVECTOR_SET_CONTENTS (bv
, c_bv
);
338 scm_is_bytevector (SCM obj
)
340 return SCM_BYTEVECTOR_P (obj
);
344 scm_c_bytevector_length (SCM bv
)
345 #define FUNC_NAME "scm_c_bytevector_length"
347 SCM_VALIDATE_BYTEVECTOR (1, bv
);
349 return SCM_BYTEVECTOR_LENGTH (bv
);
354 scm_c_bytevector_ref (SCM bv
, size_t index
)
355 #define FUNC_NAME "scm_c_bytevector_ref"
358 const scm_t_uint8
*c_bv
;
360 SCM_VALIDATE_BYTEVECTOR (1, bv
);
362 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
363 c_bv
= (scm_t_uint8
*) SCM_BYTEVECTOR_CONTENTS (bv
);
365 if (SCM_UNLIKELY (index
>= c_len
))
366 scm_out_of_range (FUNC_NAME
, scm_from_size_t (index
));
373 scm_c_bytevector_set_x (SCM bv
, size_t index
, scm_t_uint8 value
)
374 #define FUNC_NAME "scm_c_bytevector_set_x"
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
));
394 scm_i_print_bytevector (SCM bv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
396 ssize_t ubnd
, inc
, i
;
397 scm_t_array_handle h
;
399 scm_array_get_handle (bv
, &h
);
401 scm_putc ('#', port
);
402 scm_write (scm_array_handle_element_type (&h
), port
);
403 scm_putc ('(', port
);
404 for (i
= h
.dims
[0].lbnd
, ubnd
= h
.dims
[0].ubnd
, inc
= h
.dims
[0].inc
;
408 scm_putc (' ', port
);
409 scm_write (scm_array_handle_ref (&h
, i
), port
);
411 scm_putc (')', port
);
417 /* General operations. */
419 SCM_SYMBOL (scm_sym_big
, "big");
420 SCM_SYMBOL (scm_sym_little
, "little");
422 SCM scm_endianness_big
, scm_endianness_little
;
424 /* Host endianness (a symbol). */
425 SCM scm_i_native_endianness
= SCM_UNSPECIFIED
;
429 # define bswap_24(_x) \
430 ((((_x) & 0xff0000) >> 16) | \
431 (((_x) & 0x00ff00)) | \
432 (((_x) & 0x0000ff) << 16))
436 SCM_DEFINE (scm_native_endianness
, "native-endianness", 0, 0, 0,
438 "Return a symbol denoting the machine's native endianness.")
439 #define FUNC_NAME s_scm_native_endianness
441 return scm_i_native_endianness
;
445 SCM_DEFINE (scm_bytevector_p
, "bytevector?", 1, 0, 0,
447 "Return true if @var{obj} is a bytevector.")
448 #define FUNC_NAME s_scm_bytevector_p
450 return scm_from_bool (scm_is_bytevector (obj
));
454 SCM_DEFINE (scm_make_bytevector
, "make-bytevector", 1, 1, 0,
456 "Return a newly allocated bytevector of @var{len} bytes, "
457 "optionally filled with @var{fill}.")
458 #define FUNC_NAME s_scm_make_bytevector
462 signed char c_fill
= '\0';
464 SCM_VALIDATE_UINT_COPY (1, len
, c_len
);
465 if (!scm_is_eq (fill
, SCM_UNDEFINED
))
469 value
= scm_to_int (fill
);
470 if (SCM_UNLIKELY ((value
< -128) || (value
> 255)))
471 scm_out_of_range (FUNC_NAME
, fill
);
472 c_fill
= (signed char) value
;
475 bv
= make_bytevector (c_len
, SCM_ARRAY_ELEMENT_TYPE_VU8
);
476 if (!scm_is_eq (fill
, SCM_UNDEFINED
))
479 signed char *contents
;
481 contents
= SCM_BYTEVECTOR_CONTENTS (bv
);
482 for (i
= 0; i
< c_len
; i
++)
483 contents
[i
] = c_fill
;
486 memset (SCM_BYTEVECTOR_CONTENTS (bv
), 0, c_len
);
492 SCM_DEFINE (scm_bytevector_length
, "bytevector-length", 1, 0, 0,
494 "Return the length (in bytes) of @var{bv}.")
495 #define FUNC_NAME s_scm_bytevector_length
497 return scm_from_uint (scm_c_bytevector_length (bv
));
501 SCM_DEFINE (scm_bytevector_eq_p
, "bytevector=?", 2, 0, 0,
503 "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
504 "have the same length and contents.")
505 #define FUNC_NAME s_scm_bytevector_eq_p
507 SCM result
= SCM_BOOL_F
;
508 unsigned c_len1
, c_len2
;
510 SCM_VALIDATE_BYTEVECTOR (1, bv1
);
511 SCM_VALIDATE_BYTEVECTOR (2, bv2
);
513 c_len1
= SCM_BYTEVECTOR_LENGTH (bv1
);
514 c_len2
= SCM_BYTEVECTOR_LENGTH (bv2
);
516 if (c_len1
== c_len2
&& (SCM_BYTEVECTOR_ELEMENT_TYPE (bv1
)
517 == SCM_BYTEVECTOR_ELEMENT_TYPE (bv2
)))
519 signed char *c_bv1
, *c_bv2
;
521 c_bv1
= SCM_BYTEVECTOR_CONTENTS (bv1
);
522 c_bv2
= SCM_BYTEVECTOR_CONTENTS (bv2
);
524 result
= scm_from_bool (!memcmp (c_bv1
, c_bv2
, c_len1
));
531 SCM_DEFINE (scm_bytevector_fill_x
, "bytevector-fill!", 2, 0, 0,
533 "Fill bytevector @var{bv} with @var{fill}, a byte.")
534 #define FUNC_NAME s_scm_bytevector_fill_x
537 signed char *c_bv
, c_fill
;
539 SCM_VALIDATE_BYTEVECTOR (1, bv
);
540 c_fill
= scm_to_int8 (fill
);
542 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
543 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
545 for (i
= 0; i
< c_len
; i
++)
548 return SCM_UNSPECIFIED
;
552 SCM_DEFINE (scm_bytevector_copy_x
, "bytevector-copy!", 5, 0, 0,
553 (SCM source
, SCM source_start
, SCM target
, SCM target_start
,
555 "Copy @var{len} bytes from @var{source} into @var{target}, "
556 "starting reading from @var{source_start} (a positive index "
557 "within @var{source}) and start writing at "
558 "@var{target_start}.")
559 #define FUNC_NAME s_scm_bytevector_copy_x
561 unsigned c_len
, c_source_len
, c_target_len
;
562 unsigned c_source_start
, c_target_start
;
563 signed char *c_source
, *c_target
;
565 SCM_VALIDATE_BYTEVECTOR (1, source
);
566 SCM_VALIDATE_BYTEVECTOR (3, target
);
568 c_len
= scm_to_uint (len
);
569 c_source_start
= scm_to_uint (source_start
);
570 c_target_start
= scm_to_uint (target_start
);
572 c_source
= SCM_BYTEVECTOR_CONTENTS (source
);
573 c_target
= SCM_BYTEVECTOR_CONTENTS (target
);
574 c_source_len
= SCM_BYTEVECTOR_LENGTH (source
);
575 c_target_len
= SCM_BYTEVECTOR_LENGTH (target
);
577 if (SCM_UNLIKELY (c_source_start
+ c_len
> c_source_len
))
578 scm_out_of_range (FUNC_NAME
, source_start
);
579 if (SCM_UNLIKELY (c_target_start
+ c_len
> c_target_len
))
580 scm_out_of_range (FUNC_NAME
, target_start
);
582 memcpy (c_target
+ c_target_start
,
583 c_source
+ c_source_start
,
586 return SCM_UNSPECIFIED
;
590 SCM_DEFINE (scm_bytevector_copy
, "bytevector-copy", 1, 0, 0,
592 "Return a newly allocated copy of @var{bv}.")
593 #define FUNC_NAME s_scm_bytevector_copy
597 signed char *c_bv
, *c_copy
;
599 SCM_VALIDATE_BYTEVECTOR (1, bv
);
601 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
602 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
604 copy
= make_bytevector (c_len
, SCM_BYTEVECTOR_ELEMENT_TYPE (bv
));
605 c_copy
= SCM_BYTEVECTOR_CONTENTS (copy
);
606 memcpy (c_copy
, c_bv
, c_len
);
612 SCM_DEFINE (scm_uniform_array_to_bytevector
, "uniform-array->bytevector",
613 1, 0, 0, (SCM array
),
614 "Return a newly allocated bytevector whose contents\n"
615 "will be copied from the uniform array @var{array}.")
616 #define FUNC_NAME s_scm_uniform_array_to_bytevector
619 size_t len
, sz
, byte_len
;
620 scm_t_array_handle h
;
623 contents
= scm_array_contents (array
, SCM_BOOL_T
);
624 if (scm_is_false (contents
))
625 scm_wrong_type_arg_msg (FUNC_NAME
, 0, array
, "uniform contiguous array");
627 scm_array_get_handle (contents
, &h
);
628 assert (h
.base
== 0);
631 len
= h
.dims
->inc
* (h
.dims
->ubnd
- h
.dims
->lbnd
+ 1);
632 sz
= scm_array_handle_uniform_element_bit_size (&h
);
633 if (sz
>= 8 && ((sz
% 8) == 0))
634 byte_len
= len
* (sz
/ 8);
636 /* byte_len = ceil (len * sz / 8) */
637 byte_len
= (len
* sz
+ 7) / 8;
639 /* an internal guile error, really */
640 SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL
);
642 ret
= make_bytevector (byte_len
, SCM_ARRAY_ELEMENT_TYPE_VU8
);
643 memcpy (SCM_BYTEVECTOR_CONTENTS (ret
), elts
, byte_len
);
645 scm_array_handle_release (&h
);
652 /* Operations on bytes and octets. */
654 SCM_DEFINE (scm_bytevector_u8_ref
, "bytevector-u8-ref", 2, 0, 0,
656 "Return the octet located at @var{index} in @var{bv}.")
657 #define FUNC_NAME s_scm_bytevector_u8_ref
659 INTEGER_NATIVE_REF (8, unsigned);
663 SCM_DEFINE (scm_bytevector_s8_ref
, "bytevector-s8-ref", 2, 0, 0,
665 "Return the byte located at @var{index} in @var{bv}.")
666 #define FUNC_NAME s_scm_bytevector_s8_ref
668 INTEGER_NATIVE_REF (8, signed);
672 SCM_DEFINE (scm_bytevector_u8_set_x
, "bytevector-u8-set!", 3, 0, 0,
673 (SCM bv
, SCM index
, SCM value
),
674 "Return the octet located at @var{index} in @var{bv}.")
675 #define FUNC_NAME s_scm_bytevector_u8_set_x
677 INTEGER_NATIVE_SET (8, unsigned);
681 SCM_DEFINE (scm_bytevector_s8_set_x
, "bytevector-s8-set!", 3, 0, 0,
682 (SCM bv
, SCM index
, SCM value
),
683 "Return the octet located at @var{index} in @var{bv}.")
684 #define FUNC_NAME s_scm_bytevector_s8_set_x
686 INTEGER_NATIVE_SET (8, signed);
690 #undef OCTET_ACCESSOR_PROLOGUE
693 SCM_DEFINE (scm_bytevector_to_u8_list
, "bytevector->u8-list", 1, 0, 0,
695 "Return a newly allocated list of octets containing the "
696 "contents of @var{bv}.")
697 #define FUNC_NAME s_scm_bytevector_to_u8_list
703 SCM_VALIDATE_BYTEVECTOR (1, bv
);
705 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
706 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
708 lst
= scm_make_list (scm_from_uint (c_len
), SCM_UNSPECIFIED
);
709 for (i
= 0, pair
= lst
;
711 i
++, pair
= SCM_CDR (pair
))
713 SCM_SETCAR (pair
, SCM_I_MAKINUM (c_bv
[i
]));
720 SCM_DEFINE (scm_u8_list_to_bytevector
, "u8-list->bytevector", 1, 0, 0,
722 "Turn @var{lst}, a list of octets, into a bytevector.")
723 #define FUNC_NAME s_scm_u8_list_to_bytevector
729 SCM_VALIDATE_LIST_COPYLEN (1, lst
, c_len
);
731 bv
= make_bytevector (c_len
, SCM_ARRAY_ELEMENT_TYPE_VU8
);
732 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
734 for (i
= 0; i
< c_len
; lst
= SCM_CDR (lst
), i
++)
736 item
= SCM_CAR (lst
);
738 if (SCM_LIKELY (SCM_I_INUMP (item
)))
740 scm_t_signed_bits c_item
;
742 c_item
= SCM_I_INUM (item
);
743 if (SCM_LIKELY ((c_item
>= 0) && (c_item
< 256)))
744 c_bv
[i
] = (unsigned char) c_item
;
755 scm_wrong_type_arg (FUNC_NAME
, 1, item
);
761 /* Compute the two's complement of VALUE (a positive integer) on SIZE octets
762 using (2^(SIZE * 8) - VALUE). */
764 twos_complement (mpz_t value
, size_t size
)
766 unsigned long bit_count
;
768 /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
769 checking on SIZE performed earlier. */
770 bit_count
= (unsigned long) size
<< 3UL;
772 if (SCM_LIKELY (bit_count
< sizeof (unsigned long)))
773 mpz_ui_sub (value
, 1UL << bit_count
, value
);
779 mpz_ui_pow_ui (max
, 2, bit_count
);
780 mpz_sub (value
, max
, value
);
786 bytevector_large_ref (const char *c_bv
, size_t c_size
, int signed_p
,
791 int c_endianness
, negative_p
= 0;
795 if (scm_is_eq (endianness
, scm_sym_big
))
796 negative_p
= c_bv
[0] & 0x80;
798 negative_p
= c_bv
[c_size
- 1] & 0x80;
801 c_endianness
= scm_is_eq (endianness
, scm_sym_big
) ? 1 : -1;
804 mpz_import (c_mpz
, 1 /* 1 word */, 1 /* word order doesn't matter */,
805 c_size
/* word is C_SIZE-byte long */,
807 0 /* nails */, c_bv
);
809 if (signed_p
&& negative_p
)
811 twos_complement (c_mpz
, c_size
);
812 mpz_neg (c_mpz
, c_mpz
);
815 result
= scm_from_mpz (c_mpz
);
816 mpz_clear (c_mpz
); /* FIXME: Needed? */
822 bytevector_large_set (char *c_bv
, size_t c_size
, int signed_p
,
823 SCM value
, SCM endianness
)
826 int c_endianness
, c_sign
, err
= 0;
828 c_endianness
= scm_is_eq (endianness
, scm_sym_big
) ? 1 : -1;
831 scm_to_mpz (value
, c_mpz
);
833 c_sign
= mpz_sgn (c_mpz
);
836 if (SCM_LIKELY (signed_p
))
838 mpz_neg (c_mpz
, c_mpz
);
839 twos_complement (c_mpz
, c_size
);
850 memset (c_bv
, 0, c_size
);
853 size_t word_count
, value_size
;
855 value_size
= (mpz_sizeinbase (c_mpz
, 2) + (8 * c_size
)) / (8 * c_size
);
856 if (SCM_UNLIKELY (value_size
> c_size
))
863 mpz_export (c_bv
, &word_count
, 1 /* word order doesn't matter */,
864 c_size
, c_endianness
,
865 0 /* nails */, c_mpz
);
866 if (SCM_UNLIKELY (word_count
!= 1))
867 /* Shouldn't happen since we already checked with VALUE_SIZE. */
877 #define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \
878 unsigned long c_len, c_index, c_size; \
881 SCM_VALIDATE_BYTEVECTOR (1, bv); \
882 c_index = scm_to_ulong (index); \
883 c_size = scm_to_ulong (size); \
885 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
886 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
888 /* C_SIZE must have its 3 higher bits set to zero so that \
889 multiplying it by 8 yields a number that fits in an \
891 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
892 scm_out_of_range (FUNC_NAME, size); \
893 if (SCM_UNLIKELY (c_index + c_size > c_len)) \
894 scm_out_of_range (FUNC_NAME, index);
897 /* Template of an integer reference function. */
898 #define GENERIC_INTEGER_REF(_sign) \
906 swap = !scm_is_eq (endianness, scm_i_native_endianness); \
911 _sign char c_value8; \
912 memcpy (&c_value8, c_bv, 1); \
918 INT_TYPE (16, _sign) c_value16; \
919 memcpy (&c_value16, c_bv, 2); \
921 value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \
930 result = SCM_I_MAKINUM ((_sign int) value); \
933 result = bytevector_large_ref ((char *) c_bv, \
934 c_size, SIGNEDNESS (_sign), \
940 bytevector_signed_ref (const char *c_bv
, size_t c_size
, SCM endianness
)
942 GENERIC_INTEGER_REF (signed);
946 bytevector_unsigned_ref (const char *c_bv
, size_t c_size
, SCM endianness
)
948 GENERIC_INTEGER_REF (unsigned);
952 /* Template of an integer assignment function. */
953 #define GENERIC_INTEGER_SET(_sign) \
956 scm_t_signed_bits c_value; \
958 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
961 c_value = SCM_I_INUM (value); \
965 if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \
967 _sign char c_value8; \
968 c_value8 = (_sign char) c_value; \
969 memcpy (c_bv, &c_value8, 1); \
976 if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \
979 INT_TYPE (16, _sign) c_value16; \
981 swap = !scm_is_eq (endianness, scm_i_native_endianness); \
984 c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \
986 c_value16 = c_value; \
988 memcpy (c_bv, &c_value16, 2); \
1002 err = bytevector_large_set (c_bv, c_size, \
1003 SIGNEDNESS (_sign), \
1004 value, endianness); \
1012 scm_out_of_range (FUNC_NAME, value); \
1016 bytevector_signed_set (char *c_bv
, size_t c_size
,
1017 SCM value
, SCM endianness
,
1018 const char *func_name
)
1019 #define FUNC_NAME func_name
1021 GENERIC_INTEGER_SET (signed);
1026 bytevector_unsigned_set (char *c_bv
, size_t c_size
,
1027 SCM value
, SCM endianness
,
1028 const char *func_name
)
1029 #define FUNC_NAME func_name
1031 GENERIC_INTEGER_SET (unsigned);
1035 #undef GENERIC_INTEGER_SET
1036 #undef GENERIC_INTEGER_REF
1039 SCM_DEFINE (scm_bytevector_uint_ref
, "bytevector-uint-ref", 4, 0, 0,
1040 (SCM bv
, SCM index
, SCM endianness
, SCM size
),
1041 "Return the @var{size}-octet long unsigned integer at index "
1042 "@var{index} in @var{bv}.")
1043 #define FUNC_NAME s_scm_bytevector_uint_ref
1045 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
1047 return (bytevector_unsigned_ref (&c_bv
[c_index
], c_size
, endianness
));
1051 SCM_DEFINE (scm_bytevector_sint_ref
, "bytevector-sint-ref", 4, 0, 0,
1052 (SCM bv
, SCM index
, SCM endianness
, SCM size
),
1053 "Return the @var{size}-octet long unsigned integer at index "
1054 "@var{index} in @var{bv}.")
1055 #define FUNC_NAME s_scm_bytevector_sint_ref
1057 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
1059 return (bytevector_signed_ref (&c_bv
[c_index
], c_size
, endianness
));
1063 SCM_DEFINE (scm_bytevector_uint_set_x
, "bytevector-uint-set!", 5, 0, 0,
1064 (SCM bv
, SCM index
, SCM value
, SCM endianness
, SCM size
),
1065 "Set the @var{size}-octet long unsigned integer at @var{index} "
1067 #define FUNC_NAME s_scm_bytevector_uint_set_x
1069 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
1071 bytevector_unsigned_set (&c_bv
[c_index
], c_size
, value
, endianness
,
1074 return SCM_UNSPECIFIED
;
1078 SCM_DEFINE (scm_bytevector_sint_set_x
, "bytevector-sint-set!", 5, 0, 0,
1079 (SCM bv
, SCM index
, SCM value
, SCM endianness
, SCM size
),
1080 "Set the @var{size}-octet long signed integer at @var{index} "
1082 #define FUNC_NAME s_scm_bytevector_sint_set_x
1084 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
1086 bytevector_signed_set (&c_bv
[c_index
], c_size
, value
, endianness
,
1089 return SCM_UNSPECIFIED
;
1095 /* Operations on integers of arbitrary size. */
1097 #define INTEGERS_TO_LIST(_sign) \
1099 size_t i, c_len, c_size; \
1101 SCM_VALIDATE_BYTEVECTOR (1, bv); \
1102 SCM_VALIDATE_SYMBOL (2, endianness); \
1103 c_size = scm_to_uint (size); \
1105 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
1106 if (SCM_UNLIKELY (c_len == 0)) \
1108 else if (SCM_UNLIKELY (c_len < c_size)) \
1109 scm_out_of_range (FUNC_NAME, size); \
1114 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1116 lst = scm_make_list (scm_from_uint (c_len / c_size), \
1118 for (i = 0, pair = lst; \
1119 i <= c_len - c_size; \
1120 i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
1123 bytevector_ ## _sign ## _ref (c_bv, c_size, \
1130 SCM_DEFINE (scm_bytevector_to_sint_list
, "bytevector->sint-list",
1132 (SCM bv
, SCM endianness
, SCM size
),
1133 "Return a list of signed integers of @var{size} octets "
1134 "representing the contents of @var{bv}.")
1135 #define FUNC_NAME s_scm_bytevector_to_sint_list
1137 INTEGERS_TO_LIST (signed);
1141 SCM_DEFINE (scm_bytevector_to_uint_list
, "bytevector->uint-list",
1143 (SCM bv
, SCM endianness
, SCM size
),
1144 "Return a list of unsigned integers of @var{size} octets "
1145 "representing the contents of @var{bv}.")
1146 #define FUNC_NAME s_scm_bytevector_to_uint_list
1148 INTEGERS_TO_LIST (unsigned);
1152 #undef INTEGER_TO_LIST
1155 #define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
1159 char *c_bv, *c_bv_ptr; \
1161 SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
1162 SCM_VALIDATE_SYMBOL (2, endianness); \
1163 c_size = scm_to_uint (size); \
1165 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
1166 scm_out_of_range (FUNC_NAME, size); \
1168 bv = make_bytevector (c_len * c_size, SCM_ARRAY_ELEMENT_TYPE_VU8); \
1169 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1171 for (c_bv_ptr = c_bv; \
1172 !scm_is_null (lst); \
1173 lst = SCM_CDR (lst), c_bv_ptr += c_size) \
1175 bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
1176 SCM_CAR (lst), endianness, \
1183 SCM_DEFINE (scm_uint_list_to_bytevector
, "uint-list->bytevector",
1185 (SCM lst
, SCM endianness
, SCM size
),
1186 "Return a bytevector containing the unsigned integers "
1187 "listed in @var{lst} and encoded on @var{size} octets "
1188 "according to @var{endianness}.")
1189 #define FUNC_NAME s_scm_uint_list_to_bytevector
1191 INTEGER_LIST_TO_BYTEVECTOR (unsigned);
1195 SCM_DEFINE (scm_sint_list_to_bytevector
, "sint-list->bytevector",
1197 (SCM lst
, SCM endianness
, SCM size
),
1198 "Return a bytevector containing the signed integers "
1199 "listed in @var{lst} and encoded on @var{size} octets "
1200 "according to @var{endianness}.")
1201 #define FUNC_NAME s_scm_sint_list_to_bytevector
1203 INTEGER_LIST_TO_BYTEVECTOR (signed);
1207 #undef INTEGER_LIST_TO_BYTEVECTOR
1211 /* Operations on 16-bit integers. */
1213 SCM_DEFINE (scm_bytevector_u16_ref
, "bytevector-u16-ref",
1215 (SCM bv
, SCM index
, SCM endianness
),
1216 "Return the unsigned 16-bit integer from @var{bv} at "
1218 #define FUNC_NAME s_scm_bytevector_u16_ref
1220 INTEGER_REF (16, unsigned);
1224 SCM_DEFINE (scm_bytevector_s16_ref
, "bytevector-s16-ref",
1226 (SCM bv
, SCM index
, SCM endianness
),
1227 "Return the signed 16-bit integer from @var{bv} at "
1229 #define FUNC_NAME s_scm_bytevector_s16_ref
1231 INTEGER_REF (16, signed);
1235 SCM_DEFINE (scm_bytevector_u16_native_ref
, "bytevector-u16-native-ref",
1237 (SCM bv
, SCM index
),
1238 "Return the unsigned 16-bit integer from @var{bv} at "
1239 "@var{index} using the native endianness.")
1240 #define FUNC_NAME s_scm_bytevector_u16_native_ref
1242 INTEGER_NATIVE_REF (16, unsigned);
1246 SCM_DEFINE (scm_bytevector_s16_native_ref
, "bytevector-s16-native-ref",
1248 (SCM bv
, SCM index
),
1249 "Return the unsigned 16-bit integer from @var{bv} at "
1250 "@var{index} using the native endianness.")
1251 #define FUNC_NAME s_scm_bytevector_s16_native_ref
1253 INTEGER_NATIVE_REF (16, signed);
1257 SCM_DEFINE (scm_bytevector_u16_set_x
, "bytevector-u16-set!",
1259 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1260 "Store @var{value} in @var{bv} at @var{index} according to "
1261 "@var{endianness}.")
1262 #define FUNC_NAME s_scm_bytevector_u16_set_x
1264 INTEGER_SET (16, unsigned);
1268 SCM_DEFINE (scm_bytevector_s16_set_x
, "bytevector-s16-set!",
1270 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1271 "Store @var{value} in @var{bv} at @var{index} according to "
1272 "@var{endianness}.")
1273 #define FUNC_NAME s_scm_bytevector_s16_set_x
1275 INTEGER_SET (16, signed);
1279 SCM_DEFINE (scm_bytevector_u16_native_set_x
, "bytevector-u16-native-set!",
1281 (SCM bv
, SCM index
, SCM value
),
1282 "Store the unsigned integer @var{value} at index @var{index} "
1283 "of @var{bv} using the native endianness.")
1284 #define FUNC_NAME s_scm_bytevector_u16_native_set_x
1286 INTEGER_NATIVE_SET (16, unsigned);
1290 SCM_DEFINE (scm_bytevector_s16_native_set_x
, "bytevector-s16-native-set!",
1292 (SCM bv
, SCM index
, SCM value
),
1293 "Store the signed integer @var{value} at index @var{index} "
1294 "of @var{bv} using the native endianness.")
1295 #define FUNC_NAME s_scm_bytevector_s16_native_set_x
1297 INTEGER_NATIVE_SET (16, signed);
1303 /* Operations on 32-bit integers. */
1305 /* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
1306 arbitrary 32-bit integers. Thus we fall back to using the
1307 `large_{ref,set}' variants on 32-bit machines. */
1309 #define LARGE_INTEGER_REF(_len, _sign) \
1310 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1311 SCM_VALIDATE_SYMBOL (3, endianness); \
1313 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1314 SIGNEDNESS (_sign), endianness));
1316 #define LARGE_INTEGER_SET(_len, _sign) \
1318 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1319 SCM_VALIDATE_SYMBOL (4, endianness); \
1321 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1322 SIGNEDNESS (_sign), value, endianness); \
1323 if (SCM_UNLIKELY (err)) \
1324 scm_out_of_range (FUNC_NAME, value); \
1326 return SCM_UNSPECIFIED;
1328 #define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
1329 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1330 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1331 SIGNEDNESS (_sign), scm_i_native_endianness));
1333 #define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
1335 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1337 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1338 SIGNEDNESS (_sign), value, \
1339 scm_i_native_endianness); \
1340 if (SCM_UNLIKELY (err)) \
1341 scm_out_of_range (FUNC_NAME, value); \
1343 return SCM_UNSPECIFIED;
1346 SCM_DEFINE (scm_bytevector_u32_ref
, "bytevector-u32-ref",
1348 (SCM bv
, SCM index
, SCM endianness
),
1349 "Return the unsigned 32-bit integer from @var{bv} at "
1351 #define FUNC_NAME s_scm_bytevector_u32_ref
1353 #if SIZEOF_VOID_P > 4
1354 INTEGER_REF (32, unsigned);
1356 LARGE_INTEGER_REF (32, unsigned);
1361 SCM_DEFINE (scm_bytevector_s32_ref
, "bytevector-s32-ref",
1363 (SCM bv
, SCM index
, SCM endianness
),
1364 "Return the signed 32-bit integer from @var{bv} at "
1366 #define FUNC_NAME s_scm_bytevector_s32_ref
1368 #if SIZEOF_VOID_P > 4
1369 INTEGER_REF (32, signed);
1371 LARGE_INTEGER_REF (32, signed);
1376 SCM_DEFINE (scm_bytevector_u32_native_ref
, "bytevector-u32-native-ref",
1378 (SCM bv
, SCM index
),
1379 "Return the unsigned 32-bit integer from @var{bv} at "
1380 "@var{index} using the native endianness.")
1381 #define FUNC_NAME s_scm_bytevector_u32_native_ref
1383 #if SIZEOF_VOID_P > 4
1384 INTEGER_NATIVE_REF (32, unsigned);
1386 LARGE_INTEGER_NATIVE_REF (32, unsigned);
1391 SCM_DEFINE (scm_bytevector_s32_native_ref
, "bytevector-s32-native-ref",
1393 (SCM bv
, SCM index
),
1394 "Return the unsigned 32-bit integer from @var{bv} at "
1395 "@var{index} using the native endianness.")
1396 #define FUNC_NAME s_scm_bytevector_s32_native_ref
1398 #if SIZEOF_VOID_P > 4
1399 INTEGER_NATIVE_REF (32, signed);
1401 LARGE_INTEGER_NATIVE_REF (32, signed);
1406 SCM_DEFINE (scm_bytevector_u32_set_x
, "bytevector-u32-set!",
1408 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1409 "Store @var{value} in @var{bv} at @var{index} according to "
1410 "@var{endianness}.")
1411 #define FUNC_NAME s_scm_bytevector_u32_set_x
1413 #if SIZEOF_VOID_P > 4
1414 INTEGER_SET (32, unsigned);
1416 LARGE_INTEGER_SET (32, unsigned);
1421 SCM_DEFINE (scm_bytevector_s32_set_x
, "bytevector-s32-set!",
1423 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1424 "Store @var{value} in @var{bv} at @var{index} according to "
1425 "@var{endianness}.")
1426 #define FUNC_NAME s_scm_bytevector_s32_set_x
1428 #if SIZEOF_VOID_P > 4
1429 INTEGER_SET (32, signed);
1431 LARGE_INTEGER_SET (32, signed);
1436 SCM_DEFINE (scm_bytevector_u32_native_set_x
, "bytevector-u32-native-set!",
1438 (SCM bv
, SCM index
, SCM value
),
1439 "Store the unsigned integer @var{value} at index @var{index} "
1440 "of @var{bv} using the native endianness.")
1441 #define FUNC_NAME s_scm_bytevector_u32_native_set_x
1443 #if SIZEOF_VOID_P > 4
1444 INTEGER_NATIVE_SET (32, unsigned);
1446 LARGE_INTEGER_NATIVE_SET (32, unsigned);
1451 SCM_DEFINE (scm_bytevector_s32_native_set_x
, "bytevector-s32-native-set!",
1453 (SCM bv
, SCM index
, SCM value
),
1454 "Store the signed integer @var{value} at index @var{index} "
1455 "of @var{bv} using the native endianness.")
1456 #define FUNC_NAME s_scm_bytevector_s32_native_set_x
1458 #if SIZEOF_VOID_P > 4
1459 INTEGER_NATIVE_SET (32, signed);
1461 LARGE_INTEGER_NATIVE_SET (32, signed);
1468 /* Operations on 64-bit integers. */
1470 /* For 64-bit integers, we use only the `large_{ref,set}' variant. */
1472 SCM_DEFINE (scm_bytevector_u64_ref
, "bytevector-u64-ref",
1474 (SCM bv
, SCM index
, SCM endianness
),
1475 "Return the unsigned 64-bit integer from @var{bv} at "
1477 #define FUNC_NAME s_scm_bytevector_u64_ref
1479 LARGE_INTEGER_REF (64, unsigned);
1483 SCM_DEFINE (scm_bytevector_s64_ref
, "bytevector-s64-ref",
1485 (SCM bv
, SCM index
, SCM endianness
),
1486 "Return the signed 64-bit integer from @var{bv} at "
1488 #define FUNC_NAME s_scm_bytevector_s64_ref
1490 LARGE_INTEGER_REF (64, signed);
1494 SCM_DEFINE (scm_bytevector_u64_native_ref
, "bytevector-u64-native-ref",
1496 (SCM bv
, SCM index
),
1497 "Return the unsigned 64-bit integer from @var{bv} at "
1498 "@var{index} using the native endianness.")
1499 #define FUNC_NAME s_scm_bytevector_u64_native_ref
1501 LARGE_INTEGER_NATIVE_REF (64, unsigned);
1505 SCM_DEFINE (scm_bytevector_s64_native_ref
, "bytevector-s64-native-ref",
1507 (SCM bv
, SCM index
),
1508 "Return the unsigned 64-bit integer from @var{bv} at "
1509 "@var{index} using the native endianness.")
1510 #define FUNC_NAME s_scm_bytevector_s64_native_ref
1512 LARGE_INTEGER_NATIVE_REF (64, signed);
1516 SCM_DEFINE (scm_bytevector_u64_set_x
, "bytevector-u64-set!",
1518 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1519 "Store @var{value} in @var{bv} at @var{index} according to "
1520 "@var{endianness}.")
1521 #define FUNC_NAME s_scm_bytevector_u64_set_x
1523 LARGE_INTEGER_SET (64, unsigned);
1527 SCM_DEFINE (scm_bytevector_s64_set_x
, "bytevector-s64-set!",
1529 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1530 "Store @var{value} in @var{bv} at @var{index} according to "
1531 "@var{endianness}.")
1532 #define FUNC_NAME s_scm_bytevector_s64_set_x
1534 LARGE_INTEGER_SET (64, signed);
1538 SCM_DEFINE (scm_bytevector_u64_native_set_x
, "bytevector-u64-native-set!",
1540 (SCM bv
, SCM index
, SCM value
),
1541 "Store the unsigned integer @var{value} at index @var{index} "
1542 "of @var{bv} using the native endianness.")
1543 #define FUNC_NAME s_scm_bytevector_u64_native_set_x
1545 LARGE_INTEGER_NATIVE_SET (64, unsigned);
1549 SCM_DEFINE (scm_bytevector_s64_native_set_x
, "bytevector-s64-native-set!",
1551 (SCM bv
, SCM index
, SCM value
),
1552 "Store the signed integer @var{value} at index @var{index} "
1553 "of @var{bv} using the native endianness.")
1554 #define FUNC_NAME s_scm_bytevector_s64_native_set_x
1556 LARGE_INTEGER_NATIVE_SET (64, signed);
1562 /* Operations on IEEE-754 numbers. */
1564 /* There are two possible word endians, visible in glibc's <ieee754.h>.
1565 However, in R6RS, when the endianness is `little', little endian is
1566 assumed for both the byte order and the word order. This is clear from
1567 Section 2.1 of R6RS-lib (in response to
1568 http://www.r6rs.org/formal-comments/comment-187.txt). */
1571 /* Convert to/from a floating-point number with different endianness. This
1572 method is probably not the most efficient but it should be portable. */
1575 float_to_foreign_endianness (union scm_ieee754_float
*target
,
1578 union scm_ieee754_float src
;
1582 #ifdef WORDS_BIGENDIAN
1583 /* Assuming little endian for both byte and word order. */
1584 target
->little_endian
.negative
= src
.big_endian
.negative
;
1585 target
->little_endian
.exponent
= src
.big_endian
.exponent
;
1586 target
->little_endian
.mantissa
= src
.big_endian
.mantissa
;
1588 target
->big_endian
.negative
= src
.little_endian
.negative
;
1589 target
->big_endian
.exponent
= src
.little_endian
.exponent
;
1590 target
->big_endian
.mantissa
= src
.little_endian
.mantissa
;
1595 float_from_foreign_endianness (const union scm_ieee754_float
*source
)
1597 union scm_ieee754_float result
;
1599 #ifdef WORDS_BIGENDIAN
1600 /* Assuming little endian for both byte and word order. */
1601 result
.big_endian
.negative
= source
->little_endian
.negative
;
1602 result
.big_endian
.exponent
= source
->little_endian
.exponent
;
1603 result
.big_endian
.mantissa
= source
->little_endian
.mantissa
;
1605 result
.little_endian
.negative
= source
->big_endian
.negative
;
1606 result
.little_endian
.exponent
= source
->big_endian
.exponent
;
1607 result
.little_endian
.mantissa
= source
->big_endian
.mantissa
;
1614 double_to_foreign_endianness (union scm_ieee754_double
*target
,
1617 union scm_ieee754_double src
;
1621 #ifdef WORDS_BIGENDIAN
1622 /* Assuming little endian for both byte and word order. */
1623 target
->little_little_endian
.negative
= src
.big_endian
.negative
;
1624 target
->little_little_endian
.exponent
= src
.big_endian
.exponent
;
1625 target
->little_little_endian
.mantissa0
= src
.big_endian
.mantissa0
;
1626 target
->little_little_endian
.mantissa1
= src
.big_endian
.mantissa1
;
1628 target
->big_endian
.negative
= src
.little_little_endian
.negative
;
1629 target
->big_endian
.exponent
= src
.little_little_endian
.exponent
;
1630 target
->big_endian
.mantissa0
= src
.little_little_endian
.mantissa0
;
1631 target
->big_endian
.mantissa1
= src
.little_little_endian
.mantissa1
;
1635 static inline double
1636 double_from_foreign_endianness (const union scm_ieee754_double
*source
)
1638 union scm_ieee754_double result
;
1640 #ifdef WORDS_BIGENDIAN
1641 /* Assuming little endian for both byte and word order. */
1642 result
.big_endian
.negative
= source
->little_little_endian
.negative
;
1643 result
.big_endian
.exponent
= source
->little_little_endian
.exponent
;
1644 result
.big_endian
.mantissa0
= source
->little_little_endian
.mantissa0
;
1645 result
.big_endian
.mantissa1
= source
->little_little_endian
.mantissa1
;
1647 result
.little_little_endian
.negative
= source
->big_endian
.negative
;
1648 result
.little_little_endian
.exponent
= source
->big_endian
.exponent
;
1649 result
.little_little_endian
.mantissa0
= source
->big_endian
.mantissa0
;
1650 result
.little_little_endian
.mantissa1
= source
->big_endian
.mantissa1
;
1656 /* Template macros to abstract over doubles and floats.
1657 XXX: Guile can only convert to/from doubles. */
1658 #define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type
1659 #define IEEE754_TO_SCM(_c_type) scm_from_double
1660 #define IEEE754_FROM_SCM(_c_type) scm_to_double
1661 #define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
1662 _c_type ## _from_foreign_endianness
1663 #define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
1664 _c_type ## _to_foreign_endianness
1667 /* FIXME: SCM_VALIDATE_REAL rejects integers, etc. grrr */
1668 #define VALIDATE_REAL(pos, v) \
1670 SCM_ASSERT_TYPE (scm_is_real (v), v, pos, FUNC_NAME, "real"); \
1673 /* Templace getters and setters. */
1675 #define IEEE754_ACCESSOR_PROLOGUE(_type) \
1676 INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
1678 #define IEEE754_REF(_type) \
1681 IEEE754_ACCESSOR_PROLOGUE (_type); \
1682 SCM_VALIDATE_SYMBOL (3, endianness); \
1684 if (scm_is_eq (endianness, scm_i_native_endianness)) \
1685 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1688 IEEE754_UNION (_type) c_raw; \
1690 memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
1692 IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
1695 return (IEEE754_TO_SCM (_type) (c_result));
1697 #define IEEE754_NATIVE_REF(_type) \
1700 IEEE754_ACCESSOR_PROLOGUE (_type); \
1702 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1703 return (IEEE754_TO_SCM (_type) (c_result));
1705 #define IEEE754_SET(_type) \
1708 IEEE754_ACCESSOR_PROLOGUE (_type); \
1709 VALIDATE_REAL (3, value); \
1710 SCM_VALIDATE_SYMBOL (4, endianness); \
1711 c_value = IEEE754_FROM_SCM (_type) (value); \
1713 if (scm_is_eq (endianness, scm_i_native_endianness)) \
1714 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1717 IEEE754_UNION (_type) c_raw; \
1719 IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
1720 memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
1723 return SCM_UNSPECIFIED;
1725 #define IEEE754_NATIVE_SET(_type) \
1728 IEEE754_ACCESSOR_PROLOGUE (_type); \
1729 VALIDATE_REAL (3, value); \
1730 c_value = IEEE754_FROM_SCM (_type) (value); \
1732 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1733 return SCM_UNSPECIFIED;
1736 /* Single precision. */
1738 SCM_DEFINE (scm_bytevector_ieee_single_ref
,
1739 "bytevector-ieee-single-ref",
1741 (SCM bv
, SCM index
, SCM endianness
),
1742 "Return the IEEE-754 single from @var{bv} at "
1744 #define FUNC_NAME s_scm_bytevector_ieee_single_ref
1746 IEEE754_REF (float);
1750 SCM_DEFINE (scm_bytevector_ieee_single_native_ref
,
1751 "bytevector-ieee-single-native-ref",
1753 (SCM bv
, SCM index
),
1754 "Return the IEEE-754 single from @var{bv} at "
1755 "@var{index} using the native endianness.")
1756 #define FUNC_NAME s_scm_bytevector_ieee_single_native_ref
1758 IEEE754_NATIVE_REF (float);
1762 SCM_DEFINE (scm_bytevector_ieee_single_set_x
,
1763 "bytevector-ieee-single-set!",
1765 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1766 "Store real @var{value} in @var{bv} at @var{index} according to "
1767 "@var{endianness}.")
1768 #define FUNC_NAME s_scm_bytevector_ieee_single_set_x
1770 IEEE754_SET (float);
1774 SCM_DEFINE (scm_bytevector_ieee_single_native_set_x
,
1775 "bytevector-ieee-single-native-set!",
1777 (SCM bv
, SCM index
, SCM value
),
1778 "Store the real @var{value} at index @var{index} "
1779 "of @var{bv} using the native endianness.")
1780 #define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x
1782 IEEE754_NATIVE_SET (float);
1787 /* Double precision. */
1789 SCM_DEFINE (scm_bytevector_ieee_double_ref
,
1790 "bytevector-ieee-double-ref",
1792 (SCM bv
, SCM index
, SCM endianness
),
1793 "Return the IEEE-754 double from @var{bv} at "
1795 #define FUNC_NAME s_scm_bytevector_ieee_double_ref
1797 IEEE754_REF (double);
1801 SCM_DEFINE (scm_bytevector_ieee_double_native_ref
,
1802 "bytevector-ieee-double-native-ref",
1804 (SCM bv
, SCM index
),
1805 "Return the IEEE-754 double from @var{bv} at "
1806 "@var{index} using the native endianness.")
1807 #define FUNC_NAME s_scm_bytevector_ieee_double_native_ref
1809 IEEE754_NATIVE_REF (double);
1813 SCM_DEFINE (scm_bytevector_ieee_double_set_x
,
1814 "bytevector-ieee-double-set!",
1816 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1817 "Store real @var{value} in @var{bv} at @var{index} according to "
1818 "@var{endianness}.")
1819 #define FUNC_NAME s_scm_bytevector_ieee_double_set_x
1821 IEEE754_SET (double);
1825 SCM_DEFINE (scm_bytevector_ieee_double_native_set_x
,
1826 "bytevector-ieee-double-native-set!",
1828 (SCM bv
, SCM index
, SCM value
),
1829 "Store the real @var{value} at index @var{index} "
1830 "of @var{bv} using the native endianness.")
1831 #define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x
1833 IEEE754_NATIVE_SET (double);
1838 #undef IEEE754_UNION
1839 #undef IEEE754_TO_SCM
1840 #undef IEEE754_FROM_SCM
1841 #undef IEEE754_FROM_FOREIGN_ENDIANNESS
1842 #undef IEEE754_TO_FOREIGN_ENDIANNESS
1844 #undef IEEE754_NATIVE_REF
1846 #undef IEEE754_NATIVE_SET
1849 /* Operations on strings. */
1852 /* Produce a function that returns the length of a UTF-encoded string. */
1853 #define UTF_STRLEN_FUNCTION(_utf_width) \
1854 static inline size_t \
1855 utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
1858 const uint ## _utf_width ## _t *ptr; \
1866 return (len * ((_utf_width) / 8)); \
1869 UTF_STRLEN_FUNCTION (8)
1872 /* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
1873 #define UTF_STRLEN(_utf_width, _str) \
1874 utf ## _utf_width ## _strlen (_str)
1876 /* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
1877 ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
1880 utf_encoding_name (char *name
, size_t utf_width
, SCM endianness
)
1882 strcpy (name
, "UTF-");
1883 strcat (name
, ((utf_width
== 8)
1885 : ((utf_width
== 16)
1887 : ((utf_width
== 32)
1891 ((scm_is_eq (endianness
, scm_sym_big
))
1893 : ((scm_is_eq (endianness
, scm_sym_little
))
1898 /* Maximum length of a UTF encoding name. */
1899 #define MAX_UTF_ENCODING_NAME_LEN 16
1901 /* Produce the body of a `string->utf' function. */
1902 #define STRING_TO_UTF(_utf_width) \
1905 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1906 char *c_utf = NULL; \
1907 size_t c_strlen, c_utf_len = 0; \
1909 SCM_VALIDATE_STRING (1, str); \
1910 if (scm_is_eq (endianness, SCM_UNDEFINED)) \
1911 endianness = scm_sym_big; \
1913 SCM_VALIDATE_SYMBOL (2, endianness); \
1915 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1917 c_strlen = scm_i_string_length (str); \
1918 if (scm_i_is_narrow_string (str)) \
1920 err = mem_iconveh (scm_i_string_chars (str), c_strlen, \
1921 "ISO-8859-1", c_utf_name, \
1922 iconveh_question_mark, NULL, \
1923 &c_utf, &c_utf_len); \
1924 if (SCM_UNLIKELY (err)) \
1925 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1926 scm_list_1 (str), err); \
1930 const scm_t_wchar *wbuf = scm_i_string_wide_chars (str); \
1931 c_utf = u32_conv_to_encoding (c_utf_name, \
1932 iconveh_question_mark, \
1933 (scm_t_uint32 *) wbuf, \
1934 c_strlen, NULL, NULL, &c_utf_len); \
1935 if (SCM_UNLIKELY (c_utf == NULL)) \
1936 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1937 scm_list_1 (str), errno); \
1939 scm_dynwind_begin (0); \
1940 scm_dynwind_free (c_utf); \
1941 utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8); \
1942 memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len); \
1943 scm_dynwind_end (); \
1949 SCM_DEFINE (scm_string_to_utf8
, "string->utf8",
1952 "Return a newly allocated bytevector that contains the UTF-8 "
1953 "encoding of @var{str}.")
1954 #define FUNC_NAME s_scm_string_to_utf8
1958 size_t c_strlen
, c_utf_len
= 0;
1960 SCM_VALIDATE_STRING (1, str
);
1962 c_strlen
= scm_i_string_length (str
);
1963 if (scm_i_is_narrow_string (str
))
1964 c_utf
= u8_conv_from_encoding ("ISO-8859-1", iconveh_question_mark
,
1965 scm_i_string_chars (str
), c_strlen
,
1966 NULL
, NULL
, &c_utf_len
);
1969 const scm_t_wchar
*wbuf
= scm_i_string_wide_chars (str
);
1970 c_utf
= u32_to_u8 ((const uint32_t *) wbuf
, c_strlen
, NULL
, &c_utf_len
);
1972 if (SCM_UNLIKELY (c_utf
== NULL
))
1973 scm_syserror (FUNC_NAME
);
1976 scm_dynwind_begin (0);
1977 scm_dynwind_free (c_utf
);
1979 utf
= make_bytevector (c_utf_len
, SCM_ARRAY_ELEMENT_TYPE_VU8
);
1980 memcpy (SCM_BYTEVECTOR_CONTENTS (utf
), c_utf
, c_utf_len
);
1989 SCM_DEFINE (scm_string_to_utf16
, "string->utf16",
1991 (SCM str
, SCM endianness
),
1992 "Return a newly allocated bytevector that contains the UTF-16 "
1993 "encoding of @var{str}.")
1994 #define FUNC_NAME s_scm_string_to_utf16
2000 SCM_DEFINE (scm_string_to_utf32
, "string->utf32",
2002 (SCM str
, SCM endianness
),
2003 "Return a newly allocated bytevector that contains the UTF-32 "
2004 "encoding of @var{str}.")
2005 #define FUNC_NAME s_scm_string_to_utf32
2012 /* Produce the body of a function that converts a UTF-encoded bytevector to a
2014 #define UTF_TO_STRING(_utf_width) \
2015 SCM str = SCM_BOOL_F; \
2017 char *c_str = NULL; \
2018 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
2020 size_t c_strlen = 0, c_utf_len = 0; \
2022 SCM_VALIDATE_BYTEVECTOR (1, utf); \
2023 if (scm_is_eq (endianness, SCM_UNDEFINED)) \
2024 endianness = scm_sym_big; \
2026 SCM_VALIDATE_SYMBOL (2, endianness); \
2028 c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \
2029 c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
2030 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
2032 err = mem_iconveh (c_utf, c_utf_len, \
2033 c_utf_name, "UTF-8", \
2034 iconveh_question_mark, NULL, \
2035 &c_str, &c_strlen); \
2036 if (SCM_UNLIKELY (err)) \
2037 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
2038 scm_list_1 (utf), err); \
2041 str = scm_from_stringn (c_str, c_strlen, "UTF-8", \
2042 SCM_FAILED_CONVERSION_ERROR); \
2048 SCM_DEFINE (scm_utf8_to_string
, "utf8->string",
2051 "Return a newly allocate string that contains from the UTF-8-"
2052 "encoded contents of bytevector @var{utf}.")
2053 #define FUNC_NAME s_scm_utf8_to_string
2057 size_t c_utf_len
= 0;
2059 SCM_VALIDATE_BYTEVECTOR (1, utf
);
2061 c_utf_len
= SCM_BYTEVECTOR_LENGTH (utf
);
2062 c_utf
= (char *) SCM_BYTEVECTOR_CONTENTS (utf
);
2063 str
= scm_from_stringn (c_utf
, c_utf_len
, "UTF-8",
2064 SCM_FAILED_CONVERSION_ERROR
);
2070 SCM_DEFINE (scm_utf16_to_string
, "utf16->string",
2072 (SCM utf
, SCM endianness
),
2073 "Return a newly allocate string that contains from the UTF-16-"
2074 "encoded contents of bytevector @var{utf}.")
2075 #define FUNC_NAME s_scm_utf16_to_string
2081 SCM_DEFINE (scm_utf32_to_string
, "utf32->string",
2083 (SCM utf
, SCM endianness
),
2084 "Return a newly allocate string that contains from the UTF-32-"
2085 "encoded contents of bytevector @var{utf}.")
2086 #define FUNC_NAME s_scm_utf32_to_string
2093 /* Bytevectors as generalized vectors & arrays. */
2095 #define COMPLEX_ACCESSOR_PROLOGUE(_type) \
2096 size_t c_len, c_index; \
2099 SCM_VALIDATE_BYTEVECTOR (1, bv); \
2100 c_index = scm_to_size_t (index); \
2102 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
2103 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
2105 if (SCM_UNLIKELY (c_index + 2 * sizeof (_type) - 1 >= c_len)) \
2106 scm_out_of_range (FUNC_NAME, index);
2108 /* Template for native access to complex numbers of type TYPE. */
2109 #define COMPLEX_NATIVE_REF(_type) \
2112 COMPLEX_ACCESSOR_PROLOGUE (_type); \
2117 memcpy (&real, &c_bv[c_index], sizeof (_type)); \
2118 memcpy (&imag, &c_bv[c_index + sizeof (_type)], sizeof (_type)); \
2120 result = scm_c_make_rectangular (real, imag); \
2126 bytevector_ref_c32 (SCM bv
, SCM index
)
2127 #define FUNC_NAME "bytevector_ref_c32"
2129 COMPLEX_NATIVE_REF (float);
2134 bytevector_ref_c64 (SCM bv
, SCM index
)
2135 #define FUNC_NAME "bytevector_ref_c64"
2137 COMPLEX_NATIVE_REF (double);
2141 typedef SCM (*scm_t_bytevector_ref_fn
)(SCM
, SCM
);
2143 static const scm_t_bytevector_ref_fn
2144 bytevector_ref_fns
[SCM_ARRAY_ELEMENT_TYPE_LAST
+ 1] =
2149 scm_bytevector_u8_ref
, /* VU8 */
2150 scm_bytevector_u8_ref
, /* U8 */
2151 scm_bytevector_s8_ref
,
2152 scm_bytevector_u16_native_ref
,
2153 scm_bytevector_s16_native_ref
,
2154 scm_bytevector_u32_native_ref
,
2155 scm_bytevector_s32_native_ref
,
2156 scm_bytevector_u64_native_ref
,
2157 scm_bytevector_s64_native_ref
,
2158 scm_bytevector_ieee_single_native_ref
,
2159 scm_bytevector_ieee_double_native_ref
,
2165 bv_handle_ref (scm_t_array_handle
*h
, size_t index
)
2168 scm_t_bytevector_ref_fn ref_fn
;
2170 ref_fn
= bytevector_ref_fns
[h
->element_type
];
2172 scm_from_size_t (index
* scm_array_handle_uniform_element_size (h
));
2173 return ref_fn (h
->array
, byte_index
);
2176 /* Template for native modification of complex numbers of type TYPE. */
2177 #define COMPLEX_NATIVE_SET(_type) \
2178 COMPLEX_ACCESSOR_PROLOGUE (_type); \
2182 real = scm_c_real_part (value); \
2183 imag = scm_c_imag_part (value); \
2185 memcpy (&c_bv[c_index], &real, sizeof (_type)); \
2186 memcpy (&c_bv[c_index + sizeof (_type)], &imag, sizeof (_type)); \
2189 return SCM_UNSPECIFIED;
2192 bytevector_set_c32 (SCM bv
, SCM index
, SCM value
)
2193 #define FUNC_NAME "bytevector_set_c32"
2195 COMPLEX_NATIVE_SET (float);
2200 bytevector_set_c64 (SCM bv
, SCM index
, SCM value
)
2201 #define FUNC_NAME "bytevector_set_c64"
2203 COMPLEX_NATIVE_SET (double);
2207 typedef SCM (*scm_t_bytevector_set_fn
)(SCM
, SCM
, SCM
);
2209 const scm_t_bytevector_set_fn bytevector_set_fns
[SCM_ARRAY_ELEMENT_TYPE_LAST
+ 1] =
2214 scm_bytevector_u8_set_x
, /* VU8 */
2215 scm_bytevector_u8_set_x
, /* U8 */
2216 scm_bytevector_s8_set_x
,
2217 scm_bytevector_u16_native_set_x
,
2218 scm_bytevector_s16_native_set_x
,
2219 scm_bytevector_u32_native_set_x
,
2220 scm_bytevector_s32_native_set_x
,
2221 scm_bytevector_u64_native_set_x
,
2222 scm_bytevector_s64_native_set_x
,
2223 scm_bytevector_ieee_single_native_set_x
,
2224 scm_bytevector_ieee_double_native_set_x
,
2230 bv_handle_set_x (scm_t_array_handle
*h
, size_t index
, SCM val
)
2233 scm_t_bytevector_set_fn set_fn
;
2235 set_fn
= bytevector_set_fns
[h
->element_type
];
2237 scm_from_size_t (index
* scm_array_handle_uniform_element_size (h
));
2238 set_fn (h
->array
, byte_index
, val
);
2242 bytevector_get_handle (SCM v
, scm_t_array_handle
*h
)
2248 h
->dim0
.ubnd
= SCM_BYTEVECTOR_TYPED_LENGTH (v
) - 1;
2250 h
->element_type
= SCM_BYTEVECTOR_ELEMENT_TYPE (v
);
2251 h
->elements
= h
->writable_elements
= SCM_BYTEVECTOR_CONTENTS (v
);
2255 /* Initialization. */
2258 scm_bootstrap_bytevectors (void)
2260 /* This must be instantiated here because the generalized-vector API may
2261 want to access bytevectors even though `(rnrs bytevectors)' hasn't been
2263 scm_null_bytevector
= make_bytevector (0, SCM_ARRAY_ELEMENT_TYPE_VU8
);
2265 #ifdef WORDS_BIGENDIAN
2266 scm_i_native_endianness
= scm_from_latin1_symbol ("big");
2268 scm_i_native_endianness
= scm_from_latin1_symbol ("little");
2271 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
2272 "scm_init_bytevectors",
2273 (scm_t_extension_init_func
) scm_init_bytevectors
,
2277 scm_t_array_implementation impl
;
2279 impl
.tag
= scm_tc7_bytevector
;
2281 impl
.vref
= bv_handle_ref
;
2282 impl
.vset
= bv_handle_set_x
;
2283 impl
.get_handle
= bytevector_get_handle
;
2284 scm_i_register_array_implementation (&impl
);
2285 scm_i_register_vector_constructor
2286 (scm_i_array_element_types
[SCM_ARRAY_ELEMENT_TYPE_VU8
],
2287 scm_make_bytevector
);
2292 scm_init_bytevectors (void)
2294 #include "libguile/bytevectors.x"
2296 scm_endianness_big
= scm_sym_big
;
2297 scm_endianness_little
= scm_sym_little
;