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 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
28 #include "libguile/_scm.h"
29 #include "libguile/bytevectors.h"
30 #include "libguile/strings.h"
31 #include "libguile/validate.h"
32 #include "libguile/ieee-754.h"
33 #include "libguile/unif.h"
34 #include "libguile/srfi-4.h"
37 #include <striconveh.h>
43 /* Assuming 32-bit longs. */
44 # define ULONG_MAX 4294967295UL
53 /* Convenience macros. These are used by the various templates (macros) that
54 are parameterized by integer signedness. */
55 #define INT8_T_signed scm_t_int8
56 #define INT8_T_unsigned scm_t_uint8
57 #define INT16_T_signed scm_t_int16
58 #define INT16_T_unsigned scm_t_uint16
59 #define INT32_T_signed scm_t_int32
60 #define INT32_T_unsigned scm_t_uint32
61 #define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L))
62 #define is_unsigned_int8(_x) ((_x) <= 255UL)
63 #define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
64 #define is_unsigned_int16(_x) ((_x) <= 65535UL)
65 #define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L))
66 #define is_unsigned_int32(_x) ((_x) <= 4294967295UL)
67 #define SIGNEDNESS_signed 1
68 #define SIGNEDNESS_unsigned 0
70 #define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign
71 #define INT_SWAP(_size) bswap_ ## _size
72 #define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
73 #define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
76 #define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \
77 unsigned c_len, c_index; \
80 SCM_VALIDATE_BYTEVECTOR (1, bv); \
81 c_index = scm_to_uint (index); \
83 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
84 c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \
86 if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
87 scm_out_of_range (FUNC_NAME, index);
89 /* Template for fixed-size integer access (only 8, 16 or 32-bit). */
90 #define INTEGER_REF(_len, _sign) \
93 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
94 SCM_VALIDATE_SYMBOL (3, endianness); \
97 INT_TYPE (_len, _sign) c_result; \
99 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
100 if (!scm_is_eq (endianness, native_endianness)) \
101 c_result = INT_SWAP (_len) (c_result); \
103 result = SCM_I_MAKINUM (c_result); \
108 /* Template for fixed-size integer access using the native endianness. */
109 #define INTEGER_NATIVE_REF(_len, _sign) \
112 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
115 INT_TYPE (_len, _sign) c_result; \
117 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
118 result = SCM_I_MAKINUM (c_result); \
123 /* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
124 #define INTEGER_SET(_len, _sign) \
125 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
126 SCM_VALIDATE_SYMBOL (3, endianness); \
129 _sign long c_value; \
130 INT_TYPE (_len, _sign) c_value_short; \
132 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
133 scm_wrong_type_arg (FUNC_NAME, 3, value); \
135 c_value = SCM_I_INUM (value); \
136 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
137 scm_out_of_range (FUNC_NAME, value); \
139 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
140 if (!scm_is_eq (endianness, native_endianness)) \
141 c_value_short = INT_SWAP (_len) (c_value_short); \
143 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
146 return SCM_UNSPECIFIED;
148 /* Template for fixed-size integer modification using the native
150 #define INTEGER_NATIVE_SET(_len, _sign) \
151 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
154 _sign long c_value; \
155 INT_TYPE (_len, _sign) c_value_short; \
157 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
158 scm_wrong_type_arg (FUNC_NAME, 3, value); \
160 c_value = SCM_I_INUM (value); \
161 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
162 scm_out_of_range (FUNC_NAME, value); \
164 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
166 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
169 return SCM_UNSPECIFIED;
173 /* Bytevector type. */
175 SCM_GLOBAL_SMOB (scm_tc16_bytevector
, "r6rs-bytevector", 0);
177 #define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
178 SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len))
179 #define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
180 SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf))
182 /* The empty bytevector. */
183 SCM scm_null_bytevector
= SCM_UNSPECIFIED
;
187 make_bytevector_from_buffer (unsigned len
, signed char *contents
)
189 /* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */
190 SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector
, len
, contents
);
194 make_bytevector (unsigned len
)
198 if (SCM_UNLIKELY (len
== 0))
199 bv
= scm_null_bytevector
;
202 signed char *contents
= NULL
;
204 if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len
))
205 contents
= (signed char *) scm_gc_malloc (len
, SCM_GC_BYTEVECTOR
);
207 bv
= make_bytevector_from_buffer (len
, contents
);
213 /* Return a new bytevector of size LEN octets. */
215 scm_c_make_bytevector (unsigned len
)
217 return (make_bytevector (len
));
220 /* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
221 by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
223 scm_c_take_bytevector (signed char *contents
, unsigned len
)
227 if (SCM_UNLIKELY (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len
)))
229 /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */
232 bv
= make_bytevector (len
);
233 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
234 memcpy (c_bv
, contents
, len
);
235 scm_gc_free (contents
, len
, SCM_GC_BYTEVECTOR
);
238 bv
= make_bytevector_from_buffer (len
, contents
);
243 /* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
244 size) and return BV. */
246 scm_i_shrink_bytevector (SCM bv
, unsigned c_new_len
)
248 if (!SCM_BYTEVECTOR_INLINE_P (bv
))
251 signed char *c_bv
, *c_new_bv
;
253 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
254 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
256 SCM_BYTEVECTOR_SET_LENGTH (bv
, c_new_len
);
258 if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len
))
260 /* Copy to the in-line buffer and free the current buffer. */
261 c_new_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
262 memcpy (c_new_bv
, c_bv
, c_new_len
);
263 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
267 /* Resize the existing buffer. */
268 c_new_bv
= scm_gc_realloc (c_bv
, c_len
, c_new_len
,
270 SCM_BYTEVECTOR_SET_CONTENTS (bv
, c_new_bv
);
277 SCM_SMOB_PRINT (scm_tc16_bytevector
, print_bytevector
,
283 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
284 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
286 scm_puts ("#vu8(", port
);
287 for (i
= 0; i
< c_len
; i
++)
290 scm_putc (' ', port
);
292 scm_uintprint (c_bv
[i
], 10, port
);
295 scm_putc (')', port
);
297 /* Make GCC think we use it. */
298 scm_remember_upto_here ((SCM
) pstate
);
303 SCM_SMOB_EQUALP (scm_tc16_bytevector
, bytevector_equal_p
, bv1
, bv2
)
305 return scm_bytevector_eq_p (bv1
, bv2
);
308 SCM_SMOB_FREE (scm_tc16_bytevector
, free_bytevector
, bv
)
311 if (!SCM_BYTEVECTOR_INLINE_P (bv
))
316 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
317 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
319 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
327 /* General operations. */
329 SCM_SYMBOL (scm_sym_big
, "big");
330 SCM_SYMBOL (scm_sym_little
, "little");
332 SCM scm_endianness_big
, scm_endianness_little
;
334 /* Host endianness (a symbol). */
335 static SCM native_endianness
= SCM_UNSPECIFIED
;
339 # define bswap_24(_x) \
340 ((((_x) & 0xff0000) >> 16) | \
341 (((_x) & 0x00ff00)) | \
342 (((_x) & 0x0000ff) << 16))
346 SCM_DEFINE (scm_native_endianness
, "native-endianness", 0, 0, 0,
348 "Return a symbol denoting the machine's native endianness.")
349 #define FUNC_NAME s_scm_native_endianness
351 return native_endianness
;
355 SCM_DEFINE (scm_bytevector_p
, "bytevector?", 1, 0, 0,
357 "Return true if @var{obj} is a bytevector.")
358 #define FUNC_NAME s_scm_bytevector_p
360 return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_bytevector
,
365 SCM_DEFINE (scm_make_bytevector
, "make-bytevector", 1, 1, 0,
367 "Return a newly allocated bytevector of @var{len} bytes, "
368 "optionally filled with @var{fill}.")
369 #define FUNC_NAME s_scm_make_bytevector
373 signed char c_fill
= '\0';
375 SCM_VALIDATE_UINT_COPY (1, len
, c_len
);
376 if (fill
!= SCM_UNDEFINED
)
380 value
= scm_to_int (fill
);
381 if (SCM_UNLIKELY ((value
< -128) || (value
> 255)))
382 scm_out_of_range (FUNC_NAME
, fill
);
383 c_fill
= (signed char) value
;
386 bv
= make_bytevector (c_len
);
387 if (fill
!= SCM_UNDEFINED
)
390 signed char *contents
;
392 contents
= SCM_BYTEVECTOR_CONTENTS (bv
);
393 for (i
= 0; i
< c_len
; i
++)
394 contents
[i
] = c_fill
;
401 SCM_DEFINE (scm_bytevector_length
, "bytevector-length", 1, 0, 0,
403 "Return the length (in bytes) of @var{bv}.")
404 #define FUNC_NAME s_scm_bytevector_length
406 SCM_VALIDATE_BYTEVECTOR (1, bv
);
408 return (scm_from_uint (SCM_BYTEVECTOR_LENGTH (bv
)));
412 SCM_DEFINE (scm_bytevector_eq_p
, "bytevector=?", 2, 0, 0,
414 "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
415 "have the same length and contents.")
416 #define FUNC_NAME s_scm_bytevector_eq_p
418 SCM result
= SCM_BOOL_F
;
419 unsigned c_len1
, c_len2
;
421 SCM_VALIDATE_BYTEVECTOR (1, bv1
);
422 SCM_VALIDATE_BYTEVECTOR (2, bv2
);
424 c_len1
= SCM_BYTEVECTOR_LENGTH (bv1
);
425 c_len2
= SCM_BYTEVECTOR_LENGTH (bv2
);
427 if (c_len1
== c_len2
)
429 signed char *c_bv1
, *c_bv2
;
431 c_bv1
= SCM_BYTEVECTOR_CONTENTS (bv1
);
432 c_bv2
= SCM_BYTEVECTOR_CONTENTS (bv2
);
434 result
= scm_from_bool (!memcmp (c_bv1
, c_bv2
, c_len1
));
441 SCM_DEFINE (scm_bytevector_fill_x
, "bytevector-fill!", 2, 0, 0,
443 "Fill bytevector @var{bv} with @var{fill}, a byte.")
444 #define FUNC_NAME s_scm_bytevector_fill_x
447 signed char *c_bv
, c_fill
;
449 SCM_VALIDATE_BYTEVECTOR (1, bv
);
450 c_fill
= scm_to_int8 (fill
);
452 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
453 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
455 for (i
= 0; i
< c_len
; i
++)
458 return SCM_UNSPECIFIED
;
462 SCM_DEFINE (scm_bytevector_copy_x
, "bytevector-copy!", 5, 0, 0,
463 (SCM source
, SCM source_start
, SCM target
, SCM target_start
,
465 "Copy @var{len} bytes from @var{source} into @var{target}, "
466 "starting reading from @var{source_start} (a positive index "
467 "within @var{source}) and start writing at "
468 "@var{target_start}.")
469 #define FUNC_NAME s_scm_bytevector_copy_x
471 unsigned c_len
, c_source_len
, c_target_len
;
472 unsigned c_source_start
, c_target_start
;
473 signed char *c_source
, *c_target
;
475 SCM_VALIDATE_BYTEVECTOR (1, source
);
476 SCM_VALIDATE_BYTEVECTOR (3, target
);
478 c_len
= scm_to_uint (len
);
479 c_source_start
= scm_to_uint (source_start
);
480 c_target_start
= scm_to_uint (target_start
);
482 c_source
= SCM_BYTEVECTOR_CONTENTS (source
);
483 c_target
= SCM_BYTEVECTOR_CONTENTS (target
);
484 c_source_len
= SCM_BYTEVECTOR_LENGTH (source
);
485 c_target_len
= SCM_BYTEVECTOR_LENGTH (target
);
487 if (SCM_UNLIKELY (c_source_start
+ c_len
> c_source_len
))
488 scm_out_of_range (FUNC_NAME
, source_start
);
489 if (SCM_UNLIKELY (c_target_start
+ c_len
> c_target_len
))
490 scm_out_of_range (FUNC_NAME
, target_start
);
492 memcpy (c_target
+ c_target_start
,
493 c_source
+ c_source_start
,
496 return SCM_UNSPECIFIED
;
500 SCM_DEFINE (scm_bytevector_copy
, "bytevector-copy", 1, 0, 0,
502 "Return a newly allocated copy of @var{bv}.")
503 #define FUNC_NAME s_scm_bytevector_copy
507 signed char *c_bv
, *c_copy
;
509 SCM_VALIDATE_BYTEVECTOR (1, bv
);
511 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
512 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
514 copy
= make_bytevector (c_len
);
515 c_copy
= SCM_BYTEVECTOR_CONTENTS (copy
);
516 memcpy (c_copy
, c_bv
, c_len
);
522 SCM_DEFINE (scm_uniform_array_to_bytevector
, "uniform-array->bytevector",
523 1, 0, 0, (SCM array
),
524 "Return a newly allocated bytevector whose contents\n"
525 "will be copied from the uniform array @var{array}.")
526 #define FUNC_NAME s_scm_uniform_array_to_bytevector
530 scm_t_array_handle h
;
534 contents
= scm_array_contents (array
, SCM_BOOL_T
);
535 if (scm_is_false (contents
))
536 scm_wrong_type_arg_msg (FUNC_NAME
, 0, array
, "uniform contiguous array");
538 scm_array_get_handle (contents
, &h
);
540 base
= scm_array_handle_uniform_elements (&h
);
541 len
= h
.dims
->inc
* (h
.dims
->ubnd
- h
.dims
->lbnd
+ 1);
542 sz
= scm_array_handle_uniform_element_size (&h
);
544 ret
= make_bytevector (len
* sz
);
545 memcpy (SCM_BYTEVECTOR_CONTENTS (ret
), base
, len
* sz
);
547 scm_array_handle_release (&h
);
554 /* Operations on bytes and octets. */
556 SCM_DEFINE (scm_bytevector_u8_ref
, "bytevector-u8-ref", 2, 0, 0,
558 "Return the octet located at @var{index} in @var{bv}.")
559 #define FUNC_NAME s_scm_bytevector_u8_ref
561 INTEGER_NATIVE_REF (8, unsigned);
565 SCM_DEFINE (scm_bytevector_s8_ref
, "bytevector-s8-ref", 2, 0, 0,
567 "Return the byte located at @var{index} in @var{bv}.")
568 #define FUNC_NAME s_scm_bytevector_s8_ref
570 INTEGER_NATIVE_REF (8, signed);
574 SCM_DEFINE (scm_bytevector_u8_set_x
, "bytevector-u8-set!", 3, 0, 0,
575 (SCM bv
, SCM index
, SCM value
),
576 "Return the octet located at @var{index} in @var{bv}.")
577 #define FUNC_NAME s_scm_bytevector_u8_set_x
579 INTEGER_NATIVE_SET (8, unsigned);
583 SCM_DEFINE (scm_bytevector_s8_set_x
, "bytevector-s8-set!", 3, 0, 0,
584 (SCM bv
, SCM index
, SCM value
),
585 "Return the octet located at @var{index} in @var{bv}.")
586 #define FUNC_NAME s_scm_bytevector_s8_set_x
588 INTEGER_NATIVE_SET (8, signed);
592 #undef OCTET_ACCESSOR_PROLOGUE
595 SCM_DEFINE (scm_bytevector_to_u8_list
, "bytevector->u8-list", 1, 0, 0,
597 "Return a newly allocated list of octets containing the "
598 "contents of @var{bv}.")
599 #define FUNC_NAME s_scm_bytevector_to_u8_list
605 SCM_VALIDATE_BYTEVECTOR (1, bv
);
607 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
608 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
610 lst
= scm_make_list (scm_from_uint (c_len
), SCM_UNSPECIFIED
);
611 for (i
= 0, pair
= lst
;
613 i
++, pair
= SCM_CDR (pair
))
615 SCM_SETCAR (pair
, SCM_I_MAKINUM (c_bv
[i
]));
622 SCM_DEFINE (scm_u8_list_to_bytevector
, "u8-list->bytevector", 1, 0, 0,
624 "Turn @var{lst}, a list of octets, into a bytevector.")
625 #define FUNC_NAME s_scm_u8_list_to_bytevector
631 SCM_VALIDATE_LIST_COPYLEN (1, lst
, c_len
);
633 bv
= make_bytevector (c_len
);
634 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
636 for (i
= 0; i
< c_len
; lst
= SCM_CDR (lst
), i
++)
638 item
= SCM_CAR (lst
);
640 if (SCM_LIKELY (SCM_I_INUMP (item
)))
644 c_item
= SCM_I_INUM (item
);
645 if (SCM_LIKELY ((c_item
>= 0) && (c_item
< 256)))
646 c_bv
[i
] = (unsigned char) c_item
;
657 scm_wrong_type_arg (FUNC_NAME
, 1, item
);
663 /* Compute the two's complement of VALUE (a positive integer) on SIZE octets
664 using (2^(SIZE * 8) - VALUE). */
666 twos_complement (mpz_t value
, size_t size
)
668 unsigned long bit_count
;
670 /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
671 checking on SIZE performed earlier. */
672 bit_count
= (unsigned long) size
<< 3UL;
674 if (SCM_LIKELY (bit_count
< sizeof (unsigned long)))
675 mpz_ui_sub (value
, 1UL << bit_count
, value
);
681 mpz_ui_pow_ui (max
, 2, bit_count
);
682 mpz_sub (value
, max
, value
);
688 bytevector_large_ref (const char *c_bv
, size_t c_size
, int signed_p
,
693 int c_endianness
, negative_p
= 0;
697 if (scm_is_eq (endianness
, scm_sym_big
))
698 negative_p
= c_bv
[0] & 0x80;
700 negative_p
= c_bv
[c_size
- 1] & 0x80;
703 c_endianness
= scm_is_eq (endianness
, scm_sym_big
) ? 1 : -1;
706 mpz_import (c_mpz
, 1 /* 1 word */, 1 /* word order doesn't matter */,
707 c_size
/* word is C_SIZE-byte long */,
709 0 /* nails */, c_bv
);
711 if (signed_p
&& negative_p
)
713 twos_complement (c_mpz
, c_size
);
714 mpz_neg (c_mpz
, c_mpz
);
717 result
= scm_from_mpz (c_mpz
);
718 mpz_clear (c_mpz
); /* FIXME: Needed? */
724 bytevector_large_set (char *c_bv
, size_t c_size
, int signed_p
,
725 SCM value
, SCM endianness
)
728 int c_endianness
, c_sign
, err
= 0;
730 c_endianness
= scm_is_eq (endianness
, scm_sym_big
) ? 1 : -1;
733 scm_to_mpz (value
, c_mpz
);
735 c_sign
= mpz_sgn (c_mpz
);
738 if (SCM_LIKELY (signed_p
))
740 mpz_neg (c_mpz
, c_mpz
);
741 twos_complement (c_mpz
, c_size
);
752 memset (c_bv
, 0, c_size
);
755 size_t word_count
, value_size
;
757 value_size
= (mpz_sizeinbase (c_mpz
, 2) + (8 * c_size
)) / (8 * c_size
);
758 if (SCM_UNLIKELY (value_size
> c_size
))
765 mpz_export (c_bv
, &word_count
, 1 /* word order doesn't matter */,
766 c_size
, c_endianness
,
767 0 /* nails */, c_mpz
);
768 if (SCM_UNLIKELY (word_count
!= 1))
769 /* Shouldn't happen since we already checked with VALUE_SIZE. */
779 #define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \
780 unsigned long c_len, c_index, c_size; \
783 SCM_VALIDATE_BYTEVECTOR (1, bv); \
784 c_index = scm_to_ulong (index); \
785 c_size = scm_to_ulong (size); \
787 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
788 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
790 /* C_SIZE must have its 3 higher bits set to zero so that \
791 multiplying it by 8 yields a number that fits in an \
793 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
794 scm_out_of_range (FUNC_NAME, size); \
795 if (SCM_UNLIKELY (c_index + c_size > c_len)) \
796 scm_out_of_range (FUNC_NAME, index);
799 /* Template of an integer reference function. */
800 #define GENERIC_INTEGER_REF(_sign) \
808 swap = !scm_is_eq (endianness, native_endianness); \
813 _sign char c_value8; \
814 memcpy (&c_value8, c_bv, 1); \
820 INT_TYPE (16, _sign) c_value16; \
821 memcpy (&c_value16, c_bv, 2); \
823 value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \
832 result = SCM_I_MAKINUM ((_sign int) value); \
835 result = bytevector_large_ref ((char *) c_bv, \
836 c_size, SIGNEDNESS (_sign), \
842 bytevector_signed_ref (const char *c_bv
, size_t c_size
, SCM endianness
)
844 GENERIC_INTEGER_REF (signed);
848 bytevector_unsigned_ref (const char *c_bv
, size_t c_size
, SCM endianness
)
850 GENERIC_INTEGER_REF (unsigned);
854 /* Template of an integer assignment function. */
855 #define GENERIC_INTEGER_SET(_sign) \
860 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
863 c_value = SCM_I_INUM (value); \
867 if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \
869 _sign char c_value8; \
870 c_value8 = (_sign char) c_value; \
871 memcpy (c_bv, &c_value8, 1); \
878 if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \
881 INT_TYPE (16, _sign) c_value16; \
883 swap = !scm_is_eq (endianness, native_endianness); \
886 c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \
888 c_value16 = c_value; \
890 memcpy (c_bv, &c_value16, 2); \
904 err = bytevector_large_set (c_bv, c_size, \
905 SIGNEDNESS (_sign), \
906 value, endianness); \
914 scm_out_of_range (FUNC_NAME, value); \
918 bytevector_signed_set (char *c_bv
, size_t c_size
,
919 SCM value
, SCM endianness
,
920 const char *func_name
)
921 #define FUNC_NAME func_name
923 GENERIC_INTEGER_SET (signed);
928 bytevector_unsigned_set (char *c_bv
, size_t c_size
,
929 SCM value
, SCM endianness
,
930 const char *func_name
)
931 #define FUNC_NAME func_name
933 GENERIC_INTEGER_SET (unsigned);
937 #undef GENERIC_INTEGER_SET
938 #undef GENERIC_INTEGER_REF
941 SCM_DEFINE (scm_bytevector_uint_ref
, "bytevector-uint-ref", 4, 0, 0,
942 (SCM bv
, SCM index
, SCM endianness
, SCM size
),
943 "Return the @var{size}-octet long unsigned integer at index "
944 "@var{index} in @var{bv}.")
945 #define FUNC_NAME s_scm_bytevector_uint_ref
947 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
949 return (bytevector_unsigned_ref (&c_bv
[c_index
], c_size
, endianness
));
953 SCM_DEFINE (scm_bytevector_sint_ref
, "bytevector-sint-ref", 4, 0, 0,
954 (SCM bv
, SCM index
, SCM endianness
, SCM size
),
955 "Return the @var{size}-octet long unsigned integer at index "
956 "@var{index} in @var{bv}.")
957 #define FUNC_NAME s_scm_bytevector_sint_ref
959 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
961 return (bytevector_signed_ref (&c_bv
[c_index
], c_size
, endianness
));
965 SCM_DEFINE (scm_bytevector_uint_set_x
, "bytevector-uint-set!", 5, 0, 0,
966 (SCM bv
, SCM index
, SCM value
, SCM endianness
, SCM size
),
967 "Set the @var{size}-octet long unsigned integer at @var{index} "
969 #define FUNC_NAME s_scm_bytevector_uint_set_x
971 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
973 bytevector_unsigned_set (&c_bv
[c_index
], c_size
, value
, endianness
,
976 return SCM_UNSPECIFIED
;
980 SCM_DEFINE (scm_bytevector_sint_set_x
, "bytevector-sint-set!", 5, 0, 0,
981 (SCM bv
, SCM index
, SCM value
, SCM endianness
, SCM size
),
982 "Set the @var{size}-octet long signed integer at @var{index} "
984 #define FUNC_NAME s_scm_bytevector_sint_set_x
986 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
988 bytevector_signed_set (&c_bv
[c_index
], c_size
, value
, endianness
,
991 return SCM_UNSPECIFIED
;
997 /* Operations on integers of arbitrary size. */
999 #define INTEGERS_TO_LIST(_sign) \
1001 size_t i, c_len, c_size; \
1003 SCM_VALIDATE_BYTEVECTOR (1, bv); \
1004 SCM_VALIDATE_SYMBOL (2, endianness); \
1005 c_size = scm_to_uint (size); \
1007 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
1008 if (SCM_UNLIKELY (c_len == 0)) \
1010 else if (SCM_UNLIKELY (c_len < c_size)) \
1011 scm_out_of_range (FUNC_NAME, size); \
1016 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1018 lst = scm_make_list (scm_from_uint (c_len / c_size), \
1020 for (i = 0, pair = lst; \
1021 i <= c_len - c_size; \
1022 i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
1025 bytevector_ ## _sign ## _ref (c_bv, c_size, \
1032 SCM_DEFINE (scm_bytevector_to_sint_list
, "bytevector->sint-list",
1034 (SCM bv
, SCM endianness
, SCM size
),
1035 "Return a list of signed integers of @var{size} octets "
1036 "representing the contents of @var{bv}.")
1037 #define FUNC_NAME s_scm_bytevector_to_sint_list
1039 INTEGERS_TO_LIST (signed);
1043 SCM_DEFINE (scm_bytevector_to_uint_list
, "bytevector->uint-list",
1045 (SCM bv
, SCM endianness
, SCM size
),
1046 "Return a list of unsigned integers of @var{size} octets "
1047 "representing the contents of @var{bv}.")
1048 #define FUNC_NAME s_scm_bytevector_to_uint_list
1050 INTEGERS_TO_LIST (unsigned);
1054 #undef INTEGER_TO_LIST
1057 #define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
1061 char *c_bv, *c_bv_ptr; \
1063 SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
1064 SCM_VALIDATE_SYMBOL (2, endianness); \
1065 c_size = scm_to_uint (size); \
1067 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
1068 scm_out_of_range (FUNC_NAME, size); \
1070 bv = make_bytevector (c_len * c_size); \
1071 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1073 for (c_bv_ptr = c_bv; \
1074 !scm_is_null (lst); \
1075 lst = SCM_CDR (lst), c_bv_ptr += c_size) \
1077 bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
1078 SCM_CAR (lst), endianness, \
1085 SCM_DEFINE (scm_uint_list_to_bytevector
, "uint-list->bytevector",
1087 (SCM lst
, SCM endianness
, SCM size
),
1088 "Return a bytevector containing the unsigned integers "
1089 "listed in @var{lst} and encoded on @var{size} octets "
1090 "according to @var{endianness}.")
1091 #define FUNC_NAME s_scm_uint_list_to_bytevector
1093 INTEGER_LIST_TO_BYTEVECTOR (unsigned);
1097 SCM_DEFINE (scm_sint_list_to_bytevector
, "sint-list->bytevector",
1099 (SCM lst
, SCM endianness
, SCM size
),
1100 "Return a bytevector containing the signed integers "
1101 "listed in @var{lst} and encoded on @var{size} octets "
1102 "according to @var{endianness}.")
1103 #define FUNC_NAME s_scm_sint_list_to_bytevector
1105 INTEGER_LIST_TO_BYTEVECTOR (signed);
1109 #undef INTEGER_LIST_TO_BYTEVECTOR
1113 /* Operations on 16-bit integers. */
1115 SCM_DEFINE (scm_bytevector_u16_ref
, "bytevector-u16-ref",
1117 (SCM bv
, SCM index
, SCM endianness
),
1118 "Return the unsigned 16-bit integer from @var{bv} at "
1120 #define FUNC_NAME s_scm_bytevector_u16_ref
1122 INTEGER_REF (16, unsigned);
1126 SCM_DEFINE (scm_bytevector_s16_ref
, "bytevector-s16-ref",
1128 (SCM bv
, SCM index
, SCM endianness
),
1129 "Return the signed 16-bit integer from @var{bv} at "
1131 #define FUNC_NAME s_scm_bytevector_s16_ref
1133 INTEGER_REF (16, signed);
1137 SCM_DEFINE (scm_bytevector_u16_native_ref
, "bytevector-u16-native-ref",
1139 (SCM bv
, SCM index
),
1140 "Return the unsigned 16-bit integer from @var{bv} at "
1141 "@var{index} using the native endianness.")
1142 #define FUNC_NAME s_scm_bytevector_u16_native_ref
1144 INTEGER_NATIVE_REF (16, unsigned);
1148 SCM_DEFINE (scm_bytevector_s16_native_ref
, "bytevector-s16-native-ref",
1150 (SCM bv
, SCM index
),
1151 "Return the unsigned 16-bit integer from @var{bv} at "
1152 "@var{index} using the native endianness.")
1153 #define FUNC_NAME s_scm_bytevector_s16_native_ref
1155 INTEGER_NATIVE_REF (16, signed);
1159 SCM_DEFINE (scm_bytevector_u16_set_x
, "bytevector-u16-set!",
1161 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1162 "Store @var{value} in @var{bv} at @var{index} according to "
1163 "@var{endianness}.")
1164 #define FUNC_NAME s_scm_bytevector_u16_set_x
1166 INTEGER_SET (16, unsigned);
1170 SCM_DEFINE (scm_bytevector_s16_set_x
, "bytevector-s16-set!",
1172 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1173 "Store @var{value} in @var{bv} at @var{index} according to "
1174 "@var{endianness}.")
1175 #define FUNC_NAME s_scm_bytevector_s16_set_x
1177 INTEGER_SET (16, signed);
1181 SCM_DEFINE (scm_bytevector_u16_native_set_x
, "bytevector-u16-native-set!",
1183 (SCM bv
, SCM index
, SCM value
),
1184 "Store the unsigned integer @var{value} at index @var{index} "
1185 "of @var{bv} using the native endianness.")
1186 #define FUNC_NAME s_scm_bytevector_u16_native_set_x
1188 INTEGER_NATIVE_SET (16, unsigned);
1192 SCM_DEFINE (scm_bytevector_s16_native_set_x
, "bytevector-s16-native-set!",
1194 (SCM bv
, SCM index
, SCM value
),
1195 "Store the signed integer @var{value} at index @var{index} "
1196 "of @var{bv} using the native endianness.")
1197 #define FUNC_NAME s_scm_bytevector_s16_native_set_x
1199 INTEGER_NATIVE_SET (16, signed);
1205 /* Operations on 32-bit integers. */
1207 /* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
1208 arbitrary 32-bit integers. Thus we fall back to using the
1209 `large_{ref,set}' variants on 32-bit machines. */
1211 #define LARGE_INTEGER_REF(_len, _sign) \
1212 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1213 SCM_VALIDATE_SYMBOL (3, endianness); \
1215 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1216 SIGNEDNESS (_sign), endianness));
1218 #define LARGE_INTEGER_SET(_len, _sign) \
1220 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1221 SCM_VALIDATE_SYMBOL (4, endianness); \
1223 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1224 SIGNEDNESS (_sign), value, endianness); \
1225 if (SCM_UNLIKELY (err)) \
1226 scm_out_of_range (FUNC_NAME, value); \
1228 return SCM_UNSPECIFIED;
1230 #define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
1231 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1232 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1233 SIGNEDNESS (_sign), native_endianness));
1235 #define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
1237 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1239 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1240 SIGNEDNESS (_sign), value, \
1241 native_endianness); \
1242 if (SCM_UNLIKELY (err)) \
1243 scm_out_of_range (FUNC_NAME, value); \
1245 return SCM_UNSPECIFIED;
1248 SCM_DEFINE (scm_bytevector_u32_ref
, "bytevector-u32-ref",
1250 (SCM bv
, SCM index
, SCM endianness
),
1251 "Return the unsigned 32-bit integer from @var{bv} at "
1253 #define FUNC_NAME s_scm_bytevector_u32_ref
1255 #if SIZEOF_VOID_P > 4
1256 INTEGER_REF (32, unsigned);
1258 LARGE_INTEGER_REF (32, unsigned);
1263 SCM_DEFINE (scm_bytevector_s32_ref
, "bytevector-s32-ref",
1265 (SCM bv
, SCM index
, SCM endianness
),
1266 "Return the signed 32-bit integer from @var{bv} at "
1268 #define FUNC_NAME s_scm_bytevector_s32_ref
1270 #if SIZEOF_VOID_P > 4
1271 INTEGER_REF (32, signed);
1273 LARGE_INTEGER_REF (32, signed);
1278 SCM_DEFINE (scm_bytevector_u32_native_ref
, "bytevector-u32-native-ref",
1280 (SCM bv
, SCM index
),
1281 "Return the unsigned 32-bit integer from @var{bv} at "
1282 "@var{index} using the native endianness.")
1283 #define FUNC_NAME s_scm_bytevector_u32_native_ref
1285 #if SIZEOF_VOID_P > 4
1286 INTEGER_NATIVE_REF (32, unsigned);
1288 LARGE_INTEGER_NATIVE_REF (32, unsigned);
1293 SCM_DEFINE (scm_bytevector_s32_native_ref
, "bytevector-s32-native-ref",
1295 (SCM bv
, SCM index
),
1296 "Return the unsigned 32-bit integer from @var{bv} at "
1297 "@var{index} using the native endianness.")
1298 #define FUNC_NAME s_scm_bytevector_s32_native_ref
1300 #if SIZEOF_VOID_P > 4
1301 INTEGER_NATIVE_REF (32, signed);
1303 LARGE_INTEGER_NATIVE_REF (32, signed);
1308 SCM_DEFINE (scm_bytevector_u32_set_x
, "bytevector-u32-set!",
1310 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1311 "Store @var{value} in @var{bv} at @var{index} according to "
1312 "@var{endianness}.")
1313 #define FUNC_NAME s_scm_bytevector_u32_set_x
1315 #if SIZEOF_VOID_P > 4
1316 INTEGER_SET (32, unsigned);
1318 LARGE_INTEGER_SET (32, unsigned);
1323 SCM_DEFINE (scm_bytevector_s32_set_x
, "bytevector-s32-set!",
1325 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1326 "Store @var{value} in @var{bv} at @var{index} according to "
1327 "@var{endianness}.")
1328 #define FUNC_NAME s_scm_bytevector_s32_set_x
1330 #if SIZEOF_VOID_P > 4
1331 INTEGER_SET (32, signed);
1333 LARGE_INTEGER_SET (32, signed);
1338 SCM_DEFINE (scm_bytevector_u32_native_set_x
, "bytevector-u32-native-set!",
1340 (SCM bv
, SCM index
, SCM value
),
1341 "Store the unsigned integer @var{value} at index @var{index} "
1342 "of @var{bv} using the native endianness.")
1343 #define FUNC_NAME s_scm_bytevector_u32_native_set_x
1345 #if SIZEOF_VOID_P > 4
1346 INTEGER_NATIVE_SET (32, unsigned);
1348 LARGE_INTEGER_NATIVE_SET (32, unsigned);
1353 SCM_DEFINE (scm_bytevector_s32_native_set_x
, "bytevector-s32-native-set!",
1355 (SCM bv
, SCM index
, SCM value
),
1356 "Store the signed integer @var{value} at index @var{index} "
1357 "of @var{bv} using the native endianness.")
1358 #define FUNC_NAME s_scm_bytevector_s32_native_set_x
1360 #if SIZEOF_VOID_P > 4
1361 INTEGER_NATIVE_SET (32, signed);
1363 LARGE_INTEGER_NATIVE_SET (32, signed);
1370 /* Operations on 64-bit integers. */
1372 /* For 64-bit integers, we use only the `large_{ref,set}' variant. */
1374 SCM_DEFINE (scm_bytevector_u64_ref
, "bytevector-u64-ref",
1376 (SCM bv
, SCM index
, SCM endianness
),
1377 "Return the unsigned 64-bit integer from @var{bv} at "
1379 #define FUNC_NAME s_scm_bytevector_u64_ref
1381 LARGE_INTEGER_REF (64, unsigned);
1385 SCM_DEFINE (scm_bytevector_s64_ref
, "bytevector-s64-ref",
1387 (SCM bv
, SCM index
, SCM endianness
),
1388 "Return the signed 64-bit integer from @var{bv} at "
1390 #define FUNC_NAME s_scm_bytevector_s64_ref
1392 LARGE_INTEGER_REF (64, signed);
1396 SCM_DEFINE (scm_bytevector_u64_native_ref
, "bytevector-u64-native-ref",
1398 (SCM bv
, SCM index
),
1399 "Return the unsigned 64-bit integer from @var{bv} at "
1400 "@var{index} using the native endianness.")
1401 #define FUNC_NAME s_scm_bytevector_u64_native_ref
1403 LARGE_INTEGER_NATIVE_REF (64, unsigned);
1407 SCM_DEFINE (scm_bytevector_s64_native_ref
, "bytevector-s64-native-ref",
1409 (SCM bv
, SCM index
),
1410 "Return the unsigned 64-bit integer from @var{bv} at "
1411 "@var{index} using the native endianness.")
1412 #define FUNC_NAME s_scm_bytevector_s64_native_ref
1414 LARGE_INTEGER_NATIVE_REF (64, signed);
1418 SCM_DEFINE (scm_bytevector_u64_set_x
, "bytevector-u64-set!",
1420 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1421 "Store @var{value} in @var{bv} at @var{index} according to "
1422 "@var{endianness}.")
1423 #define FUNC_NAME s_scm_bytevector_u64_set_x
1425 LARGE_INTEGER_SET (64, unsigned);
1429 SCM_DEFINE (scm_bytevector_s64_set_x
, "bytevector-s64-set!",
1431 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1432 "Store @var{value} in @var{bv} at @var{index} according to "
1433 "@var{endianness}.")
1434 #define FUNC_NAME s_scm_bytevector_s64_set_x
1436 LARGE_INTEGER_SET (64, signed);
1440 SCM_DEFINE (scm_bytevector_u64_native_set_x
, "bytevector-u64-native-set!",
1442 (SCM bv
, SCM index
, SCM value
),
1443 "Store the unsigned integer @var{value} at index @var{index} "
1444 "of @var{bv} using the native endianness.")
1445 #define FUNC_NAME s_scm_bytevector_u64_native_set_x
1447 LARGE_INTEGER_NATIVE_SET (64, unsigned);
1451 SCM_DEFINE (scm_bytevector_s64_native_set_x
, "bytevector-s64-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_s64_native_set_x
1458 LARGE_INTEGER_NATIVE_SET (64, signed);
1464 /* Operations on IEEE-754 numbers. */
1466 /* There are two possible word endians, visible in glibc's <ieee754.h>.
1467 However, in R6RS, when the endianness is `little', little endian is
1468 assumed for both the byte order and the word order. This is clear from
1469 Section 2.1 of R6RS-lib (in response to
1470 http://www.r6rs.org/formal-comments/comment-187.txt). */
1473 /* Convert to/from a floating-point number with different endianness. This
1474 method is probably not the most efficient but it should be portable. */
1477 float_to_foreign_endianness (union scm_ieee754_float
*target
,
1480 union scm_ieee754_float src
;
1484 #ifdef WORDS_BIGENDIAN
1485 /* Assuming little endian for both byte and word order. */
1486 target
->little_endian
.negative
= src
.big_endian
.negative
;
1487 target
->little_endian
.exponent
= src
.big_endian
.exponent
;
1488 target
->little_endian
.mantissa
= src
.big_endian
.mantissa
;
1490 target
->big_endian
.negative
= src
.little_endian
.negative
;
1491 target
->big_endian
.exponent
= src
.little_endian
.exponent
;
1492 target
->big_endian
.mantissa
= src
.little_endian
.mantissa
;
1497 float_from_foreign_endianness (const union scm_ieee754_float
*source
)
1499 union scm_ieee754_float result
;
1501 #ifdef WORDS_BIGENDIAN
1502 /* Assuming little endian for both byte and word order. */
1503 result
.big_endian
.negative
= source
->little_endian
.negative
;
1504 result
.big_endian
.exponent
= source
->little_endian
.exponent
;
1505 result
.big_endian
.mantissa
= source
->little_endian
.mantissa
;
1507 result
.little_endian
.negative
= source
->big_endian
.negative
;
1508 result
.little_endian
.exponent
= source
->big_endian
.exponent
;
1509 result
.little_endian
.mantissa
= source
->big_endian
.mantissa
;
1516 double_to_foreign_endianness (union scm_ieee754_double
*target
,
1519 union scm_ieee754_double src
;
1523 #ifdef WORDS_BIGENDIAN
1524 /* Assuming little endian for both byte and word order. */
1525 target
->little_little_endian
.negative
= src
.big_endian
.negative
;
1526 target
->little_little_endian
.exponent
= src
.big_endian
.exponent
;
1527 target
->little_little_endian
.mantissa0
= src
.big_endian
.mantissa0
;
1528 target
->little_little_endian
.mantissa1
= src
.big_endian
.mantissa1
;
1530 target
->big_endian
.negative
= src
.little_little_endian
.negative
;
1531 target
->big_endian
.exponent
= src
.little_little_endian
.exponent
;
1532 target
->big_endian
.mantissa0
= src
.little_little_endian
.mantissa0
;
1533 target
->big_endian
.mantissa1
= src
.little_little_endian
.mantissa1
;
1537 static inline double
1538 double_from_foreign_endianness (const union scm_ieee754_double
*source
)
1540 union scm_ieee754_double result
;
1542 #ifdef WORDS_BIGENDIAN
1543 /* Assuming little endian for both byte and word order. */
1544 result
.big_endian
.negative
= source
->little_little_endian
.negative
;
1545 result
.big_endian
.exponent
= source
->little_little_endian
.exponent
;
1546 result
.big_endian
.mantissa0
= source
->little_little_endian
.mantissa0
;
1547 result
.big_endian
.mantissa1
= source
->little_little_endian
.mantissa1
;
1549 result
.little_little_endian
.negative
= source
->big_endian
.negative
;
1550 result
.little_little_endian
.exponent
= source
->big_endian
.exponent
;
1551 result
.little_little_endian
.mantissa0
= source
->big_endian
.mantissa0
;
1552 result
.little_little_endian
.mantissa1
= source
->big_endian
.mantissa1
;
1558 /* Template macros to abstract over doubles and floats.
1559 XXX: Guile can only convert to/from doubles. */
1560 #define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type
1561 #define IEEE754_TO_SCM(_c_type) scm_from_double
1562 #define IEEE754_FROM_SCM(_c_type) scm_to_double
1563 #define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
1564 _c_type ## _from_foreign_endianness
1565 #define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
1566 _c_type ## _to_foreign_endianness
1569 /* Templace getters and setters. */
1571 #define IEEE754_ACCESSOR_PROLOGUE(_type) \
1572 INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
1574 #define IEEE754_REF(_type) \
1577 IEEE754_ACCESSOR_PROLOGUE (_type); \
1578 SCM_VALIDATE_SYMBOL (3, endianness); \
1580 if (scm_is_eq (endianness, native_endianness)) \
1581 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1584 IEEE754_UNION (_type) c_raw; \
1586 memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
1588 IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
1591 return (IEEE754_TO_SCM (_type) (c_result));
1593 #define IEEE754_NATIVE_REF(_type) \
1596 IEEE754_ACCESSOR_PROLOGUE (_type); \
1598 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1599 return (IEEE754_TO_SCM (_type) (c_result));
1601 #define IEEE754_SET(_type) \
1604 IEEE754_ACCESSOR_PROLOGUE (_type); \
1605 SCM_VALIDATE_REAL (3, value); \
1606 SCM_VALIDATE_SYMBOL (4, endianness); \
1607 c_value = IEEE754_FROM_SCM (_type) (value); \
1609 if (scm_is_eq (endianness, native_endianness)) \
1610 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1613 IEEE754_UNION (_type) c_raw; \
1615 IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
1616 memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
1619 return SCM_UNSPECIFIED;
1621 #define IEEE754_NATIVE_SET(_type) \
1624 IEEE754_ACCESSOR_PROLOGUE (_type); \
1625 SCM_VALIDATE_REAL (3, value); \
1626 c_value = IEEE754_FROM_SCM (_type) (value); \
1628 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1629 return SCM_UNSPECIFIED;
1632 /* Single precision. */
1634 SCM_DEFINE (scm_bytevector_ieee_single_ref
,
1635 "bytevector-ieee-single-ref",
1637 (SCM bv
, SCM index
, SCM endianness
),
1638 "Return the IEEE-754 single from @var{bv} at "
1640 #define FUNC_NAME s_scm_bytevector_ieee_single_ref
1642 IEEE754_REF (float);
1646 SCM_DEFINE (scm_bytevector_ieee_single_native_ref
,
1647 "bytevector-ieee-single-native-ref",
1649 (SCM bv
, SCM index
),
1650 "Return the IEEE-754 single from @var{bv} at "
1651 "@var{index} using the native endianness.")
1652 #define FUNC_NAME s_scm_bytevector_ieee_single_native_ref
1654 IEEE754_NATIVE_REF (float);
1658 SCM_DEFINE (scm_bytevector_ieee_single_set_x
,
1659 "bytevector-ieee-single-set!",
1661 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1662 "Store real @var{value} in @var{bv} at @var{index} according to "
1663 "@var{endianness}.")
1664 #define FUNC_NAME s_scm_bytevector_ieee_single_set_x
1666 IEEE754_SET (float);
1670 SCM_DEFINE (scm_bytevector_ieee_single_native_set_x
,
1671 "bytevector-ieee-single-native-set!",
1673 (SCM bv
, SCM index
, SCM value
),
1674 "Store the real @var{value} at index @var{index} "
1675 "of @var{bv} using the native endianness.")
1676 #define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x
1678 IEEE754_NATIVE_SET (float);
1683 /* Double precision. */
1685 SCM_DEFINE (scm_bytevector_ieee_double_ref
,
1686 "bytevector-ieee-double-ref",
1688 (SCM bv
, SCM index
, SCM endianness
),
1689 "Return the IEEE-754 double from @var{bv} at "
1691 #define FUNC_NAME s_scm_bytevector_ieee_double_ref
1693 IEEE754_REF (double);
1697 SCM_DEFINE (scm_bytevector_ieee_double_native_ref
,
1698 "bytevector-ieee-double-native-ref",
1700 (SCM bv
, SCM index
),
1701 "Return the IEEE-754 double from @var{bv} at "
1702 "@var{index} using the native endianness.")
1703 #define FUNC_NAME s_scm_bytevector_ieee_double_native_ref
1705 IEEE754_NATIVE_REF (double);
1709 SCM_DEFINE (scm_bytevector_ieee_double_set_x
,
1710 "bytevector-ieee-double-set!",
1712 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1713 "Store real @var{value} in @var{bv} at @var{index} according to "
1714 "@var{endianness}.")
1715 #define FUNC_NAME s_scm_bytevector_ieee_double_set_x
1717 IEEE754_SET (double);
1721 SCM_DEFINE (scm_bytevector_ieee_double_native_set_x
,
1722 "bytevector-ieee-double-native-set!",
1724 (SCM bv
, SCM index
, SCM value
),
1725 "Store the real @var{value} at index @var{index} "
1726 "of @var{bv} using the native endianness.")
1727 #define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x
1729 IEEE754_NATIVE_SET (double);
1734 #undef IEEE754_UNION
1735 #undef IEEE754_TO_SCM
1736 #undef IEEE754_FROM_SCM
1737 #undef IEEE754_FROM_FOREIGN_ENDIANNESS
1738 #undef IEEE754_TO_FOREIGN_ENDIANNESS
1740 #undef IEEE754_NATIVE_REF
1742 #undef IEEE754_NATIVE_SET
1745 /* Operations on strings. */
1748 /* Produce a function that returns the length of a UTF-encoded string. */
1749 #define UTF_STRLEN_FUNCTION(_utf_width) \
1750 static inline size_t \
1751 utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
1754 const uint ## _utf_width ## _t *ptr; \
1762 return (len * ((_utf_width) / 8)); \
1765 UTF_STRLEN_FUNCTION (8)
1768 /* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
1769 #define UTF_STRLEN(_utf_width, _str) \
1770 utf ## _utf_width ## _strlen (_str)
1772 /* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
1773 ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
1776 utf_encoding_name (char *name
, size_t utf_width
, SCM endianness
)
1778 strcpy (name
, "UTF-");
1779 strcat (name
, ((utf_width
== 8)
1781 : ((utf_width
== 16)
1783 : ((utf_width
== 32)
1787 ((scm_is_eq (endianness
, scm_sym_big
))
1789 : ((scm_is_eq (endianness
, scm_sym_little
))
1794 /* Maximum length of a UTF encoding name. */
1795 #define MAX_UTF_ENCODING_NAME_LEN 16
1797 /* Produce the body of a `string->utf' function. */
1798 #define STRING_TO_UTF(_utf_width) \
1802 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1803 char *c_utf = NULL, *c_locale; \
1804 size_t c_strlen, c_raw_strlen, c_utf_len = 0; \
1806 SCM_VALIDATE_STRING (1, str); \
1807 if (endianness == SCM_UNDEFINED) \
1808 endianness = scm_sym_big; \
1810 SCM_VALIDATE_SYMBOL (2, endianness); \
1812 c_strlen = scm_c_string_length (str); \
1813 c_raw_strlen = c_strlen * ((_utf_width) / 8); \
1816 c_str = (char *) alloca (c_raw_strlen + 1); \
1817 c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \
1819 while (c_raw_strlen > c_strlen); \
1820 c_str[c_raw_strlen] = '\0'; \
1822 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1824 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1825 strcpy (c_locale, locale_charset ()); \
1827 err = mem_iconveh (c_str, c_raw_strlen, \
1828 c_locale, c_utf_name, \
1829 iconveh_question_mark, NULL, \
1830 &c_utf, &c_utf_len); \
1831 if (SCM_UNLIKELY (err)) \
1832 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1833 scm_list_1 (str), err); \
1835 /* C_UTF is null-terminated. */ \
1836 utf = scm_c_take_bytevector ((signed char *) c_utf, \
1843 SCM_DEFINE (scm_string_to_utf8
, "string->utf8",
1846 "Return a newly allocated bytevector that contains the UTF-8 "
1847 "encoding of @var{str}.")
1848 #define FUNC_NAME s_scm_string_to_utf8
1853 size_t c_strlen
, c_raw_strlen
;
1855 SCM_VALIDATE_STRING (1, str
);
1857 c_strlen
= scm_c_string_length (str
);
1858 c_raw_strlen
= c_strlen
;
1861 c_str
= (char *) alloca (c_raw_strlen
+ 1);
1862 c_raw_strlen
= scm_to_locale_stringbuf (str
, c_str
, c_strlen
);
1864 while (c_raw_strlen
> c_strlen
);
1865 c_str
[c_raw_strlen
] = '\0';
1867 c_utf
= u8_strconv_from_locale (c_str
);
1868 if (SCM_UNLIKELY (c_utf
== NULL
))
1869 scm_syserror (FUNC_NAME
);
1871 /* C_UTF is null-terminated. */
1872 utf
= scm_c_take_bytevector ((signed char *) c_utf
,
1873 UTF_STRLEN (8, c_utf
));
1879 SCM_DEFINE (scm_string_to_utf16
, "string->utf16",
1881 (SCM str
, SCM endianness
),
1882 "Return a newly allocated bytevector that contains the UTF-16 "
1883 "encoding of @var{str}.")
1884 #define FUNC_NAME s_scm_string_to_utf16
1890 SCM_DEFINE (scm_string_to_utf32
, "string->utf32",
1892 (SCM str
, SCM endianness
),
1893 "Return a newly allocated bytevector that contains the UTF-32 "
1894 "encoding of @var{str}.")
1895 #define FUNC_NAME s_scm_string_to_utf32
1902 /* Produce the body of a function that converts a UTF-encoded bytevector to a
1904 #define UTF_TO_STRING(_utf_width) \
1905 SCM str = SCM_BOOL_F; \
1907 char *c_str = NULL, *c_locale; \
1908 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1909 const char *c_utf; \
1910 size_t c_strlen = 0, c_utf_len; \
1912 SCM_VALIDATE_BYTEVECTOR (1, utf); \
1913 if (endianness == SCM_UNDEFINED) \
1914 endianness = scm_sym_big; \
1916 SCM_VALIDATE_SYMBOL (2, endianness); \
1918 c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \
1919 c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
1920 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1922 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1923 strcpy (c_locale, locale_charset ()); \
1925 err = mem_iconveh (c_utf, c_utf_len, \
1926 c_utf_name, c_locale, \
1927 iconveh_question_mark, NULL, \
1928 &c_str, &c_strlen); \
1929 if (SCM_UNLIKELY (err)) \
1930 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
1931 scm_list_1 (utf), err); \
1933 /* C_STR is null-terminated. */ \
1934 str = scm_take_locale_stringn (c_str, c_strlen); \
1939 SCM_DEFINE (scm_utf8_to_string
, "utf8->string",
1942 "Return a newly allocate string that contains from the UTF-8-"
1943 "encoded contents of bytevector @var{utf}.")
1944 #define FUNC_NAME s_scm_utf8_to_string
1948 char *c_str
= NULL
, *c_locale
;
1950 size_t c_utf_len
, c_strlen
= 0;
1952 SCM_VALIDATE_BYTEVECTOR (1, utf
);
1954 c_utf_len
= SCM_BYTEVECTOR_LENGTH (utf
);
1956 c_locale
= (char *) alloca (strlen (locale_charset ()) + 1);
1957 strcpy (c_locale
, locale_charset ());
1959 c_utf
= (char *) SCM_BYTEVECTOR_CONTENTS (utf
);
1960 err
= mem_iconveh (c_utf
, c_utf_len
,
1962 iconveh_question_mark
, NULL
,
1964 if (SCM_UNLIKELY (err
))
1965 scm_syserror_msg (FUNC_NAME
, "failed to convert to string: ~A",
1966 scm_list_1 (utf
), err
);
1968 /* C_STR is null-terminated. */
1969 str
= scm_take_locale_stringn (c_str
, c_strlen
);
1975 SCM_DEFINE (scm_utf16_to_string
, "utf16->string",
1977 (SCM utf
, SCM endianness
),
1978 "Return a newly allocate string that contains from the UTF-16-"
1979 "encoded contents of bytevector @var{utf}.")
1980 #define FUNC_NAME s_scm_utf16_to_string
1986 SCM_DEFINE (scm_utf32_to_string
, "utf32->string",
1988 (SCM utf
, SCM endianness
),
1989 "Return a newly allocate string that contains from the UTF-32-"
1990 "encoded contents of bytevector @var{utf}.")
1991 #define FUNC_NAME s_scm_utf32_to_string
1999 /* Initialization. */
2002 scm_init_bytevectors (void)
2004 #include "libguile/bytevectors.x"
2006 #ifdef WORDS_BIGENDIAN
2007 native_endianness
= scm_sym_big
;
2009 native_endianness
= scm_sym_little
;
2012 scm_endianness_big
= scm_sym_big
;
2013 scm_endianness_little
= scm_sym_little
;
2015 scm_null_bytevector
=
2016 scm_gc_protect_object (make_bytevector_from_buffer (0, NULL
));