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/extensions.h"
30 #include "libguile/bytevectors.h"
31 #include "libguile/strings.h"
32 #include "libguile/validate.h"
33 #include "libguile/ieee-754.h"
34 #include "libguile/arrays.h"
35 #include "libguile/array-handle.h"
36 #include "libguile/srfi-4.h"
39 #include <striconveh.h>
45 /* Assuming 32-bit longs. */
46 # define ULONG_MAX 4294967295UL
55 /* Convenience macros. These are used by the various templates (macros) that
56 are parameterized by integer signedness. */
57 #define INT8_T_signed scm_t_int8
58 #define INT8_T_unsigned scm_t_uint8
59 #define INT16_T_signed scm_t_int16
60 #define INT16_T_unsigned scm_t_uint16
61 #define INT32_T_signed scm_t_int32
62 #define INT32_T_unsigned scm_t_uint32
63 #define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L))
64 #define is_unsigned_int8(_x) ((_x) <= 255UL)
65 #define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
66 #define is_unsigned_int16(_x) ((_x) <= 65535UL)
67 #define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L))
68 #define is_unsigned_int32(_x) ((_x) <= 4294967295UL)
69 #define SIGNEDNESS_signed 1
70 #define SIGNEDNESS_unsigned 0
72 #define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign
73 #define INT_SWAP(_size) bswap_ ## _size
74 #define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
75 #define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
78 #define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \
79 size_t c_len, c_index; \
82 SCM_VALIDATE_BYTEVECTOR (1, bv); \
83 c_index = scm_to_uint (index); \
85 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
86 c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \
88 if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
89 scm_out_of_range (FUNC_NAME, index);
91 /* Template for fixed-size integer access (only 8, 16 or 32-bit). */
92 #define INTEGER_REF(_len, _sign) \
95 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
96 SCM_VALIDATE_SYMBOL (3, endianness); \
99 INT_TYPE (_len, _sign) c_result; \
101 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
102 if (!scm_is_eq (endianness, scm_i_native_endianness)) \
103 c_result = INT_SWAP (_len) (c_result); \
105 result = SCM_I_MAKINUM (c_result); \
110 /* Template for fixed-size integer access using the native endianness. */
111 #define INTEGER_NATIVE_REF(_len, _sign) \
114 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
117 INT_TYPE (_len, _sign) c_result; \
119 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
120 result = SCM_I_MAKINUM (c_result); \
125 /* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
126 #define INTEGER_SET(_len, _sign) \
127 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
128 SCM_VALIDATE_SYMBOL (3, endianness); \
131 _sign long c_value; \
132 INT_TYPE (_len, _sign) c_value_short; \
134 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
135 scm_wrong_type_arg (FUNC_NAME, 3, value); \
137 c_value = SCM_I_INUM (value); \
138 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
139 scm_out_of_range (FUNC_NAME, value); \
141 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
142 if (!scm_is_eq (endianness, scm_i_native_endianness)) \
143 c_value_short = INT_SWAP (_len) (c_value_short); \
145 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
148 return SCM_UNSPECIFIED;
150 /* Template for fixed-size integer modification using the native
152 #define INTEGER_NATIVE_SET(_len, _sign) \
153 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
156 _sign long c_value; \
157 INT_TYPE (_len, _sign) c_value_short; \
159 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
160 scm_wrong_type_arg (FUNC_NAME, 3, value); \
162 c_value = SCM_I_INUM (value); \
163 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
164 scm_out_of_range (FUNC_NAME, value); \
166 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
168 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
171 return SCM_UNSPECIFIED;
175 /* Bytevector type. */
177 scm_t_bits scm_tc16_bytevector
;
179 #define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
180 SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len))
181 #define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
182 SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf))
184 /* The empty bytevector. */
185 SCM scm_null_bytevector
= SCM_UNSPECIFIED
;
189 make_bytevector_from_buffer (size_t len
, signed char *contents
)
191 /* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */
192 SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector
, len
, contents
);
196 make_bytevector (size_t len
)
200 if (SCM_UNLIKELY (len
== 0))
201 bv
= scm_null_bytevector
;
204 signed char *contents
= NULL
;
206 if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len
))
207 contents
= (signed char *) scm_gc_malloc (len
, SCM_GC_BYTEVECTOR
);
209 bv
= make_bytevector_from_buffer (len
, contents
);
215 /* Return a new bytevector of size LEN octets. */
217 scm_c_make_bytevector (size_t len
)
219 return (make_bytevector (len
));
222 /* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
223 by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
225 scm_c_take_bytevector (signed char *contents
, size_t len
)
229 if (SCM_UNLIKELY (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len
)))
231 /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */
234 bv
= make_bytevector (len
);
235 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
236 memcpy (c_bv
, contents
, len
);
237 scm_gc_free (contents
, len
, SCM_GC_BYTEVECTOR
);
240 bv
= make_bytevector_from_buffer (len
, contents
);
245 /* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
246 size) and return BV. */
248 scm_i_shrink_bytevector (SCM bv
, size_t c_new_len
)
250 if (!SCM_BYTEVECTOR_INLINE_P (bv
))
253 signed char *c_bv
, *c_new_bv
;
255 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
256 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
258 SCM_BYTEVECTOR_SET_LENGTH (bv
, c_new_len
);
260 if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len
))
262 /* Copy to the in-line buffer and free the current buffer. */
263 c_new_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
264 memcpy (c_new_bv
, c_bv
, c_new_len
);
265 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
269 /* Resize the existing buffer. */
270 c_new_bv
= scm_gc_realloc (c_bv
, c_len
, c_new_len
,
272 SCM_BYTEVECTOR_SET_CONTENTS (bv
, c_new_bv
);
280 scm_is_bytevector (SCM obj
)
282 return SCM_SMOB_PREDICATE (scm_tc16_bytevector
, obj
);
286 scm_c_bytevector_length (SCM bv
)
287 #define FUNC_NAME "scm_c_bytevector_length"
289 SCM_VALIDATE_BYTEVECTOR (1, bv
);
291 return SCM_BYTEVECTOR_LENGTH (bv
);
296 scm_c_bytevector_ref (SCM bv
, size_t index
)
297 #define FUNC_NAME "scm_c_bytevector_ref"
300 const scm_t_uint8
*c_bv
;
302 SCM_VALIDATE_BYTEVECTOR (1, bv
);
304 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
305 c_bv
= (scm_t_uint8
*) SCM_BYTEVECTOR_CONTENTS (bv
);
307 if (SCM_UNLIKELY (index
>= c_len
))
308 scm_out_of_range (FUNC_NAME
, scm_from_size_t (index
));
315 scm_c_bytevector_set_x (SCM bv
, size_t index
, scm_t_uint8 value
)
316 #define FUNC_NAME "scm_c_bytevector_set_x"
321 SCM_VALIDATE_BYTEVECTOR (1, bv
);
323 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
324 c_bv
= (scm_t_uint8
*) SCM_BYTEVECTOR_CONTENTS (bv
);
326 if (SCM_UNLIKELY (index
>= c_len
))
327 scm_out_of_range (FUNC_NAME
, scm_from_size_t (index
));
333 /* This procedure is used by `scm_c_generalized_vector_set_x ()'. */
335 scm_i_bytevector_generalized_set_x (SCM bv
, size_t index
, SCM value
)
336 #define FUNC_NAME "scm_i_bytevector_generalized_set_x"
338 scm_c_bytevector_set_x (bv
, index
, scm_to_uint8 (value
));
343 print_bytevector (SCM bv
, SCM port
, scm_print_state
*pstate
)
348 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
349 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
351 scm_puts ("#vu8(", port
);
352 for (i
= 0; i
< c_len
; i
++)
355 scm_putc (' ', port
);
357 scm_uintprint (c_bv
[i
], 10, port
);
360 scm_putc (')', port
);
362 /* Make GCC think we use it. */
363 scm_remember_upto_here ((SCM
) pstate
);
369 bytevector_equal_p (SCM bv1
, SCM bv2
)
371 return scm_bytevector_eq_p (bv1
, bv2
);
375 free_bytevector (SCM bv
)
378 if (!SCM_BYTEVECTOR_INLINE_P (bv
))
383 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
384 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
386 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
394 /* General operations. */
396 SCM_SYMBOL (scm_sym_big
, "big");
397 SCM_SYMBOL (scm_sym_little
, "little");
399 SCM scm_endianness_big
, scm_endianness_little
;
401 /* Host endianness (a symbol). */
402 SCM scm_i_native_endianness
= SCM_UNSPECIFIED
;
406 # define bswap_24(_x) \
407 ((((_x) & 0xff0000) >> 16) | \
408 (((_x) & 0x00ff00)) | \
409 (((_x) & 0x0000ff) << 16))
413 SCM_DEFINE (scm_native_endianness
, "native-endianness", 0, 0, 0,
415 "Return a symbol denoting the machine's native endianness.")
416 #define FUNC_NAME s_scm_native_endianness
418 return scm_i_native_endianness
;
422 SCM_DEFINE (scm_bytevector_p
, "bytevector?", 1, 0, 0,
424 "Return true if @var{obj} is a bytevector.")
425 #define FUNC_NAME s_scm_bytevector_p
427 return scm_from_bool (scm_is_bytevector (obj
));
431 SCM_DEFINE (scm_make_bytevector
, "make-bytevector", 1, 1, 0,
433 "Return a newly allocated bytevector of @var{len} bytes, "
434 "optionally filled with @var{fill}.")
435 #define FUNC_NAME s_scm_make_bytevector
439 signed char c_fill
= '\0';
441 SCM_VALIDATE_UINT_COPY (1, len
, c_len
);
442 if (fill
!= SCM_UNDEFINED
)
446 value
= scm_to_int (fill
);
447 if (SCM_UNLIKELY ((value
< -128) || (value
> 255)))
448 scm_out_of_range (FUNC_NAME
, fill
);
449 c_fill
= (signed char) value
;
452 bv
= make_bytevector (c_len
);
453 if (fill
!= SCM_UNDEFINED
)
456 signed char *contents
;
458 contents
= SCM_BYTEVECTOR_CONTENTS (bv
);
459 for (i
= 0; i
< c_len
; i
++)
460 contents
[i
] = c_fill
;
467 SCM_DEFINE (scm_bytevector_length
, "bytevector-length", 1, 0, 0,
469 "Return the length (in bytes) of @var{bv}.")
470 #define FUNC_NAME s_scm_bytevector_length
472 return scm_from_uint (scm_c_bytevector_length (bv
));
476 SCM_DEFINE (scm_bytevector_eq_p
, "bytevector=?", 2, 0, 0,
478 "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
479 "have the same length and contents.")
480 #define FUNC_NAME s_scm_bytevector_eq_p
482 SCM result
= SCM_BOOL_F
;
483 unsigned c_len1
, c_len2
;
485 SCM_VALIDATE_BYTEVECTOR (1, bv1
);
486 SCM_VALIDATE_BYTEVECTOR (2, bv2
);
488 c_len1
= SCM_BYTEVECTOR_LENGTH (bv1
);
489 c_len2
= SCM_BYTEVECTOR_LENGTH (bv2
);
491 if (c_len1
== c_len2
)
493 signed char *c_bv1
, *c_bv2
;
495 c_bv1
= SCM_BYTEVECTOR_CONTENTS (bv1
);
496 c_bv2
= SCM_BYTEVECTOR_CONTENTS (bv2
);
498 result
= scm_from_bool (!memcmp (c_bv1
, c_bv2
, c_len1
));
505 SCM_DEFINE (scm_bytevector_fill_x
, "bytevector-fill!", 2, 0, 0,
507 "Fill bytevector @var{bv} with @var{fill}, a byte.")
508 #define FUNC_NAME s_scm_bytevector_fill_x
511 signed char *c_bv
, c_fill
;
513 SCM_VALIDATE_BYTEVECTOR (1, bv
);
514 c_fill
= scm_to_int8 (fill
);
516 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
517 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
519 for (i
= 0; i
< c_len
; i
++)
522 return SCM_UNSPECIFIED
;
526 SCM_DEFINE (scm_bytevector_copy_x
, "bytevector-copy!", 5, 0, 0,
527 (SCM source
, SCM source_start
, SCM target
, SCM target_start
,
529 "Copy @var{len} bytes from @var{source} into @var{target}, "
530 "starting reading from @var{source_start} (a positive index "
531 "within @var{source}) and start writing at "
532 "@var{target_start}.")
533 #define FUNC_NAME s_scm_bytevector_copy_x
535 unsigned c_len
, c_source_len
, c_target_len
;
536 unsigned c_source_start
, c_target_start
;
537 signed char *c_source
, *c_target
;
539 SCM_VALIDATE_BYTEVECTOR (1, source
);
540 SCM_VALIDATE_BYTEVECTOR (3, target
);
542 c_len
= scm_to_uint (len
);
543 c_source_start
= scm_to_uint (source_start
);
544 c_target_start
= scm_to_uint (target_start
);
546 c_source
= SCM_BYTEVECTOR_CONTENTS (source
);
547 c_target
= SCM_BYTEVECTOR_CONTENTS (target
);
548 c_source_len
= SCM_BYTEVECTOR_LENGTH (source
);
549 c_target_len
= SCM_BYTEVECTOR_LENGTH (target
);
551 if (SCM_UNLIKELY (c_source_start
+ c_len
> c_source_len
))
552 scm_out_of_range (FUNC_NAME
, source_start
);
553 if (SCM_UNLIKELY (c_target_start
+ c_len
> c_target_len
))
554 scm_out_of_range (FUNC_NAME
, target_start
);
556 memcpy (c_target
+ c_target_start
,
557 c_source
+ c_source_start
,
560 return SCM_UNSPECIFIED
;
564 SCM_DEFINE (scm_bytevector_copy
, "bytevector-copy", 1, 0, 0,
566 "Return a newly allocated copy of @var{bv}.")
567 #define FUNC_NAME s_scm_bytevector_copy
571 signed char *c_bv
, *c_copy
;
573 SCM_VALIDATE_BYTEVECTOR (1, bv
);
575 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
576 c_bv
= SCM_BYTEVECTOR_CONTENTS (bv
);
578 copy
= make_bytevector (c_len
);
579 c_copy
= SCM_BYTEVECTOR_CONTENTS (copy
);
580 memcpy (c_copy
, c_bv
, c_len
);
586 SCM_DEFINE (scm_uniform_array_to_bytevector
, "uniform-array->bytevector",
587 1, 0, 0, (SCM array
),
588 "Return a newly allocated bytevector whose contents\n"
589 "will be copied from the uniform array @var{array}.")
590 #define FUNC_NAME s_scm_uniform_array_to_bytevector
594 scm_t_array_handle h
;
598 contents
= scm_array_contents (array
, SCM_BOOL_T
);
599 if (scm_is_false (contents
))
600 scm_wrong_type_arg_msg (FUNC_NAME
, 0, array
, "uniform contiguous array");
602 scm_array_get_handle (contents
, &h
);
604 base
= scm_array_handle_uniform_elements (&h
);
605 len
= h
.dims
->inc
* (h
.dims
->ubnd
- h
.dims
->lbnd
+ 1);
606 sz
= scm_array_handle_uniform_element_size (&h
);
608 ret
= make_bytevector (len
* sz
);
609 memcpy (SCM_BYTEVECTOR_CONTENTS (ret
), base
, len
* sz
);
611 scm_array_handle_release (&h
);
618 /* Operations on bytes and octets. */
620 SCM_DEFINE (scm_bytevector_u8_ref
, "bytevector-u8-ref", 2, 0, 0,
622 "Return the octet located at @var{index} in @var{bv}.")
623 #define FUNC_NAME s_scm_bytevector_u8_ref
625 INTEGER_NATIVE_REF (8, unsigned);
629 SCM_DEFINE (scm_bytevector_s8_ref
, "bytevector-s8-ref", 2, 0, 0,
631 "Return the byte located at @var{index} in @var{bv}.")
632 #define FUNC_NAME s_scm_bytevector_s8_ref
634 INTEGER_NATIVE_REF (8, signed);
638 SCM_DEFINE (scm_bytevector_u8_set_x
, "bytevector-u8-set!", 3, 0, 0,
639 (SCM bv
, SCM index
, SCM value
),
640 "Return the octet located at @var{index} in @var{bv}.")
641 #define FUNC_NAME s_scm_bytevector_u8_set_x
643 INTEGER_NATIVE_SET (8, unsigned);
647 SCM_DEFINE (scm_bytevector_s8_set_x
, "bytevector-s8-set!", 3, 0, 0,
648 (SCM bv
, SCM index
, SCM value
),
649 "Return the octet located at @var{index} in @var{bv}.")
650 #define FUNC_NAME s_scm_bytevector_s8_set_x
652 INTEGER_NATIVE_SET (8, signed);
656 #undef OCTET_ACCESSOR_PROLOGUE
659 SCM_DEFINE (scm_bytevector_to_u8_list
, "bytevector->u8-list", 1, 0, 0,
661 "Return a newly allocated list of octets containing the "
662 "contents of @var{bv}.")
663 #define FUNC_NAME s_scm_bytevector_to_u8_list
669 SCM_VALIDATE_BYTEVECTOR (1, bv
);
671 c_len
= SCM_BYTEVECTOR_LENGTH (bv
);
672 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
674 lst
= scm_make_list (scm_from_uint (c_len
), SCM_UNSPECIFIED
);
675 for (i
= 0, pair
= lst
;
677 i
++, pair
= SCM_CDR (pair
))
679 SCM_SETCAR (pair
, SCM_I_MAKINUM (c_bv
[i
]));
686 SCM_DEFINE (scm_u8_list_to_bytevector
, "u8-list->bytevector", 1, 0, 0,
688 "Turn @var{lst}, a list of octets, into a bytevector.")
689 #define FUNC_NAME s_scm_u8_list_to_bytevector
695 SCM_VALIDATE_LIST_COPYLEN (1, lst
, c_len
);
697 bv
= make_bytevector (c_len
);
698 c_bv
= (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv
);
700 for (i
= 0; i
< c_len
; lst
= SCM_CDR (lst
), i
++)
702 item
= SCM_CAR (lst
);
704 if (SCM_LIKELY (SCM_I_INUMP (item
)))
708 c_item
= SCM_I_INUM (item
);
709 if (SCM_LIKELY ((c_item
>= 0) && (c_item
< 256)))
710 c_bv
[i
] = (unsigned char) c_item
;
721 scm_wrong_type_arg (FUNC_NAME
, 1, item
);
727 /* Compute the two's complement of VALUE (a positive integer) on SIZE octets
728 using (2^(SIZE * 8) - VALUE). */
730 twos_complement (mpz_t value
, size_t size
)
732 unsigned long bit_count
;
734 /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
735 checking on SIZE performed earlier. */
736 bit_count
= (unsigned long) size
<< 3UL;
738 if (SCM_LIKELY (bit_count
< sizeof (unsigned long)))
739 mpz_ui_sub (value
, 1UL << bit_count
, value
);
745 mpz_ui_pow_ui (max
, 2, bit_count
);
746 mpz_sub (value
, max
, value
);
752 bytevector_large_ref (const char *c_bv
, size_t c_size
, int signed_p
,
757 int c_endianness
, negative_p
= 0;
761 if (scm_is_eq (endianness
, scm_sym_big
))
762 negative_p
= c_bv
[0] & 0x80;
764 negative_p
= c_bv
[c_size
- 1] & 0x80;
767 c_endianness
= scm_is_eq (endianness
, scm_sym_big
) ? 1 : -1;
770 mpz_import (c_mpz
, 1 /* 1 word */, 1 /* word order doesn't matter */,
771 c_size
/* word is C_SIZE-byte long */,
773 0 /* nails */, c_bv
);
775 if (signed_p
&& negative_p
)
777 twos_complement (c_mpz
, c_size
);
778 mpz_neg (c_mpz
, c_mpz
);
781 result
= scm_from_mpz (c_mpz
);
782 mpz_clear (c_mpz
); /* FIXME: Needed? */
788 bytevector_large_set (char *c_bv
, size_t c_size
, int signed_p
,
789 SCM value
, SCM endianness
)
792 int c_endianness
, c_sign
, err
= 0;
794 c_endianness
= scm_is_eq (endianness
, scm_sym_big
) ? 1 : -1;
797 scm_to_mpz (value
, c_mpz
);
799 c_sign
= mpz_sgn (c_mpz
);
802 if (SCM_LIKELY (signed_p
))
804 mpz_neg (c_mpz
, c_mpz
);
805 twos_complement (c_mpz
, c_size
);
816 memset (c_bv
, 0, c_size
);
819 size_t word_count
, value_size
;
821 value_size
= (mpz_sizeinbase (c_mpz
, 2) + (8 * c_size
)) / (8 * c_size
);
822 if (SCM_UNLIKELY (value_size
> c_size
))
829 mpz_export (c_bv
, &word_count
, 1 /* word order doesn't matter */,
830 c_size
, c_endianness
,
831 0 /* nails */, c_mpz
);
832 if (SCM_UNLIKELY (word_count
!= 1))
833 /* Shouldn't happen since we already checked with VALUE_SIZE. */
843 #define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \
844 unsigned long c_len, c_index, c_size; \
847 SCM_VALIDATE_BYTEVECTOR (1, bv); \
848 c_index = scm_to_ulong (index); \
849 c_size = scm_to_ulong (size); \
851 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
852 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
854 /* C_SIZE must have its 3 higher bits set to zero so that \
855 multiplying it by 8 yields a number that fits in an \
857 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
858 scm_out_of_range (FUNC_NAME, size); \
859 if (SCM_UNLIKELY (c_index + c_size > c_len)) \
860 scm_out_of_range (FUNC_NAME, index);
863 /* Template of an integer reference function. */
864 #define GENERIC_INTEGER_REF(_sign) \
872 swap = !scm_is_eq (endianness, scm_i_native_endianness); \
877 _sign char c_value8; \
878 memcpy (&c_value8, c_bv, 1); \
884 INT_TYPE (16, _sign) c_value16; \
885 memcpy (&c_value16, c_bv, 2); \
887 value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \
896 result = SCM_I_MAKINUM ((_sign int) value); \
899 result = bytevector_large_ref ((char *) c_bv, \
900 c_size, SIGNEDNESS (_sign), \
906 bytevector_signed_ref (const char *c_bv
, size_t c_size
, SCM endianness
)
908 GENERIC_INTEGER_REF (signed);
912 bytevector_unsigned_ref (const char *c_bv
, size_t c_size
, SCM endianness
)
914 GENERIC_INTEGER_REF (unsigned);
918 /* Template of an integer assignment function. */
919 #define GENERIC_INTEGER_SET(_sign) \
924 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
927 c_value = SCM_I_INUM (value); \
931 if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \
933 _sign char c_value8; \
934 c_value8 = (_sign char) c_value; \
935 memcpy (c_bv, &c_value8, 1); \
942 if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \
945 INT_TYPE (16, _sign) c_value16; \
947 swap = !scm_is_eq (endianness, scm_i_native_endianness); \
950 c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \
952 c_value16 = c_value; \
954 memcpy (c_bv, &c_value16, 2); \
968 err = bytevector_large_set (c_bv, c_size, \
969 SIGNEDNESS (_sign), \
970 value, endianness); \
978 scm_out_of_range (FUNC_NAME, value); \
982 bytevector_signed_set (char *c_bv
, size_t c_size
,
983 SCM value
, SCM endianness
,
984 const char *func_name
)
985 #define FUNC_NAME func_name
987 GENERIC_INTEGER_SET (signed);
992 bytevector_unsigned_set (char *c_bv
, size_t c_size
,
993 SCM value
, SCM endianness
,
994 const char *func_name
)
995 #define FUNC_NAME func_name
997 GENERIC_INTEGER_SET (unsigned);
1001 #undef GENERIC_INTEGER_SET
1002 #undef GENERIC_INTEGER_REF
1005 SCM_DEFINE (scm_bytevector_uint_ref
, "bytevector-uint-ref", 4, 0, 0,
1006 (SCM bv
, SCM index
, SCM endianness
, SCM size
),
1007 "Return the @var{size}-octet long unsigned integer at index "
1008 "@var{index} in @var{bv}.")
1009 #define FUNC_NAME s_scm_bytevector_uint_ref
1011 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
1013 return (bytevector_unsigned_ref (&c_bv
[c_index
], c_size
, endianness
));
1017 SCM_DEFINE (scm_bytevector_sint_ref
, "bytevector-sint-ref", 4, 0, 0,
1018 (SCM bv
, SCM index
, SCM endianness
, SCM size
),
1019 "Return the @var{size}-octet long unsigned integer at index "
1020 "@var{index} in @var{bv}.")
1021 #define FUNC_NAME s_scm_bytevector_sint_ref
1023 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
1025 return (bytevector_signed_ref (&c_bv
[c_index
], c_size
, endianness
));
1029 SCM_DEFINE (scm_bytevector_uint_set_x
, "bytevector-uint-set!", 5, 0, 0,
1030 (SCM bv
, SCM index
, SCM value
, SCM endianness
, SCM size
),
1031 "Set the @var{size}-octet long unsigned integer at @var{index} "
1033 #define FUNC_NAME s_scm_bytevector_uint_set_x
1035 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
1037 bytevector_unsigned_set (&c_bv
[c_index
], c_size
, value
, endianness
,
1040 return SCM_UNSPECIFIED
;
1044 SCM_DEFINE (scm_bytevector_sint_set_x
, "bytevector-sint-set!", 5, 0, 0,
1045 (SCM bv
, SCM index
, SCM value
, SCM endianness
, SCM size
),
1046 "Set the @var{size}-octet long signed integer at @var{index} "
1048 #define FUNC_NAME s_scm_bytevector_sint_set_x
1050 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
1052 bytevector_signed_set (&c_bv
[c_index
], c_size
, value
, endianness
,
1055 return SCM_UNSPECIFIED
;
1061 /* Operations on integers of arbitrary size. */
1063 #define INTEGERS_TO_LIST(_sign) \
1065 size_t i, c_len, c_size; \
1067 SCM_VALIDATE_BYTEVECTOR (1, bv); \
1068 SCM_VALIDATE_SYMBOL (2, endianness); \
1069 c_size = scm_to_uint (size); \
1071 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
1072 if (SCM_UNLIKELY (c_len == 0)) \
1074 else if (SCM_UNLIKELY (c_len < c_size)) \
1075 scm_out_of_range (FUNC_NAME, size); \
1080 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1082 lst = scm_make_list (scm_from_uint (c_len / c_size), \
1084 for (i = 0, pair = lst; \
1085 i <= c_len - c_size; \
1086 i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
1089 bytevector_ ## _sign ## _ref (c_bv, c_size, \
1096 SCM_DEFINE (scm_bytevector_to_sint_list
, "bytevector->sint-list",
1098 (SCM bv
, SCM endianness
, SCM size
),
1099 "Return a list of signed integers of @var{size} octets "
1100 "representing the contents of @var{bv}.")
1101 #define FUNC_NAME s_scm_bytevector_to_sint_list
1103 INTEGERS_TO_LIST (signed);
1107 SCM_DEFINE (scm_bytevector_to_uint_list
, "bytevector->uint-list",
1109 (SCM bv
, SCM endianness
, SCM size
),
1110 "Return a list of unsigned integers of @var{size} octets "
1111 "representing the contents of @var{bv}.")
1112 #define FUNC_NAME s_scm_bytevector_to_uint_list
1114 INTEGERS_TO_LIST (unsigned);
1118 #undef INTEGER_TO_LIST
1121 #define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
1125 char *c_bv, *c_bv_ptr; \
1127 SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
1128 SCM_VALIDATE_SYMBOL (2, endianness); \
1129 c_size = scm_to_uint (size); \
1131 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
1132 scm_out_of_range (FUNC_NAME, size); \
1134 bv = make_bytevector (c_len * c_size); \
1135 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1137 for (c_bv_ptr = c_bv; \
1138 !scm_is_null (lst); \
1139 lst = SCM_CDR (lst), c_bv_ptr += c_size) \
1141 bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
1142 SCM_CAR (lst), endianness, \
1149 SCM_DEFINE (scm_uint_list_to_bytevector
, "uint-list->bytevector",
1151 (SCM lst
, SCM endianness
, SCM size
),
1152 "Return a bytevector containing the unsigned integers "
1153 "listed in @var{lst} and encoded on @var{size} octets "
1154 "according to @var{endianness}.")
1155 #define FUNC_NAME s_scm_uint_list_to_bytevector
1157 INTEGER_LIST_TO_BYTEVECTOR (unsigned);
1161 SCM_DEFINE (scm_sint_list_to_bytevector
, "sint-list->bytevector",
1163 (SCM lst
, SCM endianness
, SCM size
),
1164 "Return a bytevector containing the signed integers "
1165 "listed in @var{lst} and encoded on @var{size} octets "
1166 "according to @var{endianness}.")
1167 #define FUNC_NAME s_scm_sint_list_to_bytevector
1169 INTEGER_LIST_TO_BYTEVECTOR (signed);
1173 #undef INTEGER_LIST_TO_BYTEVECTOR
1177 /* Operations on 16-bit integers. */
1179 SCM_DEFINE (scm_bytevector_u16_ref
, "bytevector-u16-ref",
1181 (SCM bv
, SCM index
, SCM endianness
),
1182 "Return the unsigned 16-bit integer from @var{bv} at "
1184 #define FUNC_NAME s_scm_bytevector_u16_ref
1186 INTEGER_REF (16, unsigned);
1190 SCM_DEFINE (scm_bytevector_s16_ref
, "bytevector-s16-ref",
1192 (SCM bv
, SCM index
, SCM endianness
),
1193 "Return the signed 16-bit integer from @var{bv} at "
1195 #define FUNC_NAME s_scm_bytevector_s16_ref
1197 INTEGER_REF (16, signed);
1201 SCM_DEFINE (scm_bytevector_u16_native_ref
, "bytevector-u16-native-ref",
1203 (SCM bv
, SCM index
),
1204 "Return the unsigned 16-bit integer from @var{bv} at "
1205 "@var{index} using the native endianness.")
1206 #define FUNC_NAME s_scm_bytevector_u16_native_ref
1208 INTEGER_NATIVE_REF (16, unsigned);
1212 SCM_DEFINE (scm_bytevector_s16_native_ref
, "bytevector-s16-native-ref",
1214 (SCM bv
, SCM index
),
1215 "Return the unsigned 16-bit integer from @var{bv} at "
1216 "@var{index} using the native endianness.")
1217 #define FUNC_NAME s_scm_bytevector_s16_native_ref
1219 INTEGER_NATIVE_REF (16, signed);
1223 SCM_DEFINE (scm_bytevector_u16_set_x
, "bytevector-u16-set!",
1225 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1226 "Store @var{value} in @var{bv} at @var{index} according to "
1227 "@var{endianness}.")
1228 #define FUNC_NAME s_scm_bytevector_u16_set_x
1230 INTEGER_SET (16, unsigned);
1234 SCM_DEFINE (scm_bytevector_s16_set_x
, "bytevector-s16-set!",
1236 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1237 "Store @var{value} in @var{bv} at @var{index} according to "
1238 "@var{endianness}.")
1239 #define FUNC_NAME s_scm_bytevector_s16_set_x
1241 INTEGER_SET (16, signed);
1245 SCM_DEFINE (scm_bytevector_u16_native_set_x
, "bytevector-u16-native-set!",
1247 (SCM bv
, SCM index
, SCM value
),
1248 "Store the unsigned integer @var{value} at index @var{index} "
1249 "of @var{bv} using the native endianness.")
1250 #define FUNC_NAME s_scm_bytevector_u16_native_set_x
1252 INTEGER_NATIVE_SET (16, unsigned);
1256 SCM_DEFINE (scm_bytevector_s16_native_set_x
, "bytevector-s16-native-set!",
1258 (SCM bv
, SCM index
, SCM value
),
1259 "Store the signed integer @var{value} at index @var{index} "
1260 "of @var{bv} using the native endianness.")
1261 #define FUNC_NAME s_scm_bytevector_s16_native_set_x
1263 INTEGER_NATIVE_SET (16, signed);
1269 /* Operations on 32-bit integers. */
1271 /* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
1272 arbitrary 32-bit integers. Thus we fall back to using the
1273 `large_{ref,set}' variants on 32-bit machines. */
1275 #define LARGE_INTEGER_REF(_len, _sign) \
1276 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1277 SCM_VALIDATE_SYMBOL (3, endianness); \
1279 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1280 SIGNEDNESS (_sign), endianness));
1282 #define LARGE_INTEGER_SET(_len, _sign) \
1284 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1285 SCM_VALIDATE_SYMBOL (4, endianness); \
1287 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1288 SIGNEDNESS (_sign), value, endianness); \
1289 if (SCM_UNLIKELY (err)) \
1290 scm_out_of_range (FUNC_NAME, value); \
1292 return SCM_UNSPECIFIED;
1294 #define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
1295 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1296 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1297 SIGNEDNESS (_sign), scm_i_native_endianness));
1299 #define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
1301 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1303 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1304 SIGNEDNESS (_sign), value, \
1305 scm_i_native_endianness); \
1306 if (SCM_UNLIKELY (err)) \
1307 scm_out_of_range (FUNC_NAME, value); \
1309 return SCM_UNSPECIFIED;
1312 SCM_DEFINE (scm_bytevector_u32_ref
, "bytevector-u32-ref",
1314 (SCM bv
, SCM index
, SCM endianness
),
1315 "Return the unsigned 32-bit integer from @var{bv} at "
1317 #define FUNC_NAME s_scm_bytevector_u32_ref
1319 #if SIZEOF_VOID_P > 4
1320 INTEGER_REF (32, unsigned);
1322 LARGE_INTEGER_REF (32, unsigned);
1327 SCM_DEFINE (scm_bytevector_s32_ref
, "bytevector-s32-ref",
1329 (SCM bv
, SCM index
, SCM endianness
),
1330 "Return the signed 32-bit integer from @var{bv} at "
1332 #define FUNC_NAME s_scm_bytevector_s32_ref
1334 #if SIZEOF_VOID_P > 4
1335 INTEGER_REF (32, signed);
1337 LARGE_INTEGER_REF (32, signed);
1342 SCM_DEFINE (scm_bytevector_u32_native_ref
, "bytevector-u32-native-ref",
1344 (SCM bv
, SCM index
),
1345 "Return the unsigned 32-bit integer from @var{bv} at "
1346 "@var{index} using the native endianness.")
1347 #define FUNC_NAME s_scm_bytevector_u32_native_ref
1349 #if SIZEOF_VOID_P > 4
1350 INTEGER_NATIVE_REF (32, unsigned);
1352 LARGE_INTEGER_NATIVE_REF (32, unsigned);
1357 SCM_DEFINE (scm_bytevector_s32_native_ref
, "bytevector-s32-native-ref",
1359 (SCM bv
, SCM index
),
1360 "Return the unsigned 32-bit integer from @var{bv} at "
1361 "@var{index} using the native endianness.")
1362 #define FUNC_NAME s_scm_bytevector_s32_native_ref
1364 #if SIZEOF_VOID_P > 4
1365 INTEGER_NATIVE_REF (32, signed);
1367 LARGE_INTEGER_NATIVE_REF (32, signed);
1372 SCM_DEFINE (scm_bytevector_u32_set_x
, "bytevector-u32-set!",
1374 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1375 "Store @var{value} in @var{bv} at @var{index} according to "
1376 "@var{endianness}.")
1377 #define FUNC_NAME s_scm_bytevector_u32_set_x
1379 #if SIZEOF_VOID_P > 4
1380 INTEGER_SET (32, unsigned);
1382 LARGE_INTEGER_SET (32, unsigned);
1387 SCM_DEFINE (scm_bytevector_s32_set_x
, "bytevector-s32-set!",
1389 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1390 "Store @var{value} in @var{bv} at @var{index} according to "
1391 "@var{endianness}.")
1392 #define FUNC_NAME s_scm_bytevector_s32_set_x
1394 #if SIZEOF_VOID_P > 4
1395 INTEGER_SET (32, signed);
1397 LARGE_INTEGER_SET (32, signed);
1402 SCM_DEFINE (scm_bytevector_u32_native_set_x
, "bytevector-u32-native-set!",
1404 (SCM bv
, SCM index
, SCM value
),
1405 "Store the unsigned integer @var{value} at index @var{index} "
1406 "of @var{bv} using the native endianness.")
1407 #define FUNC_NAME s_scm_bytevector_u32_native_set_x
1409 #if SIZEOF_VOID_P > 4
1410 INTEGER_NATIVE_SET (32, unsigned);
1412 LARGE_INTEGER_NATIVE_SET (32, unsigned);
1417 SCM_DEFINE (scm_bytevector_s32_native_set_x
, "bytevector-s32-native-set!",
1419 (SCM bv
, SCM index
, SCM value
),
1420 "Store the signed integer @var{value} at index @var{index} "
1421 "of @var{bv} using the native endianness.")
1422 #define FUNC_NAME s_scm_bytevector_s32_native_set_x
1424 #if SIZEOF_VOID_P > 4
1425 INTEGER_NATIVE_SET (32, signed);
1427 LARGE_INTEGER_NATIVE_SET (32, signed);
1434 /* Operations on 64-bit integers. */
1436 /* For 64-bit integers, we use only the `large_{ref,set}' variant. */
1438 SCM_DEFINE (scm_bytevector_u64_ref
, "bytevector-u64-ref",
1440 (SCM bv
, SCM index
, SCM endianness
),
1441 "Return the unsigned 64-bit integer from @var{bv} at "
1443 #define FUNC_NAME s_scm_bytevector_u64_ref
1445 LARGE_INTEGER_REF (64, unsigned);
1449 SCM_DEFINE (scm_bytevector_s64_ref
, "bytevector-s64-ref",
1451 (SCM bv
, SCM index
, SCM endianness
),
1452 "Return the signed 64-bit integer from @var{bv} at "
1454 #define FUNC_NAME s_scm_bytevector_s64_ref
1456 LARGE_INTEGER_REF (64, signed);
1460 SCM_DEFINE (scm_bytevector_u64_native_ref
, "bytevector-u64-native-ref",
1462 (SCM bv
, SCM index
),
1463 "Return the unsigned 64-bit integer from @var{bv} at "
1464 "@var{index} using the native endianness.")
1465 #define FUNC_NAME s_scm_bytevector_u64_native_ref
1467 LARGE_INTEGER_NATIVE_REF (64, unsigned);
1471 SCM_DEFINE (scm_bytevector_s64_native_ref
, "bytevector-s64-native-ref",
1473 (SCM bv
, SCM index
),
1474 "Return the unsigned 64-bit integer from @var{bv} at "
1475 "@var{index} using the native endianness.")
1476 #define FUNC_NAME s_scm_bytevector_s64_native_ref
1478 LARGE_INTEGER_NATIVE_REF (64, signed);
1482 SCM_DEFINE (scm_bytevector_u64_set_x
, "bytevector-u64-set!",
1484 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1485 "Store @var{value} in @var{bv} at @var{index} according to "
1486 "@var{endianness}.")
1487 #define FUNC_NAME s_scm_bytevector_u64_set_x
1489 LARGE_INTEGER_SET (64, unsigned);
1493 SCM_DEFINE (scm_bytevector_s64_set_x
, "bytevector-s64-set!",
1495 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1496 "Store @var{value} in @var{bv} at @var{index} according to "
1497 "@var{endianness}.")
1498 #define FUNC_NAME s_scm_bytevector_s64_set_x
1500 LARGE_INTEGER_SET (64, signed);
1504 SCM_DEFINE (scm_bytevector_u64_native_set_x
, "bytevector-u64-native-set!",
1506 (SCM bv
, SCM index
, SCM value
),
1507 "Store the unsigned integer @var{value} at index @var{index} "
1508 "of @var{bv} using the native endianness.")
1509 #define FUNC_NAME s_scm_bytevector_u64_native_set_x
1511 LARGE_INTEGER_NATIVE_SET (64, unsigned);
1515 SCM_DEFINE (scm_bytevector_s64_native_set_x
, "bytevector-s64-native-set!",
1517 (SCM bv
, SCM index
, SCM value
),
1518 "Store the signed integer @var{value} at index @var{index} "
1519 "of @var{bv} using the native endianness.")
1520 #define FUNC_NAME s_scm_bytevector_s64_native_set_x
1522 LARGE_INTEGER_NATIVE_SET (64, signed);
1528 /* Operations on IEEE-754 numbers. */
1530 /* There are two possible word endians, visible in glibc's <ieee754.h>.
1531 However, in R6RS, when the endianness is `little', little endian is
1532 assumed for both the byte order and the word order. This is clear from
1533 Section 2.1 of R6RS-lib (in response to
1534 http://www.r6rs.org/formal-comments/comment-187.txt). */
1537 /* Convert to/from a floating-point number with different endianness. This
1538 method is probably not the most efficient but it should be portable. */
1541 float_to_foreign_endianness (union scm_ieee754_float
*target
,
1544 union scm_ieee754_float src
;
1548 #ifdef WORDS_BIGENDIAN
1549 /* Assuming little endian for both byte and word order. */
1550 target
->little_endian
.negative
= src
.big_endian
.negative
;
1551 target
->little_endian
.exponent
= src
.big_endian
.exponent
;
1552 target
->little_endian
.mantissa
= src
.big_endian
.mantissa
;
1554 target
->big_endian
.negative
= src
.little_endian
.negative
;
1555 target
->big_endian
.exponent
= src
.little_endian
.exponent
;
1556 target
->big_endian
.mantissa
= src
.little_endian
.mantissa
;
1561 float_from_foreign_endianness (const union scm_ieee754_float
*source
)
1563 union scm_ieee754_float result
;
1565 #ifdef WORDS_BIGENDIAN
1566 /* Assuming little endian for both byte and word order. */
1567 result
.big_endian
.negative
= source
->little_endian
.negative
;
1568 result
.big_endian
.exponent
= source
->little_endian
.exponent
;
1569 result
.big_endian
.mantissa
= source
->little_endian
.mantissa
;
1571 result
.little_endian
.negative
= source
->big_endian
.negative
;
1572 result
.little_endian
.exponent
= source
->big_endian
.exponent
;
1573 result
.little_endian
.mantissa
= source
->big_endian
.mantissa
;
1580 double_to_foreign_endianness (union scm_ieee754_double
*target
,
1583 union scm_ieee754_double src
;
1587 #ifdef WORDS_BIGENDIAN
1588 /* Assuming little endian for both byte and word order. */
1589 target
->little_little_endian
.negative
= src
.big_endian
.negative
;
1590 target
->little_little_endian
.exponent
= src
.big_endian
.exponent
;
1591 target
->little_little_endian
.mantissa0
= src
.big_endian
.mantissa0
;
1592 target
->little_little_endian
.mantissa1
= src
.big_endian
.mantissa1
;
1594 target
->big_endian
.negative
= src
.little_little_endian
.negative
;
1595 target
->big_endian
.exponent
= src
.little_little_endian
.exponent
;
1596 target
->big_endian
.mantissa0
= src
.little_little_endian
.mantissa0
;
1597 target
->big_endian
.mantissa1
= src
.little_little_endian
.mantissa1
;
1601 static inline double
1602 double_from_foreign_endianness (const union scm_ieee754_double
*source
)
1604 union scm_ieee754_double result
;
1606 #ifdef WORDS_BIGENDIAN
1607 /* Assuming little endian for both byte and word order. */
1608 result
.big_endian
.negative
= source
->little_little_endian
.negative
;
1609 result
.big_endian
.exponent
= source
->little_little_endian
.exponent
;
1610 result
.big_endian
.mantissa0
= source
->little_little_endian
.mantissa0
;
1611 result
.big_endian
.mantissa1
= source
->little_little_endian
.mantissa1
;
1613 result
.little_little_endian
.negative
= source
->big_endian
.negative
;
1614 result
.little_little_endian
.exponent
= source
->big_endian
.exponent
;
1615 result
.little_little_endian
.mantissa0
= source
->big_endian
.mantissa0
;
1616 result
.little_little_endian
.mantissa1
= source
->big_endian
.mantissa1
;
1622 /* Template macros to abstract over doubles and floats.
1623 XXX: Guile can only convert to/from doubles. */
1624 #define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type
1625 #define IEEE754_TO_SCM(_c_type) scm_from_double
1626 #define IEEE754_FROM_SCM(_c_type) scm_to_double
1627 #define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
1628 _c_type ## _from_foreign_endianness
1629 #define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
1630 _c_type ## _to_foreign_endianness
1633 /* Templace getters and setters. */
1635 #define IEEE754_ACCESSOR_PROLOGUE(_type) \
1636 INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
1638 #define IEEE754_REF(_type) \
1641 IEEE754_ACCESSOR_PROLOGUE (_type); \
1642 SCM_VALIDATE_SYMBOL (3, endianness); \
1644 if (scm_is_eq (endianness, scm_i_native_endianness)) \
1645 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1648 IEEE754_UNION (_type) c_raw; \
1650 memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
1652 IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
1655 return (IEEE754_TO_SCM (_type) (c_result));
1657 #define IEEE754_NATIVE_REF(_type) \
1660 IEEE754_ACCESSOR_PROLOGUE (_type); \
1662 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1663 return (IEEE754_TO_SCM (_type) (c_result));
1665 #define IEEE754_SET(_type) \
1668 IEEE754_ACCESSOR_PROLOGUE (_type); \
1669 SCM_VALIDATE_REAL (3, value); \
1670 SCM_VALIDATE_SYMBOL (4, endianness); \
1671 c_value = IEEE754_FROM_SCM (_type) (value); \
1673 if (scm_is_eq (endianness, scm_i_native_endianness)) \
1674 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1677 IEEE754_UNION (_type) c_raw; \
1679 IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
1680 memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
1683 return SCM_UNSPECIFIED;
1685 #define IEEE754_NATIVE_SET(_type) \
1688 IEEE754_ACCESSOR_PROLOGUE (_type); \
1689 SCM_VALIDATE_REAL (3, value); \
1690 c_value = IEEE754_FROM_SCM (_type) (value); \
1692 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1693 return SCM_UNSPECIFIED;
1696 /* Single precision. */
1698 SCM_DEFINE (scm_bytevector_ieee_single_ref
,
1699 "bytevector-ieee-single-ref",
1701 (SCM bv
, SCM index
, SCM endianness
),
1702 "Return the IEEE-754 single from @var{bv} at "
1704 #define FUNC_NAME s_scm_bytevector_ieee_single_ref
1706 IEEE754_REF (float);
1710 SCM_DEFINE (scm_bytevector_ieee_single_native_ref
,
1711 "bytevector-ieee-single-native-ref",
1713 (SCM bv
, SCM index
),
1714 "Return the IEEE-754 single from @var{bv} at "
1715 "@var{index} using the native endianness.")
1716 #define FUNC_NAME s_scm_bytevector_ieee_single_native_ref
1718 IEEE754_NATIVE_REF (float);
1722 SCM_DEFINE (scm_bytevector_ieee_single_set_x
,
1723 "bytevector-ieee-single-set!",
1725 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1726 "Store real @var{value} in @var{bv} at @var{index} according to "
1727 "@var{endianness}.")
1728 #define FUNC_NAME s_scm_bytevector_ieee_single_set_x
1730 IEEE754_SET (float);
1734 SCM_DEFINE (scm_bytevector_ieee_single_native_set_x
,
1735 "bytevector-ieee-single-native-set!",
1737 (SCM bv
, SCM index
, SCM value
),
1738 "Store the real @var{value} at index @var{index} "
1739 "of @var{bv} using the native endianness.")
1740 #define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x
1742 IEEE754_NATIVE_SET (float);
1747 /* Double precision. */
1749 SCM_DEFINE (scm_bytevector_ieee_double_ref
,
1750 "bytevector-ieee-double-ref",
1752 (SCM bv
, SCM index
, SCM endianness
),
1753 "Return the IEEE-754 double from @var{bv} at "
1755 #define FUNC_NAME s_scm_bytevector_ieee_double_ref
1757 IEEE754_REF (double);
1761 SCM_DEFINE (scm_bytevector_ieee_double_native_ref
,
1762 "bytevector-ieee-double-native-ref",
1764 (SCM bv
, SCM index
),
1765 "Return the IEEE-754 double from @var{bv} at "
1766 "@var{index} using the native endianness.")
1767 #define FUNC_NAME s_scm_bytevector_ieee_double_native_ref
1769 IEEE754_NATIVE_REF (double);
1773 SCM_DEFINE (scm_bytevector_ieee_double_set_x
,
1774 "bytevector-ieee-double-set!",
1776 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1777 "Store real @var{value} in @var{bv} at @var{index} according to "
1778 "@var{endianness}.")
1779 #define FUNC_NAME s_scm_bytevector_ieee_double_set_x
1781 IEEE754_SET (double);
1785 SCM_DEFINE (scm_bytevector_ieee_double_native_set_x
,
1786 "bytevector-ieee-double-native-set!",
1788 (SCM bv
, SCM index
, SCM value
),
1789 "Store the real @var{value} at index @var{index} "
1790 "of @var{bv} using the native endianness.")
1791 #define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x
1793 IEEE754_NATIVE_SET (double);
1798 #undef IEEE754_UNION
1799 #undef IEEE754_TO_SCM
1800 #undef IEEE754_FROM_SCM
1801 #undef IEEE754_FROM_FOREIGN_ENDIANNESS
1802 #undef IEEE754_TO_FOREIGN_ENDIANNESS
1804 #undef IEEE754_NATIVE_REF
1806 #undef IEEE754_NATIVE_SET
1809 /* Operations on strings. */
1812 /* Produce a function that returns the length of a UTF-encoded string. */
1813 #define UTF_STRLEN_FUNCTION(_utf_width) \
1814 static inline size_t \
1815 utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
1818 const uint ## _utf_width ## _t *ptr; \
1826 return (len * ((_utf_width) / 8)); \
1829 UTF_STRLEN_FUNCTION (8)
1832 /* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
1833 #define UTF_STRLEN(_utf_width, _str) \
1834 utf ## _utf_width ## _strlen (_str)
1836 /* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
1837 ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
1840 utf_encoding_name (char *name
, size_t utf_width
, SCM endianness
)
1842 strcpy (name
, "UTF-");
1843 strcat (name
, ((utf_width
== 8)
1845 : ((utf_width
== 16)
1847 : ((utf_width
== 32)
1851 ((scm_is_eq (endianness
, scm_sym_big
))
1853 : ((scm_is_eq (endianness
, scm_sym_little
))
1858 /* Maximum length of a UTF encoding name. */
1859 #define MAX_UTF_ENCODING_NAME_LEN 16
1861 /* Produce the body of a `string->utf' function. */
1862 #define STRING_TO_UTF(_utf_width) \
1866 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1867 char *c_utf = NULL, *c_locale; \
1868 size_t c_strlen, c_raw_strlen, c_utf_len = 0; \
1870 SCM_VALIDATE_STRING (1, str); \
1871 if (endianness == SCM_UNDEFINED) \
1872 endianness = scm_sym_big; \
1874 SCM_VALIDATE_SYMBOL (2, endianness); \
1876 c_strlen = scm_c_string_length (str); \
1877 c_raw_strlen = c_strlen * ((_utf_width) / 8); \
1880 c_str = (char *) alloca (c_raw_strlen + 1); \
1881 c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \
1883 while (c_raw_strlen > c_strlen); \
1884 c_str[c_raw_strlen] = '\0'; \
1886 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1888 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1889 strcpy (c_locale, locale_charset ()); \
1891 err = mem_iconveh (c_str, c_raw_strlen, \
1892 c_locale, c_utf_name, \
1893 iconveh_question_mark, NULL, \
1894 &c_utf, &c_utf_len); \
1895 if (SCM_UNLIKELY (err)) \
1896 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1897 scm_list_1 (str), err); \
1899 /* C_UTF is null-terminated. */ \
1900 utf = scm_c_take_bytevector ((signed char *) c_utf, \
1907 SCM_DEFINE (scm_string_to_utf8
, "string->utf8",
1910 "Return a newly allocated bytevector that contains the UTF-8 "
1911 "encoding of @var{str}.")
1912 #define FUNC_NAME s_scm_string_to_utf8
1917 size_t c_strlen
, c_raw_strlen
;
1919 SCM_VALIDATE_STRING (1, str
);
1921 c_strlen
= scm_c_string_length (str
);
1922 c_raw_strlen
= c_strlen
;
1925 c_str
= (char *) alloca (c_raw_strlen
+ 1);
1926 c_raw_strlen
= scm_to_locale_stringbuf (str
, c_str
, c_strlen
);
1928 while (c_raw_strlen
> c_strlen
);
1929 c_str
[c_raw_strlen
] = '\0';
1931 c_utf
= u8_strconv_from_locale (c_str
);
1932 if (SCM_UNLIKELY (c_utf
== NULL
))
1933 scm_syserror (FUNC_NAME
);
1935 /* C_UTF is null-terminated. */
1936 utf
= scm_c_take_bytevector ((signed char *) c_utf
,
1937 UTF_STRLEN (8, c_utf
));
1943 SCM_DEFINE (scm_string_to_utf16
, "string->utf16",
1945 (SCM str
, SCM endianness
),
1946 "Return a newly allocated bytevector that contains the UTF-16 "
1947 "encoding of @var{str}.")
1948 #define FUNC_NAME s_scm_string_to_utf16
1954 SCM_DEFINE (scm_string_to_utf32
, "string->utf32",
1956 (SCM str
, SCM endianness
),
1957 "Return a newly allocated bytevector that contains the UTF-32 "
1958 "encoding of @var{str}.")
1959 #define FUNC_NAME s_scm_string_to_utf32
1966 /* Produce the body of a function that converts a UTF-encoded bytevector to a
1968 #define UTF_TO_STRING(_utf_width) \
1969 SCM str = SCM_BOOL_F; \
1971 char *c_str = NULL, *c_locale; \
1972 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1973 const char *c_utf; \
1974 size_t c_strlen = 0, c_utf_len; \
1976 SCM_VALIDATE_BYTEVECTOR (1, utf); \
1977 if (endianness == SCM_UNDEFINED) \
1978 endianness = scm_sym_big; \
1980 SCM_VALIDATE_SYMBOL (2, endianness); \
1982 c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \
1983 c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
1984 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1986 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1987 strcpy (c_locale, locale_charset ()); \
1989 err = mem_iconveh (c_utf, c_utf_len, \
1990 c_utf_name, c_locale, \
1991 iconveh_question_mark, NULL, \
1992 &c_str, &c_strlen); \
1993 if (SCM_UNLIKELY (err)) \
1994 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
1995 scm_list_1 (utf), err); \
1997 /* C_STR is null-terminated. */ \
1998 str = scm_take_locale_stringn (c_str, c_strlen); \
2003 SCM_DEFINE (scm_utf8_to_string
, "utf8->string",
2006 "Return a newly allocate string that contains from the UTF-8-"
2007 "encoded contents of bytevector @var{utf}.")
2008 #define FUNC_NAME s_scm_utf8_to_string
2012 char *c_str
= NULL
, *c_locale
;
2014 size_t c_utf_len
, c_strlen
= 0;
2016 SCM_VALIDATE_BYTEVECTOR (1, utf
);
2018 c_utf_len
= SCM_BYTEVECTOR_LENGTH (utf
);
2020 c_locale
= (char *) alloca (strlen (locale_charset ()) + 1);
2021 strcpy (c_locale
, locale_charset ());
2023 c_utf
= (char *) SCM_BYTEVECTOR_CONTENTS (utf
);
2024 err
= mem_iconveh (c_utf
, c_utf_len
,
2026 iconveh_question_mark
, NULL
,
2028 if (SCM_UNLIKELY (err
))
2029 scm_syserror_msg (FUNC_NAME
, "failed to convert to string: ~A",
2030 scm_list_1 (utf
), err
);
2032 /* C_STR is null-terminated. */
2033 str
= scm_take_locale_stringn (c_str
, c_strlen
);
2039 SCM_DEFINE (scm_utf16_to_string
, "utf16->string",
2041 (SCM utf
, SCM endianness
),
2042 "Return a newly allocate string that contains from the UTF-16-"
2043 "encoded contents of bytevector @var{utf}.")
2044 #define FUNC_NAME s_scm_utf16_to_string
2050 SCM_DEFINE (scm_utf32_to_string
, "utf32->string",
2052 (SCM utf
, SCM endianness
),
2053 "Return a newly allocate string that contains from the UTF-32-"
2054 "encoded contents of bytevector @var{utf}.")
2055 #define FUNC_NAME s_scm_utf32_to_string
2063 /* Bytevectors as generalized vectors & arrays. */
2066 bv_handle_ref (scm_t_array_handle
*h
, size_t index
)
2068 return SCM_I_MAKINUM (scm_c_bytevector_ref (h
->array
, index
));
2072 bv_handle_set_x (scm_t_array_handle
*h
, size_t index
, SCM val
)
2074 scm_c_bytevector_set_x (h
->array
, index
, scm_to_uint8 (val
));
2078 bytevector_get_handle (SCM v
, scm_t_array_handle
*h
)
2084 h
->dim0
.ubnd
= SCM_BYTEVECTOR_LENGTH (v
) - 1;
2086 h
->element_type
= SCM_ARRAY_ELEMENT_TYPE_VU8
;
2087 h
->elements
= h
->writable_elements
= SCM_BYTEVECTOR_CONTENTS (v
);
2091 /* Initialization. */
2094 scm_bootstrap_bytevectors (void)
2096 /* The SMOB type must be instantiated here because the
2097 generalized-vector API may want to access bytevectors even though
2098 `(rnrs bytevector)' hasn't been loaded. */
2099 scm_tc16_bytevector
= scm_make_smob_type ("bytevector", 0);
2100 scm_set_smob_free (scm_tc16_bytevector
, free_bytevector
);
2101 scm_set_smob_print (scm_tc16_bytevector
, print_bytevector
);
2102 scm_set_smob_equalp (scm_tc16_bytevector
, bytevector_equal_p
);
2104 scm_null_bytevector
=
2105 scm_gc_protect_object (make_bytevector_from_buffer (0, NULL
));
2107 #ifdef WORDS_BIGENDIAN
2108 scm_i_native_endianness
= scm_permanent_object (scm_from_locale_symbol ("big"));
2110 scm_i_native_endianness
= scm_permanent_object (scm_from_locale_symbol ("little"));
2113 scm_c_register_extension ("libguile", "scm_init_bytevectors",
2114 (scm_t_extension_init_func
) scm_init_bytevectors
,
2118 scm_t_array_implementation impl
;
2119 impl
.tag
= scm_tc16_bytevector
;
2121 impl
.vref
= bv_handle_ref
;
2122 impl
.vset
= bv_handle_set_x
;
2123 impl
.get_handle
= bytevector_get_handle
;
2124 scm_i_register_array_implementation (&impl
);
2129 scm_init_bytevectors (void)
2131 #include "libguile/bytevectors.x"
2133 scm_endianness_big
= scm_sym_big
;
2134 scm_endianness_little
= scm_sym_little
;