1 /* Copyright (C) 2009 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
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but 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 02110-1301 USA
27 #include "libguile/_scm.h"
28 #include "libguile/bytevectors.h"
29 #include "libguile/strings.h"
30 #include "libguile/validate.h"
31 #include "libguile/ieee-754.h"
32 #include "libguile/unif.h"
33 #include "libguile/srfi-4.h"
36 #include <striconveh.h>
42 /* Assuming 32-bit longs. */
43 # define ULONG_MAX 4294967295UL
52 /* Convenience macros. These are used by the various templates (macros) that
53 are parameterized by integer signedness. */
54 #define INT8_T_signed scm_t_int8
55 #define INT8_T_unsigned scm_t_uint8
56 #define INT16_T_signed scm_t_int16
57 #define INT16_T_unsigned scm_t_uint16
58 #define INT32_T_signed scm_t_int32
59 #define INT32_T_unsigned scm_t_uint32
60 #define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L))
61 #define is_unsigned_int8(_x) ((_x) <= 255UL)
62 #define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
63 #define is_unsigned_int16(_x) ((_x) <= 65535UL)
64 #define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L))
65 #define is_unsigned_int32(_x) ((_x) <= 4294967295UL)
66 #define SIGNEDNESS_signed 1
67 #define SIGNEDNESS_unsigned 0
69 #define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign
70 #define INT_SWAP(_size) bswap_ ## _size
71 #define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
72 #define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
75 #define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \
76 unsigned c_len, c_index; \
79 SCM_VALIDATE_BYTEVECTOR (1, bv); \
80 c_index = scm_to_uint (index); \
82 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
83 c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \
85 if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
86 scm_out_of_range (FUNC_NAME, index);
88 /* Template for fixed-size integer access (only 8, 16 or 32-bit). */
89 #define INTEGER_REF(_len, _sign) \
92 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
93 SCM_VALIDATE_SYMBOL (3, endianness); \
96 INT_TYPE (_len, _sign) c_result; \
98 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
99 if (!scm_is_eq (endianness, native_endianness)) \
100 c_result = INT_SWAP (_len) (c_result); \
102 result = SCM_I_MAKINUM (c_result); \
107 /* Template for fixed-size integer access using the native endianness. */
108 #define INTEGER_NATIVE_REF(_len, _sign) \
111 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
114 INT_TYPE (_len, _sign) c_result; \
116 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
117 result = SCM_I_MAKINUM (c_result); \
122 /* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
123 #define INTEGER_SET(_len, _sign) \
124 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
125 SCM_VALIDATE_SYMBOL (3, endianness); \
128 _sign long c_value; \
129 INT_TYPE (_len, _sign) c_value_short; \
131 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
132 scm_wrong_type_arg (FUNC_NAME, 3, value); \
134 c_value = SCM_I_INUM (value); \
135 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
136 scm_out_of_range (FUNC_NAME, value); \
138 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
139 if (!scm_is_eq (endianness, native_endianness)) \
140 c_value_short = INT_SWAP (_len) (c_value_short); \
142 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
145 return SCM_UNSPECIFIED;
147 /* Template for fixed-size integer modification using the native
149 #define INTEGER_NATIVE_SET(_len, _sign) \
150 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
153 _sign long c_value; \
154 INT_TYPE (_len, _sign) c_value_short; \
156 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
157 scm_wrong_type_arg (FUNC_NAME, 3, value); \
159 c_value = SCM_I_INUM (value); \
160 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
161 scm_out_of_range (FUNC_NAME, value); \
163 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
165 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
168 return SCM_UNSPECIFIED;
172 /* Bytevector type. */
174 SCM_GLOBAL_SMOB (scm_tc16_bytevector
, "r6rs-bytevector", 0);
176 #define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
177 SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len))
178 #define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
179 SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf))
181 /* The empty bytevector. */
182 SCM scm_null_bytevector
= SCM_UNSPECIFIED
;
186 make_bytevector_from_buffer (unsigned len
, signed char *contents
)
188 /* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */
189 SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector
, len
, contents
);
193 make_bytevector (unsigned len
)
197 if (SCM_UNLIKELY (len
== 0))
198 bv
= scm_null_bytevector
;
201 signed char *contents
= NULL
;
203 if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len
))
204 contents
= (signed char *) scm_gc_malloc (len
, SCM_GC_BYTEVECTOR
);
206 bv
= make_bytevector_from_buffer (len
, contents
);
212 /* Return a new bytevector of size LEN octets. */
214 scm_c_make_bytevector (unsigned len
)
216 return (make_bytevector (len
));
219 /* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
220 by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
222 scm_c_take_bytevector (signed char *contents
, unsigned len
)
226 if (SCM_UNLIKELY (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len
)))
228 /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */
231 bv
= make_bytevector (len
);
232 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
233 memcpy (c_bv
, contents
, len
);
234 scm_gc_free (contents
, len
, SCM_GC_BYTEVECTOR
);
237 bv
= make_bytevector_from_buffer (len
, contents
);
242 /* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
243 size) and return BV. */
245 scm_i_shrink_bytevector (SCM bv
, unsigned c_new_len
)
247 if (!SCM_BYTEVECTOR_INLINE_P (bv
))
250 signed char *c_bv
, *c_new_bv
;
252 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
253 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
255 SCM_BYTEVECTOR_SET_LENGTH (bv
, c_new_len
);
257 if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len
))
259 /* Copy to the in-line buffer and free the current buffer. */
260 c_new_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
261 memcpy (c_new_bv
, c_bv
, c_new_len
);
262 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
266 /* Resize the existing buffer. */
267 c_new_bv
= scm_gc_realloc (c_bv
, c_len
, c_new_len
,
269 SCM_BYTEVECTOR_SET_CONTENTS (bv
, c_new_bv
);
276 SCM_SMOB_PRINT (scm_tc16_bytevector
, print_bytevector
,
282 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
283 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
285 scm_puts ("#vu8(", port
);
286 for (i
= 0; i
< c_len
; i
++)
289 scm_putc (' ', port
);
291 scm_uintprint (c_bv
[i
], 10, port
);
294 scm_putc (')', port
);
296 /* Make GCC think we use it. */
297 scm_remember_upto_here ((SCM
) pstate
);
302 SCM_SMOB_FREE (scm_tc16_bytevector
, free_bytevector
, bv
)
305 if (!SCM_BYTEVECTOR_INLINE_P (bv
))
310 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
311 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
313 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
321 /* General operations. */
323 SCM_SYMBOL (scm_sym_big
, "big");
324 SCM_SYMBOL (scm_sym_little
, "little");
326 SCM scm_endianness_big
, scm_endianness_little
;
328 /* Host endianness (a symbol). */
329 static SCM native_endianness
= SCM_UNSPECIFIED
;
333 # define bswap_24(_x) \
334 ((((_x) & 0xff0000) >> 16) | \
335 (((_x) & 0x00ff00)) | \
336 (((_x) & 0x0000ff) << 16))
340 SCM_DEFINE (scm_native_endianness
, "native-endianness", 0, 0, 0,
342 "Return a symbol denoting the machine's native endianness.")
343 #define FUNC_NAME s_scm_native_endianness
345 return native_endianness
;
349 SCM_DEFINE (scm_bytevector_p
, "bytevector?", 1, 0, 0,
351 "Return true if @var{obj} is a bytevector.")
352 #define FUNC_NAME s_scm_bytevector_p
354 return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_bytevector
,
359 SCM_DEFINE (scm_make_bytevector
, "make-bytevector", 1, 1, 0,
361 "Return a newly allocated bytevector of @var{len} bytes, "
362 "optionally filled with @var{fill}.")
363 #define FUNC_NAME s_scm_make_bytevector
367 signed char c_fill
= '\0';
369 SCM_VALIDATE_UINT_COPY (1, len
, c_len
);
370 if (fill
!= SCM_UNDEFINED
)
374 value
= scm_to_int (fill
);
375 if (SCM_UNLIKELY ((value
< -128) || (value
> 255)))
376 scm_out_of_range (FUNC_NAME
, fill
);
377 c_fill
= (signed char) value
;
380 bv
= make_bytevector (c_len
);
381 if (fill
!= SCM_UNDEFINED
)
384 signed char *contents
;
386 contents
= SCM_BYTEVECTOR_CONTENTS (bv
);
387 for (i
= 0; i
< c_len
; i
++)
388 contents
[i
] = c_fill
;
395 SCM_DEFINE (scm_bytevector_length
, "bytevector-length", 1, 0, 0,
397 "Return the length (in bytes) of @var{bv}.")
398 #define FUNC_NAME s_scm_bytevector_length
400 SCM_VALIDATE_BYTEVECTOR (1, bv
);
402 return (scm_from_uint (SCM_BYTEVECTOR_LENGTH (bv
)));
406 SCM_DEFINE (scm_bytevector_eq_p
, "bytevector=?", 2, 0, 0,
408 "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
409 "have the same length and contents.")
410 #define FUNC_NAME s_scm_bytevector_eq_p
412 SCM result
= SCM_BOOL_F
;
413 unsigned c_len1
, c_len2
;
415 SCM_VALIDATE_BYTEVECTOR (1, bv1
);
416 SCM_VALIDATE_BYTEVECTOR (2, bv2
);
418 c_len1
= SCM_BYTEVECTOR_LENGTH (bv1
);
419 c_len2
= SCM_BYTEVECTOR_LENGTH (bv2
);
421 if (c_len1
== c_len2
)
423 signed char *c_bv1
, *c_bv2
;
425 c_bv1
= SCM_BYTEVECTOR_CONTENTS (bv1
);
426 c_bv2
= SCM_BYTEVECTOR_CONTENTS (bv2
);
428 result
= scm_from_bool (!memcmp (c_bv1
, c_bv2
, c_len1
));
435 SCM_DEFINE (scm_bytevector_fill_x
, "bytevector-fill!", 2, 0, 0,
437 "Fill bytevector @var{bv} with @var{fill}, a byte.")
438 #define FUNC_NAME s_scm_bytevector_fill_x
441 signed char *c_bv
, c_fill
;
443 SCM_VALIDATE_BYTEVECTOR (1, bv
);
444 c_fill
= scm_to_int8 (fill
);
446 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
447 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
449 for (i
= 0; i
< c_len
; i
++)
452 return SCM_UNSPECIFIED
;
456 SCM_DEFINE (scm_bytevector_copy_x
, "bytevector-copy!", 5, 0, 0,
457 (SCM source
, SCM source_start
, SCM target
, SCM target_start
,
459 "Copy @var{len} bytes from @var{source} into @var{target}, "
460 "starting reading from @var{source_start} (a positive index "
461 "within @var{source}) and start writing at "
462 "@var{target_start}.")
463 #define FUNC_NAME s_scm_bytevector_copy_x
465 unsigned c_len
, c_source_len
, c_target_len
;
466 unsigned c_source_start
, c_target_start
;
467 signed char *c_source
, *c_target
;
469 SCM_VALIDATE_BYTEVECTOR (1, source
);
470 SCM_VALIDATE_BYTEVECTOR (3, target
);
472 c_len
= scm_to_uint (len
);
473 c_source_start
= scm_to_uint (source_start
);
474 c_target_start
= scm_to_uint (target_start
);
476 c_source
= SCM_BYTEVECTOR_CONTENTS (source
);
477 c_target
= SCM_BYTEVECTOR_CONTENTS (target
);
478 c_source_len
= SCM_BYTEVECTOR_LENGTH (source
);
479 c_target_len
= SCM_BYTEVECTOR_LENGTH (target
);
481 if (SCM_UNLIKELY (c_source_start
+ c_len
> c_source_len
))
482 scm_out_of_range (FUNC_NAME
, source_start
);
483 if (SCM_UNLIKELY (c_target_start
+ c_len
> c_target_len
))
484 scm_out_of_range (FUNC_NAME
, target_start
);
486 memcpy (c_target
+ c_target_start
,
487 c_source
+ c_source_start
,
490 return SCM_UNSPECIFIED
;
494 SCM_DEFINE (scm_bytevector_copy
, "bytevector-copy", 1, 0, 0,
496 "Return a newly allocated copy of @var{bv}.")
497 #define FUNC_NAME s_scm_bytevector_copy
501 signed char *c_bv
, *c_copy
;
503 SCM_VALIDATE_BYTEVECTOR (1, bv
);
505 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
506 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
508 copy
= make_bytevector (c_len
);
509 c_copy
= SCM_BYTEVECTOR_CONTENTS (copy
);
510 memcpy (c_copy
, c_bv
, c_len
);
516 SCM_DEFINE (scm_uniform_array_to_bytevector
, "uniform-array->bytevector",
517 1, 0, 0, (SCM array
),
518 "Return a newly allocated bytevector whose contents\n"
519 "will be copied from the uniform array @var{array}.")
520 #define FUNC_NAME s_scm_uniform_array_to_bytevector
524 scm_t_array_handle h
;
528 contents
= scm_array_contents (array
, SCM_BOOL_T
);
529 if (scm_is_false (contents
))
530 scm_wrong_type_arg_msg (FUNC_NAME
, 0, array
, "uniform contiguous array");
532 scm_array_get_handle (contents
, &h
);
534 base
= scm_array_handle_uniform_elements (&h
);
535 len
= h
.dims
->inc
* (h
.dims
->ubnd
- h
.dims
->lbnd
+ 1);
536 sz
= scm_array_handle_uniform_element_size (&h
);
538 ret
= make_bytevector (len
* sz
);
539 memcpy (SCM_BYTEVECTOR_CONTENTS (ret
), base
, len
* sz
);
541 scm_array_handle_release (&h
);
548 /* Operations on bytes and octets. */
550 SCM_DEFINE (scm_bytevector_u8_ref
, "bytevector-u8-ref", 2, 0, 0,
552 "Return the octet located at @var{index} in @var{bv}.")
553 #define FUNC_NAME s_scm_bytevector_u8_ref
555 INTEGER_NATIVE_REF (8, unsigned);
559 SCM_DEFINE (scm_bytevector_s8_ref
, "bytevector-s8-ref", 2, 0, 0,
561 "Return the byte located at @var{index} in @var{bv}.")
562 #define FUNC_NAME s_scm_bytevector_s8_ref
564 INTEGER_NATIVE_REF (8, signed);
568 SCM_DEFINE (scm_bytevector_u8_set_x
, "bytevector-u8-set!", 3, 0, 0,
569 (SCM bv
, SCM index
, SCM value
),
570 "Return the octet located at @var{index} in @var{bv}.")
571 #define FUNC_NAME s_scm_bytevector_u8_set_x
573 INTEGER_NATIVE_SET (8, unsigned);
577 SCM_DEFINE (scm_bytevector_s8_set_x
, "bytevector-s8-set!", 3, 0, 0,
578 (SCM bv
, SCM index
, SCM value
),
579 "Return the octet located at @var{index} in @var{bv}.")
580 #define FUNC_NAME s_scm_bytevector_u8_set_x
582 INTEGER_NATIVE_SET (8, signed);
586 #undef OCTET_ACCESSOR_PROLOGUE
589 SCM_DEFINE (scm_bytevector_to_u8_list
, "bytevector->u8-list", 1, 0, 0,
591 "Return a newly allocated list of octets containing the "
592 "contents of @var{bv}.")
593 #define FUNC_NAME s_scm_bytevector_to_u8_list
599 SCM_VALIDATE_BYTEVECTOR (1, bv
);
601 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
602 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
604 lst
= scm_make_list (scm_from_uint (c_len
), SCM_UNSPECIFIED
);
605 for (i
= 0, pair
= lst
;
607 i
++, pair
= SCM_CDR (pair
))
609 SCM_SETCAR (pair
, SCM_I_MAKINUM (c_bv
[i
]));
616 SCM_DEFINE (scm_u8_list_to_bytevector
, "u8-list->bytevector", 1, 0, 0,
618 "Turn @var{lst}, a list of octets, into a bytevector.")
619 #define FUNC_NAME s_scm_u8_list_to_bytevector
625 SCM_VALIDATE_LIST_COPYLEN (1, lst
, c_len
);
627 bv
= make_bytevector (c_len
);
628 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
630 for (i
= 0; i
< c_len
; lst
= SCM_CDR (lst
), i
++)
632 item
= SCM_CAR (lst
);
634 if (SCM_LIKELY (SCM_I_INUMP (item
)))
638 c_item
= SCM_I_INUM (item
);
639 if (SCM_LIKELY ((c_item
>= 0) && (c_item
< 256)))
640 c_bv
[i
] = (unsigned char) c_item
;
651 scm_wrong_type_arg (FUNC_NAME
, 1, item
);
657 /* Compute the two's complement of VALUE (a positive integer) on SIZE octets
658 using (2^(SIZE * 8) - VALUE). */
660 twos_complement (mpz_t value
, size_t size
)
662 unsigned long bit_count
;
664 /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
665 checking on SIZE performed earlier. */
666 bit_count
= (unsigned long) size
<< 3UL;
668 if (SCM_LIKELY (bit_count
< sizeof (unsigned long)))
669 mpz_ui_sub (value
, 1UL << bit_count
, value
);
675 mpz_ui_pow_ui (max
, 2, bit_count
);
676 mpz_sub (value
, max
, value
);
682 bytevector_large_ref (const char *c_bv
, size_t c_size
, int signed_p
,
687 int c_endianness
, negative_p
= 0;
691 if (scm_is_eq (endianness
, scm_sym_big
))
692 negative_p
= c_bv
[0] & 0x80;
694 negative_p
= c_bv
[c_size
- 1] & 0x80;
697 c_endianness
= scm_is_eq (endianness
, scm_sym_big
) ? 1 : -1;
700 mpz_import (c_mpz
, 1 /* 1 word */, 1 /* word order doesn't matter */,
701 c_size
/* word is C_SIZE-byte long */,
703 0 /* nails */, c_bv
);
705 if (signed_p
&& negative_p
)
707 twos_complement (c_mpz
, c_size
);
708 mpz_neg (c_mpz
, c_mpz
);
711 result
= scm_from_mpz (c_mpz
);
712 mpz_clear (c_mpz
); /* FIXME: Needed? */
718 bytevector_large_set (char *c_bv
, size_t c_size
, int signed_p
,
719 SCM value
, SCM endianness
)
722 int c_endianness
, c_sign
, err
= 0;
724 c_endianness
= scm_is_eq (endianness
, scm_sym_big
) ? 1 : -1;
727 scm_to_mpz (value
, c_mpz
);
729 c_sign
= mpz_sgn (c_mpz
);
732 if (SCM_LIKELY (signed_p
))
734 mpz_neg (c_mpz
, c_mpz
);
735 twos_complement (c_mpz
, c_size
);
746 memset (c_bv
, 0, c_size
);
749 size_t word_count
, value_size
;
751 value_size
= (mpz_sizeinbase (c_mpz
, 2) + (8 * c_size
)) / (8 * c_size
);
752 if (SCM_UNLIKELY (value_size
> c_size
))
759 mpz_export (c_bv
, &word_count
, 1 /* word order doesn't matter */,
760 c_size
, c_endianness
,
761 0 /* nails */, c_mpz
);
762 if (SCM_UNLIKELY (word_count
!= 1))
763 /* Shouldn't happen since we already checked with VALUE_SIZE. */
773 #define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \
774 unsigned long c_len, c_index, c_size; \
777 SCM_VALIDATE_BYTEVECTOR (1, bv); \
778 c_index = scm_to_ulong (index); \
779 c_size = scm_to_ulong (size); \
781 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
782 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
784 /* C_SIZE must have its 3 higher bits set to zero so that \
785 multiplying it by 8 yields a number that fits in an \
787 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
788 scm_out_of_range (FUNC_NAME, size); \
789 if (SCM_UNLIKELY (c_index + c_size > c_len)) \
790 scm_out_of_range (FUNC_NAME, index);
793 /* Template of an integer reference function. */
794 #define GENERIC_INTEGER_REF(_sign) \
802 swap = !scm_is_eq (endianness, native_endianness); \
807 _sign char c_value8; \
808 memcpy (&c_value8, c_bv, 1); \
814 INT_TYPE (16, _sign) c_value16; \
815 memcpy (&c_value16, c_bv, 2); \
817 value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \
826 result = SCM_I_MAKINUM ((_sign int) value); \
829 result = bytevector_large_ref ((char *) c_bv, \
830 c_size, SIGNEDNESS (_sign), \
836 bytevector_signed_ref (const char *c_bv
, size_t c_size
, SCM endianness
)
838 GENERIC_INTEGER_REF (signed);
842 bytevector_unsigned_ref (const char *c_bv
, size_t c_size
, SCM endianness
)
844 GENERIC_INTEGER_REF (unsigned);
848 /* Template of an integer assignment function. */
849 #define GENERIC_INTEGER_SET(_sign) \
854 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
857 c_value = SCM_I_INUM (value); \
861 if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \
863 _sign char c_value8; \
864 c_value8 = (_sign char) c_value; \
865 memcpy (c_bv, &c_value8, 1); \
872 if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \
875 INT_TYPE (16, _sign) c_value16; \
877 swap = !scm_is_eq (endianness, native_endianness); \
880 c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \
882 c_value16 = c_value; \
884 memcpy (c_bv, &c_value16, 2); \
898 err = bytevector_large_set (c_bv, c_size, \
899 SIGNEDNESS (_sign), \
900 value, endianness); \
908 scm_out_of_range (FUNC_NAME, value); \
912 bytevector_signed_set (char *c_bv
, size_t c_size
,
913 SCM value
, SCM endianness
,
914 const char *func_name
)
915 #define FUNC_NAME func_name
917 GENERIC_INTEGER_SET (signed);
922 bytevector_unsigned_set (char *c_bv
, size_t c_size
,
923 SCM value
, SCM endianness
,
924 const char *func_name
)
925 #define FUNC_NAME func_name
927 GENERIC_INTEGER_SET (unsigned);
931 #undef GENERIC_INTEGER_SET
932 #undef GENERIC_INTEGER_REF
935 SCM_DEFINE (scm_bytevector_uint_ref
, "bytevector-uint-ref", 4, 0, 0,
936 (SCM bv
, SCM index
, SCM endianness
, SCM size
),
937 "Return the @var{size}-octet long unsigned integer at index "
938 "@var{index} in @var{bv}.")
939 #define FUNC_NAME s_scm_bytevector_uint_ref
941 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
943 return (bytevector_unsigned_ref (&c_bv
[c_index
], c_size
, endianness
));
947 SCM_DEFINE (scm_bytevector_sint_ref
, "bytevector-sint-ref", 4, 0, 0,
948 (SCM bv
, SCM index
, SCM endianness
, SCM size
),
949 "Return the @var{size}-octet long unsigned integer at index "
950 "@var{index} in @var{bv}.")
951 #define FUNC_NAME s_scm_bytevector_sint_ref
953 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
955 return (bytevector_signed_ref (&c_bv
[c_index
], c_size
, endianness
));
959 SCM_DEFINE (scm_bytevector_uint_set_x
, "bytevector-uint-set!", 5, 0, 0,
960 (SCM bv
, SCM index
, SCM value
, SCM endianness
, SCM size
),
961 "Set the @var{size}-octet long unsigned integer at @var{index} "
963 #define FUNC_NAME s_scm_bytevector_uint_set_x
965 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
967 bytevector_unsigned_set (&c_bv
[c_index
], c_size
, value
, endianness
,
970 return SCM_UNSPECIFIED
;
974 SCM_DEFINE (scm_bytevector_sint_set_x
, "bytevector-sint-set!", 5, 0, 0,
975 (SCM bv
, SCM index
, SCM value
, SCM endianness
, SCM size
),
976 "Set the @var{size}-octet long signed integer at @var{index} "
978 #define FUNC_NAME s_scm_bytevector_sint_set_x
980 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
982 bytevector_signed_set (&c_bv
[c_index
], c_size
, value
, endianness
,
985 return SCM_UNSPECIFIED
;
991 /* Operations on integers of arbitrary size. */
993 #define INTEGERS_TO_LIST(_sign) \
995 size_t i, c_len, c_size; \
997 SCM_VALIDATE_BYTEVECTOR (1, bv); \
998 SCM_VALIDATE_SYMBOL (2, endianness); \
999 c_size = scm_to_uint (size); \
1001 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
1002 if (SCM_UNLIKELY (c_len == 0)) \
1004 else if (SCM_UNLIKELY (c_len < c_size)) \
1005 scm_out_of_range (FUNC_NAME, size); \
1010 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1012 lst = scm_make_list (scm_from_uint (c_len / c_size), \
1014 for (i = 0, pair = lst; \
1015 i <= c_len - c_size; \
1016 i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
1019 bytevector_ ## _sign ## _ref (c_bv, c_size, \
1026 SCM_DEFINE (scm_bytevector_to_sint_list
, "bytevector->sint-list",
1028 (SCM bv
, SCM endianness
, SCM size
),
1029 "Return a list of signed integers of @var{size} octets "
1030 "representing the contents of @var{bv}.")
1031 #define FUNC_NAME s_scm_bytevector_to_sint_list
1033 INTEGERS_TO_LIST (signed);
1037 SCM_DEFINE (scm_bytevector_to_uint_list
, "bytevector->uint-list",
1039 (SCM bv
, SCM endianness
, SCM size
),
1040 "Return a list of unsigned integers of @var{size} octets "
1041 "representing the contents of @var{bv}.")
1042 #define FUNC_NAME s_scm_bytevector_to_uint_list
1044 INTEGERS_TO_LIST (unsigned);
1048 #undef INTEGER_TO_LIST
1051 #define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
1055 char *c_bv, *c_bv_ptr; \
1057 SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
1058 SCM_VALIDATE_SYMBOL (2, endianness); \
1059 c_size = scm_to_uint (size); \
1061 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
1062 scm_out_of_range (FUNC_NAME, size); \
1064 bv = make_bytevector (c_len * c_size); \
1065 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1067 for (c_bv_ptr = c_bv; \
1068 !scm_is_null (lst); \
1069 lst = SCM_CDR (lst), c_bv_ptr += c_size) \
1071 bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
1072 SCM_CAR (lst), endianness, \
1079 SCM_DEFINE (scm_uint_list_to_bytevector
, "uint-list->bytevector",
1081 (SCM lst
, SCM endianness
, SCM size
),
1082 "Return a bytevector containing the unsigned integers "
1083 "listed in @var{lst} and encoded on @var{size} octets "
1084 "according to @var{endianness}.")
1085 #define FUNC_NAME s_scm_uint_list_to_bytevector
1087 INTEGER_LIST_TO_BYTEVECTOR (unsigned);
1091 SCM_DEFINE (scm_sint_list_to_bytevector
, "sint-list->bytevector",
1093 (SCM lst
, SCM endianness
, SCM size
),
1094 "Return a bytevector containing the signed integers "
1095 "listed in @var{lst} and encoded on @var{size} octets "
1096 "according to @var{endianness}.")
1097 #define FUNC_NAME s_scm_sint_list_to_bytevector
1099 INTEGER_LIST_TO_BYTEVECTOR (signed);
1103 #undef INTEGER_LIST_TO_BYTEVECTOR
1107 /* Operations on 16-bit integers. */
1109 SCM_DEFINE (scm_bytevector_u16_ref
, "bytevector-u16-ref",
1111 (SCM bv
, SCM index
, SCM endianness
),
1112 "Return the unsigned 16-bit integer from @var{bv} at "
1114 #define FUNC_NAME s_scm_bytevector_u16_ref
1116 INTEGER_REF (16, unsigned);
1120 SCM_DEFINE (scm_bytevector_s16_ref
, "bytevector-s16-ref",
1122 (SCM bv
, SCM index
, SCM endianness
),
1123 "Return the signed 16-bit integer from @var{bv} at "
1125 #define FUNC_NAME s_scm_bytevector_s16_ref
1127 INTEGER_REF (16, signed);
1131 SCM_DEFINE (scm_bytevector_u16_native_ref
, "bytevector-u16-native-ref",
1133 (SCM bv
, SCM index
),
1134 "Return the unsigned 16-bit integer from @var{bv} at "
1135 "@var{index} using the native endianness.")
1136 #define FUNC_NAME s_scm_bytevector_u16_native_ref
1138 INTEGER_NATIVE_REF (16, unsigned);
1142 SCM_DEFINE (scm_bytevector_s16_native_ref
, "bytevector-s16-native-ref",
1144 (SCM bv
, SCM index
),
1145 "Return the unsigned 16-bit integer from @var{bv} at "
1146 "@var{index} using the native endianness.")
1147 #define FUNC_NAME s_scm_bytevector_s16_native_ref
1149 INTEGER_NATIVE_REF (16, signed);
1153 SCM_DEFINE (scm_bytevector_u16_set_x
, "bytevector-u16-set!",
1155 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1156 "Store @var{value} in @var{bv} at @var{index} according to "
1157 "@var{endianness}.")
1158 #define FUNC_NAME s_scm_bytevector_u16_set_x
1160 INTEGER_SET (16, unsigned);
1164 SCM_DEFINE (scm_bytevector_s16_set_x
, "bytevector-s16-set!",
1166 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1167 "Store @var{value} in @var{bv} at @var{index} according to "
1168 "@var{endianness}.")
1169 #define FUNC_NAME s_scm_bytevector_s16_set_x
1171 INTEGER_SET (16, signed);
1175 SCM_DEFINE (scm_bytevector_u16_native_set_x
, "bytevector-u16-native-set!",
1177 (SCM bv
, SCM index
, SCM value
),
1178 "Store the unsigned integer @var{value} at index @var{index} "
1179 "of @var{bv} using the native endianness.")
1180 #define FUNC_NAME s_scm_bytevector_u16_native_set_x
1182 INTEGER_NATIVE_SET (16, unsigned);
1186 SCM_DEFINE (scm_bytevector_s16_native_set_x
, "bytevector-s16-native-set!",
1188 (SCM bv
, SCM index
, SCM value
),
1189 "Store the signed integer @var{value} at index @var{index} "
1190 "of @var{bv} using the native endianness.")
1191 #define FUNC_NAME s_scm_bytevector_s16_native_set_x
1193 INTEGER_NATIVE_SET (16, signed);
1199 /* Operations on 32-bit integers. */
1201 /* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
1202 arbitrary 32-bit integers. Thus we fall back to using the
1203 `large_{ref,set}' variants on 32-bit machines. */
1205 #define LARGE_INTEGER_REF(_len, _sign) \
1206 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1207 SCM_VALIDATE_SYMBOL (3, endianness); \
1209 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1210 SIGNEDNESS (_sign), endianness));
1212 #define LARGE_INTEGER_SET(_len, _sign) \
1214 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1215 SCM_VALIDATE_SYMBOL (4, endianness); \
1217 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1218 SIGNEDNESS (_sign), value, endianness); \
1219 if (SCM_UNLIKELY (err)) \
1220 scm_out_of_range (FUNC_NAME, value); \
1222 return SCM_UNSPECIFIED;
1224 #define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
1225 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1226 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1227 SIGNEDNESS (_sign), native_endianness));
1229 #define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
1231 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1233 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1234 SIGNEDNESS (_sign), value, \
1235 native_endianness); \
1236 if (SCM_UNLIKELY (err)) \
1237 scm_out_of_range (FUNC_NAME, value); \
1239 return SCM_UNSPECIFIED;
1242 SCM_DEFINE (scm_bytevector_u32_ref
, "bytevector-u32-ref",
1244 (SCM bv
, SCM index
, SCM endianness
),
1245 "Return the unsigned 32-bit integer from @var{bv} at "
1247 #define FUNC_NAME s_scm_bytevector_u32_ref
1249 #if SIZEOF_VOID_P > 4
1250 INTEGER_REF (32, unsigned);
1252 LARGE_INTEGER_REF (32, unsigned);
1257 SCM_DEFINE (scm_bytevector_s32_ref
, "bytevector-s32-ref",
1259 (SCM bv
, SCM index
, SCM endianness
),
1260 "Return the signed 32-bit integer from @var{bv} at "
1262 #define FUNC_NAME s_scm_bytevector_s32_ref
1264 #if SIZEOF_VOID_P > 4
1265 INTEGER_REF (32, signed);
1267 LARGE_INTEGER_REF (32, signed);
1272 SCM_DEFINE (scm_bytevector_u32_native_ref
, "bytevector-u32-native-ref",
1274 (SCM bv
, SCM index
),
1275 "Return the unsigned 32-bit integer from @var{bv} at "
1276 "@var{index} using the native endianness.")
1277 #define FUNC_NAME s_scm_bytevector_u32_native_ref
1279 #if SIZEOF_VOID_P > 4
1280 INTEGER_NATIVE_REF (32, unsigned);
1282 LARGE_INTEGER_NATIVE_REF (32, unsigned);
1287 SCM_DEFINE (scm_bytevector_s32_native_ref
, "bytevector-s32-native-ref",
1289 (SCM bv
, SCM index
),
1290 "Return the unsigned 32-bit integer from @var{bv} at "
1291 "@var{index} using the native endianness.")
1292 #define FUNC_NAME s_scm_bytevector_s32_native_ref
1294 #if SIZEOF_VOID_P > 4
1295 INTEGER_NATIVE_REF (32, signed);
1297 LARGE_INTEGER_NATIVE_REF (32, signed);
1302 SCM_DEFINE (scm_bytevector_u32_set_x
, "bytevector-u32-set!",
1304 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1305 "Store @var{value} in @var{bv} at @var{index} according to "
1306 "@var{endianness}.")
1307 #define FUNC_NAME s_scm_bytevector_u32_set_x
1309 #if SIZEOF_VOID_P > 4
1310 INTEGER_SET (32, unsigned);
1312 LARGE_INTEGER_SET (32, unsigned);
1317 SCM_DEFINE (scm_bytevector_s32_set_x
, "bytevector-s32-set!",
1319 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1320 "Store @var{value} in @var{bv} at @var{index} according to "
1321 "@var{endianness}.")
1322 #define FUNC_NAME s_scm_bytevector_s32_set_x
1324 #if SIZEOF_VOID_P > 4
1325 INTEGER_SET (32, signed);
1327 LARGE_INTEGER_SET (32, signed);
1332 SCM_DEFINE (scm_bytevector_u32_native_set_x
, "bytevector-u32-native-set!",
1334 (SCM bv
, SCM index
, SCM value
),
1335 "Store the unsigned integer @var{value} at index @var{index} "
1336 "of @var{bv} using the native endianness.")
1337 #define FUNC_NAME s_scm_bytevector_u32_native_set_x
1339 #if SIZEOF_VOID_P > 4
1340 INTEGER_NATIVE_SET (32, unsigned);
1342 LARGE_INTEGER_NATIVE_SET (32, unsigned);
1347 SCM_DEFINE (scm_bytevector_s32_native_set_x
, "bytevector-s32-native-set!",
1349 (SCM bv
, SCM index
, SCM value
),
1350 "Store the signed integer @var{value} at index @var{index} "
1351 "of @var{bv} using the native endianness.")
1352 #define FUNC_NAME s_scm_bytevector_s32_native_set_x
1354 #if SIZEOF_VOID_P > 4
1355 INTEGER_NATIVE_SET (32, signed);
1357 LARGE_INTEGER_NATIVE_SET (32, signed);
1364 /* Operations on 64-bit integers. */
1366 /* For 64-bit integers, we use only the `large_{ref,set}' variant. */
1368 SCM_DEFINE (scm_bytevector_u64_ref
, "bytevector-u64-ref",
1370 (SCM bv
, SCM index
, SCM endianness
),
1371 "Return the unsigned 64-bit integer from @var{bv} at "
1373 #define FUNC_NAME s_scm_bytevector_u64_ref
1375 LARGE_INTEGER_REF (64, unsigned);
1379 SCM_DEFINE (scm_bytevector_s64_ref
, "bytevector-s64-ref",
1381 (SCM bv
, SCM index
, SCM endianness
),
1382 "Return the signed 64-bit integer from @var{bv} at "
1384 #define FUNC_NAME s_scm_bytevector_s64_ref
1386 LARGE_INTEGER_REF (64, signed);
1390 SCM_DEFINE (scm_bytevector_u64_native_ref
, "bytevector-u64-native-ref",
1392 (SCM bv
, SCM index
),
1393 "Return the unsigned 64-bit integer from @var{bv} at "
1394 "@var{index} using the native endianness.")
1395 #define FUNC_NAME s_scm_bytevector_u64_native_ref
1397 LARGE_INTEGER_NATIVE_REF (64, unsigned);
1401 SCM_DEFINE (scm_bytevector_s64_native_ref
, "bytevector-s64-native-ref",
1403 (SCM bv
, SCM index
),
1404 "Return the unsigned 64-bit integer from @var{bv} at "
1405 "@var{index} using the native endianness.")
1406 #define FUNC_NAME s_scm_bytevector_s64_native_ref
1408 LARGE_INTEGER_NATIVE_REF (64, signed);
1412 SCM_DEFINE (scm_bytevector_u64_set_x
, "bytevector-u64-set!",
1414 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1415 "Store @var{value} in @var{bv} at @var{index} according to "
1416 "@var{endianness}.")
1417 #define FUNC_NAME s_scm_bytevector_u64_set_x
1419 LARGE_INTEGER_SET (64, unsigned);
1423 SCM_DEFINE (scm_bytevector_s64_set_x
, "bytevector-s64-set!",
1425 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1426 "Store @var{value} in @var{bv} at @var{index} according to "
1427 "@var{endianness}.")
1428 #define FUNC_NAME s_scm_bytevector_s64_set_x
1430 LARGE_INTEGER_SET (64, signed);
1434 SCM_DEFINE (scm_bytevector_u64_native_set_x
, "bytevector-u64-native-set!",
1436 (SCM bv
, SCM index
, SCM value
),
1437 "Store the unsigned integer @var{value} at index @var{index} "
1438 "of @var{bv} using the native endianness.")
1439 #define FUNC_NAME s_scm_bytevector_u64_native_set_x
1441 LARGE_INTEGER_NATIVE_SET (64, unsigned);
1445 SCM_DEFINE (scm_bytevector_s64_native_set_x
, "bytevector-s64-native-set!",
1447 (SCM bv
, SCM index
, SCM value
),
1448 "Store the signed integer @var{value} at index @var{index} "
1449 "of @var{bv} using the native endianness.")
1450 #define FUNC_NAME s_scm_bytevector_s64_native_set_x
1452 LARGE_INTEGER_NATIVE_SET (64, signed);
1458 /* Operations on IEEE-754 numbers. */
1460 /* There are two possible word endians, visible in glibc's <ieee754.h>.
1461 However, in R6RS, when the endianness is `little', little endian is
1462 assumed for both the byte order and the word order. This is clear from
1463 Section 2.1 of R6RS-lib (in response to
1464 http://www.r6rs.org/formal-comments/comment-187.txt). */
1467 /* Convert to/from a floating-point number with different endianness. This
1468 method is probably not the most efficient but it should be portable. */
1471 float_to_foreign_endianness (union scm_ieee754_float
*target
,
1474 union scm_ieee754_float src
;
1478 #ifdef WORDS_BIGENDIAN
1479 /* Assuming little endian for both byte and word order. */
1480 target
->little_endian
.negative
= src
.big_endian
.negative
;
1481 target
->little_endian
.exponent
= src
.big_endian
.exponent
;
1482 target
->little_endian
.mantissa
= src
.big_endian
.mantissa
;
1484 target
->big_endian
.negative
= src
.little_endian
.negative
;
1485 target
->big_endian
.exponent
= src
.little_endian
.exponent
;
1486 target
->big_endian
.mantissa
= src
.little_endian
.mantissa
;
1491 float_from_foreign_endianness (const union scm_ieee754_float
*source
)
1493 union scm_ieee754_float result
;
1495 #ifdef WORDS_BIGENDIAN
1496 /* Assuming little endian for both byte and word order. */
1497 result
.big_endian
.negative
= source
->little_endian
.negative
;
1498 result
.big_endian
.exponent
= source
->little_endian
.exponent
;
1499 result
.big_endian
.mantissa
= source
->little_endian
.mantissa
;
1501 result
.little_endian
.negative
= source
->big_endian
.negative
;
1502 result
.little_endian
.exponent
= source
->big_endian
.exponent
;
1503 result
.little_endian
.mantissa
= source
->big_endian
.mantissa
;
1510 double_to_foreign_endianness (union scm_ieee754_double
*target
,
1513 union scm_ieee754_double src
;
1517 #ifdef WORDS_BIGENDIAN
1518 /* Assuming little endian for both byte and word order. */
1519 target
->little_little_endian
.negative
= src
.big_endian
.negative
;
1520 target
->little_little_endian
.exponent
= src
.big_endian
.exponent
;
1521 target
->little_little_endian
.mantissa0
= src
.big_endian
.mantissa0
;
1522 target
->little_little_endian
.mantissa1
= src
.big_endian
.mantissa1
;
1524 target
->big_endian
.negative
= src
.little_little_endian
.negative
;
1525 target
->big_endian
.exponent
= src
.little_little_endian
.exponent
;
1526 target
->big_endian
.mantissa0
= src
.little_little_endian
.mantissa0
;
1527 target
->big_endian
.mantissa1
= src
.little_little_endian
.mantissa1
;
1531 static inline double
1532 double_from_foreign_endianness (const union scm_ieee754_double
*source
)
1534 union scm_ieee754_double result
;
1536 #ifdef WORDS_BIGENDIAN
1537 /* Assuming little endian for both byte and word order. */
1538 result
.big_endian
.negative
= source
->little_little_endian
.negative
;
1539 result
.big_endian
.exponent
= source
->little_little_endian
.exponent
;
1540 result
.big_endian
.mantissa0
= source
->little_little_endian
.mantissa0
;
1541 result
.big_endian
.mantissa1
= source
->little_little_endian
.mantissa1
;
1543 result
.little_little_endian
.negative
= source
->big_endian
.negative
;
1544 result
.little_little_endian
.exponent
= source
->big_endian
.exponent
;
1545 result
.little_little_endian
.mantissa0
= source
->big_endian
.mantissa0
;
1546 result
.little_little_endian
.mantissa1
= source
->big_endian
.mantissa1
;
1552 /* Template macros to abstract over doubles and floats.
1553 XXX: Guile can only convert to/from doubles. */
1554 #define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type
1555 #define IEEE754_TO_SCM(_c_type) scm_from_double
1556 #define IEEE754_FROM_SCM(_c_type) scm_to_double
1557 #define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
1558 _c_type ## _from_foreign_endianness
1559 #define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
1560 _c_type ## _to_foreign_endianness
1563 /* Templace getters and setters. */
1565 #define IEEE754_ACCESSOR_PROLOGUE(_type) \
1566 INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
1568 #define IEEE754_REF(_type) \
1571 IEEE754_ACCESSOR_PROLOGUE (_type); \
1572 SCM_VALIDATE_SYMBOL (3, endianness); \
1574 if (scm_is_eq (endianness, native_endianness)) \
1575 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1578 IEEE754_UNION (_type) c_raw; \
1580 memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
1582 IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
1585 return (IEEE754_TO_SCM (_type) (c_result));
1587 #define IEEE754_NATIVE_REF(_type) \
1590 IEEE754_ACCESSOR_PROLOGUE (_type); \
1592 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1593 return (IEEE754_TO_SCM (_type) (c_result));
1595 #define IEEE754_SET(_type) \
1598 IEEE754_ACCESSOR_PROLOGUE (_type); \
1599 SCM_VALIDATE_REAL (3, value); \
1600 SCM_VALIDATE_SYMBOL (4, endianness); \
1601 c_value = IEEE754_FROM_SCM (_type) (value); \
1603 if (scm_is_eq (endianness, native_endianness)) \
1604 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1607 IEEE754_UNION (_type) c_raw; \
1609 IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
1610 memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
1613 return SCM_UNSPECIFIED;
1615 #define IEEE754_NATIVE_SET(_type) \
1618 IEEE754_ACCESSOR_PROLOGUE (_type); \
1619 SCM_VALIDATE_REAL (3, value); \
1620 c_value = IEEE754_FROM_SCM (_type) (value); \
1622 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1623 return SCM_UNSPECIFIED;
1626 /* Single precision. */
1628 SCM_DEFINE (scm_bytevector_ieee_single_ref
,
1629 "bytevector-ieee-single-ref",
1631 (SCM bv
, SCM index
, SCM endianness
),
1632 "Return the IEEE-754 single from @var{bv} at "
1634 #define FUNC_NAME s_scm_bytevector_ieee_single_ref
1636 IEEE754_REF (float);
1640 SCM_DEFINE (scm_bytevector_ieee_single_native_ref
,
1641 "bytevector-ieee-single-native-ref",
1643 (SCM bv
, SCM index
),
1644 "Return the IEEE-754 single from @var{bv} at "
1645 "@var{index} using the native endianness.")
1646 #define FUNC_NAME s_scm_bytevector_ieee_single_native_ref
1648 IEEE754_NATIVE_REF (float);
1652 SCM_DEFINE (scm_bytevector_ieee_single_set_x
,
1653 "bytevector-ieee-single-set!",
1655 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1656 "Store real @var{value} in @var{bv} at @var{index} according to "
1657 "@var{endianness}.")
1658 #define FUNC_NAME s_scm_bytevector_ieee_single_set_x
1660 IEEE754_SET (float);
1664 SCM_DEFINE (scm_bytevector_ieee_single_native_set_x
,
1665 "bytevector-ieee-single-native-set!",
1667 (SCM bv
, SCM index
, SCM value
),
1668 "Store the real @var{value} at index @var{index} "
1669 "of @var{bv} using the native endianness.")
1670 #define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x
1672 IEEE754_NATIVE_SET (float);
1677 /* Double precision. */
1679 SCM_DEFINE (scm_bytevector_ieee_double_ref
,
1680 "bytevector-ieee-double-ref",
1682 (SCM bv
, SCM index
, SCM endianness
),
1683 "Return the IEEE-754 double from @var{bv} at "
1685 #define FUNC_NAME s_scm_bytevector_ieee_double_ref
1687 IEEE754_REF (double);
1691 SCM_DEFINE (scm_bytevector_ieee_double_native_ref
,
1692 "bytevector-ieee-double-native-ref",
1694 (SCM bv
, SCM index
),
1695 "Return the IEEE-754 double from @var{bv} at "
1696 "@var{index} using the native endianness.")
1697 #define FUNC_NAME s_scm_bytevector_ieee_double_native_ref
1699 IEEE754_NATIVE_REF (double);
1703 SCM_DEFINE (scm_bytevector_ieee_double_set_x
,
1704 "bytevector-ieee-double-set!",
1706 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1707 "Store real @var{value} in @var{bv} at @var{index} according to "
1708 "@var{endianness}.")
1709 #define FUNC_NAME s_scm_bytevector_ieee_double_set_x
1711 IEEE754_SET (double);
1715 SCM_DEFINE (scm_bytevector_ieee_double_native_set_x
,
1716 "bytevector-ieee-double-native-set!",
1718 (SCM bv
, SCM index
, SCM value
),
1719 "Store the real @var{value} at index @var{index} "
1720 "of @var{bv} using the native endianness.")
1721 #define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x
1723 IEEE754_NATIVE_SET (double);
1728 #undef IEEE754_UNION
1729 #undef IEEE754_TO_SCM
1730 #undef IEEE754_FROM_SCM
1731 #undef IEEE754_FROM_FOREIGN_ENDIANNESS
1732 #undef IEEE754_TO_FOREIGN_ENDIANNESS
1734 #undef IEEE754_NATIVE_REF
1736 #undef IEEE754_NATIVE_SET
1739 /* Operations on strings. */
1742 /* Produce a function that returns the length of a UTF-encoded string. */
1743 #define UTF_STRLEN_FUNCTION(_utf_width) \
1744 static inline size_t \
1745 utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
1748 const uint ## _utf_width ## _t *ptr; \
1756 return (len * ((_utf_width) / 8)); \
1759 UTF_STRLEN_FUNCTION (8)
1762 /* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
1763 #define UTF_STRLEN(_utf_width, _str) \
1764 utf ## _utf_width ## _strlen (_str)
1766 /* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
1767 ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
1770 utf_encoding_name (char *name
, size_t utf_width
, SCM endianness
)
1772 strcpy (name
, "UTF-");
1773 strcat (name
, ((utf_width
== 8)
1775 : ((utf_width
== 16)
1777 : ((utf_width
== 32)
1781 ((scm_is_eq (endianness
, scm_sym_big
))
1783 : ((scm_is_eq (endianness
, scm_sym_little
))
1788 /* Maximum length of a UTF encoding name. */
1789 #define MAX_UTF_ENCODING_NAME_LEN 16
1791 /* Produce the body of a `string->utf' function. */
1792 #define STRING_TO_UTF(_utf_width) \
1796 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1797 char *c_utf = NULL, *c_locale; \
1798 size_t c_strlen, c_raw_strlen, c_utf_len = 0; \
1800 SCM_VALIDATE_STRING (1, str); \
1801 if (endianness == SCM_UNDEFINED) \
1802 endianness = scm_sym_big; \
1804 SCM_VALIDATE_SYMBOL (2, endianness); \
1806 c_strlen = scm_c_string_length (str); \
1807 c_raw_strlen = c_strlen * ((_utf_width) / 8); \
1810 c_str = (char *) alloca (c_raw_strlen + 1); \
1811 c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \
1813 while (c_raw_strlen > c_strlen); \
1814 c_str[c_raw_strlen] = '\0'; \
1816 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1818 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1819 strcpy (c_locale, locale_charset ()); \
1821 err = mem_iconveh (c_str, c_raw_strlen, \
1822 c_locale, c_utf_name, \
1823 iconveh_question_mark, NULL, \
1824 &c_utf, &c_utf_len); \
1825 if (SCM_UNLIKELY (err)) \
1826 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1827 scm_list_1 (str), err); \
1829 /* C_UTF is null-terminated. */ \
1830 utf = scm_c_take_bytevector ((signed char *) c_utf, \
1837 SCM_DEFINE (scm_string_to_utf8
, "string->utf8",
1840 "Return a newly allocated bytevector that contains the UTF-8 "
1841 "encoding of @var{str}.")
1842 #define FUNC_NAME s_scm_string_to_utf8
1847 size_t c_strlen
, c_raw_strlen
;
1849 SCM_VALIDATE_STRING (1, str
);
1851 c_strlen
= scm_c_string_length (str
);
1852 c_raw_strlen
= c_strlen
;
1855 c_str
= (char *) alloca (c_raw_strlen
+ 1);
1856 c_raw_strlen
= scm_to_locale_stringbuf (str
, c_str
, c_strlen
);
1858 while (c_raw_strlen
> c_strlen
);
1859 c_str
[c_raw_strlen
] = '\0';
1861 c_utf
= u8_strconv_from_locale (c_str
);
1862 if (SCM_UNLIKELY (c_utf
== NULL
))
1863 scm_syserror (FUNC_NAME
);
1865 /* C_UTF is null-terminated. */
1866 utf
= scm_c_take_bytevector ((signed char *) c_utf
,
1867 UTF_STRLEN (8, c_utf
));
1873 SCM_DEFINE (scm_string_to_utf16
, "string->utf16",
1875 (SCM str
, SCM endianness
),
1876 "Return a newly allocated bytevector that contains the UTF-16 "
1877 "encoding of @var{str}.")
1878 #define FUNC_NAME s_scm_string_to_utf16
1884 SCM_DEFINE (scm_string_to_utf32
, "string->utf32",
1886 (SCM str
, SCM endianness
),
1887 "Return a newly allocated bytevector that contains the UTF-32 "
1888 "encoding of @var{str}.")
1889 #define FUNC_NAME s_scm_string_to_utf32
1896 /* Produce the body of a function that converts a UTF-encoded bytevector to a
1898 #define UTF_TO_STRING(_utf_width) \
1899 SCM str = SCM_BOOL_F; \
1901 char *c_str = NULL, *c_locale; \
1902 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1903 const char *c_utf; \
1904 size_t c_strlen = 0, c_utf_len; \
1906 SCM_VALIDATE_BYTEVECTOR (1, utf); \
1907 if (endianness == SCM_UNDEFINED) \
1908 endianness = scm_sym_big; \
1910 SCM_VALIDATE_SYMBOL (2, endianness); \
1912 c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \
1913 c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
1914 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1916 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1917 strcpy (c_locale, locale_charset ()); \
1919 err = mem_iconveh (c_utf, c_utf_len, \
1920 c_utf_name, c_locale, \
1921 iconveh_question_mark, NULL, \
1922 &c_str, &c_strlen); \
1923 if (SCM_UNLIKELY (err)) \
1924 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
1925 scm_list_1 (utf), err); \
1927 /* C_STR is null-terminated. */ \
1928 str = scm_take_locale_stringn (c_str, c_strlen); \
1933 SCM_DEFINE (scm_utf8_to_string
, "utf8->string",
1936 "Return a newly allocate string that contains from the UTF-8-"
1937 "encoded contents of bytevector @var{utf}.")
1938 #define FUNC_NAME s_scm_utf8_to_string
1942 char *c_str
= NULL
, *c_locale
;
1944 size_t c_utf_len
, c_strlen
= 0;
1946 SCM_VALIDATE_BYTEVECTOR (1, utf
);
1948 c_utf_len
= SCM_BYTEVECTOR_LENGTH (utf
);
1950 c_locale
= (char *) alloca (strlen (locale_charset ()) + 1);
1951 strcpy (c_locale
, locale_charset ());
1953 c_utf
= (char *) SCM_BYTEVECTOR_CONTENTS (utf
);
1954 err
= mem_iconveh (c_utf
, c_utf_len
,
1956 iconveh_question_mark
, NULL
,
1958 if (SCM_UNLIKELY (err
))
1959 scm_syserror_msg (FUNC_NAME
, "failed to convert to string: ~A",
1960 scm_list_1 (utf
), err
);
1962 /* C_STR is null-terminated. */
1963 str
= scm_take_locale_stringn (c_str
, c_strlen
);
1969 SCM_DEFINE (scm_utf16_to_string
, "utf16->string",
1971 (SCM utf
, SCM endianness
),
1972 "Return a newly allocate string that contains from the UTF-16-"
1973 "encoded contents of bytevector @var{utf}.")
1974 #define FUNC_NAME s_scm_utf16_to_string
1980 SCM_DEFINE (scm_utf32_to_string
, "utf32->string",
1982 (SCM utf
, SCM endianness
),
1983 "Return a newly allocate string that contains from the UTF-32-"
1984 "encoded contents of bytevector @var{utf}.")
1985 #define FUNC_NAME s_scm_utf32_to_string
1993 /* Initialization. */
1996 scm_init_bytevectors (void)
1998 #include "libguile/bytevectors.x"
2000 #ifdef WORDS_BIGENDIAN
2001 native_endianness
= scm_sym_big
;
2003 native_endianness
= scm_sym_little
;
2006 scm_endianness_big
= scm_sym_big
;
2007 scm_endianness_little
= scm_sym_little
;
2009 scm_null_bytevector
=
2010 scm_gc_protect_object (make_bytevector_from_buffer (0, NULL
));