1 /* Guile-R6RS-Libs --- Implementation of R6RS standard libraries.
2 Copyright (C) 2007, 2008 Ludovic Courtès <ludo@gnu.org>
4 Guile-R6RS-Libs is free software; you can redistribute it and/or
5 modify it under the terms of the GNU Lesser General Public
6 License as published by the Free Software Foundation; either
7 version 2.1 of the License, or (at your option) any later version.
9 Guile-R6RS-Libs is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 Lesser General Public License for more details.
14 You should have received a copy of the GNU Lesser General Public
15 License along with Guile-R6RS-Libs; if not, write to the Free Software
16 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */
25 #include "bytevector.h"
35 /* Assuming 32-bit longs. */
36 # define ULONG_MAX 4294967295UL
45 /* Convenience macros. These are used by the various templates (macros) that
46 are parameterized by integer signedness. */
47 #define INT8_T_signed scm_t_int8
48 #define INT8_T_unsigned scm_t_uint8
49 #define INT16_T_signed scm_t_int16
50 #define INT16_T_unsigned scm_t_uint16
51 #define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L))
52 #define is_unsigned_int8(_x) ((_x) <= 255UL)
53 #define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
54 #define is_unsigned_int16(_x) ((_x) <= 65535UL)
55 #define SIGNEDNESS_signed 1
56 #define SIGNEDNESS_unsigned 0
58 #define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign
59 #define INT_SWAP(_size) bswap_ ## _size
60 #define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
61 #define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
64 #define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \
65 unsigned c_len, c_index; \
68 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv); \
69 c_index = scm_to_uint (index); \
71 c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv); \
72 c_bv = (_sign char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv); \
74 if (EXPECT_FALSE (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
75 scm_out_of_range (FUNC_NAME, index);
77 /* Template for fixed-size integer access (only 8, 16 or 32-bit). */
78 #define INTEGER_REF(_len, _sign) \
81 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
82 SCM_VALIDATE_SYMBOL (3, endianness); \
85 INT_TYPE (_len, _sign) c_result; \
87 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
88 if (!scm_is_eq (endianness, native_endianness)) \
89 c_result = INT_SWAP (_len) (c_result); \
91 result = SCM_I_MAKINUM (c_result); \
96 /* Template for fixed-size integer access using the native endianness. */
97 #define INTEGER_NATIVE_REF(_len, _sign) \
100 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
103 INT_TYPE (_len, _sign) c_result; \
105 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
106 result = SCM_I_MAKINUM (c_result); \
111 /* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
112 #define INTEGER_SET(_len, _sign) \
113 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
114 SCM_VALIDATE_SYMBOL (3, endianness); \
117 _sign long c_value; \
118 INT_TYPE (_len, _sign) c_value_short; \
120 if (EXPECT_FALSE (!SCM_I_INUMP (value))) \
121 scm_wrong_type_arg (FUNC_NAME, 3, value); \
123 c_value = SCM_I_INUM (value); \
124 if (EXPECT_FALSE (!INT_VALID_P (_len, _sign) (c_value))) \
125 scm_out_of_range (FUNC_NAME, value); \
127 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
128 if (!scm_is_eq (endianness, native_endianness)) \
129 c_value_short = INT_SWAP (_len) (c_value_short); \
131 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
134 return SCM_UNSPECIFIED;
136 /* Template for fixed-size integer modification using the native
138 #define INTEGER_NATIVE_SET(_len, _sign) \
139 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
142 _sign long c_value; \
143 INT_TYPE (_len, _sign) c_value_short; \
145 if (EXPECT_FALSE (!SCM_I_INUMP (value))) \
146 scm_wrong_type_arg (FUNC_NAME, 3, value); \
148 c_value = SCM_I_INUM (value); \
149 if (EXPECT_FALSE (!INT_VALID_P (_len, _sign) (c_value))) \
150 scm_out_of_range (FUNC_NAME, value); \
152 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
154 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
157 return SCM_UNSPECIFIED;
161 /* Bytevector type. */
163 SCM_GLOBAL_SMOB (scm_tc16_r6rs_bytevector
, "r6rs-bytevector", 0);
165 #define SCM_R6RS_BYTEVECTOR_SET_LENGTH(_bv, _len) \
166 SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len))
167 #define SCM_R6RS_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
168 SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf))
170 /* The empty bytevector. */
171 SCM scm_r6rs_null_bytevector
= SCM_UNSPECIFIED
;
175 make_bytevector_from_buffer (unsigned len
, signed char *contents
)
177 /* Assuming LEN > SCM_R6RS_BYTEVECTOR_INLINE_THRESHOLD. */
178 SCM_RETURN_NEWSMOB2 (scm_tc16_r6rs_bytevector
, len
, contents
);
182 make_bytevector (unsigned len
)
186 if (EXPECT_FALSE (len
== 0))
187 bv
= scm_r6rs_null_bytevector
;
190 signed char *contents
= NULL
;
192 if (!SCM_R6RS_BYTEVECTOR_INLINEABLE_SIZE_P (len
))
193 contents
= (signed char *) scm_gc_malloc (len
, SCM_GC_BYTEVECTOR
);
195 bv
= make_bytevector_from_buffer (len
, contents
);
201 /* Return a new bytevector of size LEN octets. */
203 scm_r6rs_c_make_bytevector (unsigned len
)
205 return (make_bytevector (len
));
208 /* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
209 by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
211 scm_r6rs_c_take_bytevector (signed char *contents
, unsigned len
)
215 if (EXPECT_FALSE (SCM_R6RS_BYTEVECTOR_INLINEABLE_SIZE_P (len
)))
217 /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */
220 bv
= make_bytevector (len
);
221 c_bv
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
222 memcpy (c_bv
, contents
, len
);
223 scm_gc_free (contents
, len
, SCM_GC_BYTEVECTOR
);
226 bv
= make_bytevector_from_buffer (len
, contents
);
231 /* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
232 size) and return BV. */
234 scm_r6rs_i_shrink_bytevector (SCM bv
, unsigned c_new_len
)
236 if (!SCM_R6RS_BYTEVECTOR_INLINE_P (bv
))
239 signed char *c_bv
, *c_new_bv
;
241 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
242 c_bv
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
244 SCM_R6RS_BYTEVECTOR_SET_LENGTH (bv
, c_new_len
);
246 if (SCM_R6RS_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len
))
248 /* Copy to the in-line buffer and free the current buffer. */
249 c_new_bv
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
250 memcpy (c_new_bv
, c_bv
, c_new_len
);
251 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
255 /* Resize the existing buffer. */
256 c_new_bv
= scm_gc_realloc (c_bv
, c_len
, c_new_len
,
258 SCM_R6RS_BYTEVECTOR_SET_CONTENTS (bv
, c_new_bv
);
265 SCM_SMOB_PRINT (scm_tc16_r6rs_bytevector
, print_bytevector
,
271 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
272 c_bv
= (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
274 scm_puts ("#vu8(", port
);
275 for (i
= 0; i
< c_len
; i
++)
278 scm_putc (' ', port
);
280 scm_uintprint (c_bv
[i
], 10, port
);
283 scm_putc (')', port
);
288 SCM_SMOB_FREE (scm_tc16_r6rs_bytevector
, free_bytevector
, bv
)
291 if (!SCM_R6RS_BYTEVECTOR_INLINE_P (bv
))
296 c_bv
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
297 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
299 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
307 /* General operations. */
309 SCM_SYMBOL (scm_sym_big
, "big");
310 SCM_SYMBOL (scm_sym_little
, "little");
312 /* Host endianness (a symbol). */
313 static SCM native_endianness
= SCM_UNSPECIFIED
;
317 # define bswap_24(_x) \
318 ((((_x) & 0xff0000) >> 16) | \
319 (((_x) & 0x00ff00)) | \
320 (((_x) & 0x0000ff) << 16))
324 SCM_DEFINE (scm_r6rs_native_endianness
, "native-endianness", 0, 0, 0,
326 "Return a symbol denoting the machine's native endianness.")
327 #define FUNC_NAME s_scm_r6rs_native_endianness
329 return native_endianness
;
333 SCM_DEFINE (scm_r6rs_bytevector_p
, "bytevector?", 1, 0, 0,
335 "Return true if @var{obj} is a bytevector.")
336 #define FUNC_NAME s_scm_r6rs_bytevector_p
338 return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_r6rs_bytevector
,
343 SCM_DEFINE (scm_r6rs_make_bytevector
, "make-bytevector", 1, 1, 0,
345 "Return a newly allocated bytevector of @var{len} bytes, "
346 "optionally filled with @var{fill}.")
347 #define FUNC_NAME s_scm_r6rs_make_bytevector
351 signed char c_fill
= '\0';
353 SCM_VALIDATE_UINT_COPY (1, len
, c_len
);
354 if (fill
!= SCM_UNDEFINED
)
358 value
= scm_to_int (fill
);
359 if (EXPECT_FALSE ((value
< -128) || (value
> 255)))
360 scm_out_of_range (FUNC_NAME
, fill
);
361 c_fill
= (signed char) value
;
364 bv
= make_bytevector (c_len
);
365 if (fill
!= SCM_UNDEFINED
)
368 signed char *contents
;
370 contents
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
371 for (i
= 0; i
< c_len
; i
++)
372 contents
[i
] = c_fill
;
379 SCM_DEFINE (scm_r6rs_bytevector_length
, "bytevector-length", 1, 0, 0,
381 "Return the length (in bytes) of @var{bv}.")
382 #define FUNC_NAME s_scm_r6rs_bytevector_length
384 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv
);
386 return (scm_from_uint (SCM_R6RS_BYTEVECTOR_LENGTH (bv
)));
390 SCM_DEFINE (scm_r6rs_bytevector_eq_p
, "bytevector=?", 2, 0, 0,
392 "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
393 "have the same length and contents.")
394 #define FUNC_NAME s_scm_r6rs_bytevector_eq_p
396 SCM result
= SCM_BOOL_F
;
397 unsigned c_len1
, c_len2
;
399 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv1
);
400 SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv2
);
402 c_len1
= SCM_R6RS_BYTEVECTOR_LENGTH (bv1
);
403 c_len2
= SCM_R6RS_BYTEVECTOR_LENGTH (bv2
);
405 if (c_len1
== c_len2
)
407 signed char *c_bv1
, *c_bv2
;
409 c_bv1
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv1
);
410 c_bv2
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv2
);
412 result
= scm_from_bool (!memcmp (c_bv1
, c_bv2
, c_len1
));
419 SCM_DEFINE (scm_r6rs_bytevector_fill_x
, "bytevector-fill!", 2, 0, 0,
421 "Fill bytevector @var{bv} with @var{fill}, a byte.")
422 #define FUNC_NAME s_scm_r6rs_bytevector_fill_x
425 signed char *c_bv
, c_fill
;
427 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv
);
428 c_fill
= scm_to_int8 (fill
);
430 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
431 c_bv
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
433 for (i
= 0; i
< c_len
; i
++)
436 return SCM_UNSPECIFIED
;
440 SCM_DEFINE (scm_r6rs_bytevector_copy_x
, "bytevector-copy!", 5, 0, 0,
441 (SCM source
, SCM source_start
, SCM target
, SCM target_start
,
443 "Copy @var{len} bytes from @var{source} into @var{target}, "
444 "starting reading from @var{source_start} (a positive index "
445 "within @var{source}) and start writing at "
446 "@var{target_start}.")
447 #define FUNC_NAME s_scm_r6rs_bytevector_copy_x
449 unsigned c_len
, c_source_len
, c_target_len
;
450 unsigned c_source_start
, c_target_start
;
451 signed char *c_source
, *c_target
;
453 SCM_VALIDATE_R6RS_BYTEVECTOR (1, source
);
454 SCM_VALIDATE_R6RS_BYTEVECTOR (3, target
);
456 c_len
= scm_to_uint (len
);
457 c_source_start
= scm_to_uint (source_start
);
458 c_target_start
= scm_to_uint (target_start
);
460 c_source
= SCM_R6RS_BYTEVECTOR_CONTENTS (source
);
461 c_target
= SCM_R6RS_BYTEVECTOR_CONTENTS (target
);
462 c_source_len
= SCM_R6RS_BYTEVECTOR_LENGTH (source
);
463 c_target_len
= SCM_R6RS_BYTEVECTOR_LENGTH (target
);
465 if (EXPECT_FALSE (c_source_start
+ c_len
> c_source_len
))
466 scm_out_of_range (FUNC_NAME
, source_start
);
467 if (EXPECT_FALSE (c_target_start
+ c_len
> c_target_len
))
468 scm_out_of_range (FUNC_NAME
, target_start
);
470 memcpy (c_target
+ c_target_start
,
471 c_source
+ c_source_start
,
474 return SCM_UNSPECIFIED
;
478 SCM_DEFINE (scm_r6rs_bytevector_copy
, "bytevector-copy", 1, 0, 0,
480 "Return a newly allocated copy of @var{bv}.")
481 #define FUNC_NAME s_scm_r6rs_bytevector_copy
485 signed char *c_bv
, *c_copy
;
487 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv
);
489 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
490 c_bv
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
492 copy
= make_bytevector (c_len
);
493 c_copy
= SCM_R6RS_BYTEVECTOR_CONTENTS (copy
);
494 memcpy (c_copy
, c_bv
, c_len
);
501 /* Operations on bytes and octets. */
503 SCM_DEFINE (scm_r6rs_bytevector_u8_ref
, "bytevector-u8-ref", 2, 0, 0,
505 "Return the octet located at @var{index} in @var{bv}.")
506 #define FUNC_NAME s_scm_r6rs_bytevector_u8_ref
508 INTEGER_NATIVE_REF (8, unsigned);
512 SCM_DEFINE (scm_r6rs_bytevector_s8_ref
, "bytevector-s8-ref", 2, 0, 0,
514 "Return the byte located at @var{index} in @var{bv}.")
515 #define FUNC_NAME s_scm_r6rs_bytevector_u8_ref
517 INTEGER_NATIVE_REF (8, signed);
521 SCM_DEFINE (scm_r6rs_bytevector_u8_set_x
, "bytevector-u8-set!", 3, 0, 0,
522 (SCM bv
, SCM index
, SCM value
),
523 "Return the octet located at @var{index} in @var{bv}.")
524 #define FUNC_NAME s_scm_r6rs_bytevector_u8_set_x
526 INTEGER_NATIVE_SET (8, unsigned);
530 SCM_DEFINE (scm_r6rs_bytevector_s8_set_x
, "bytevector-s8-set!", 3, 0, 0,
531 (SCM bv
, SCM index
, SCM value
),
532 "Return the octet located at @var{index} in @var{bv}.")
533 #define FUNC_NAME s_scm_r6rs_bytevector_u8_set_x
535 INTEGER_NATIVE_SET (8, signed);
539 #undef OCTET_ACCESSOR_PROLOGUE
542 SCM_DEFINE (scm_r6rs_bytevector_to_u8_list
, "bytevector->u8-list", 1, 0, 0,
544 "Return a newly allocated list of octets containing the "
545 "contents of @var{bv}.")
546 #define FUNC_NAME s_scm_r6rs_bytevector_to_u8_list
552 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv
);
554 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
555 c_bv
= (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
557 lst
= scm_make_list (scm_from_uint (c_len
), SCM_UNSPECIFIED
);
558 for (i
= 0, pair
= lst
;
560 i
++, pair
= SCM_CDR (pair
))
562 SCM_SETCAR (pair
, SCM_I_MAKINUM (c_bv
[i
]));
569 SCM_DEFINE (scm_r6rs_u8_list_to_bytevector
, "u8-list->bytevector", 1, 0, 0,
571 "Turn @var{lst}, a list of octets, into a bytevector.")
572 #define FUNC_NAME s_scm_r6rs_u8_list_to_bytevector
578 SCM_VALIDATE_LIST_COPYLEN (1, lst
, c_len
);
580 bv
= make_bytevector (c_len
);
581 c_bv
= (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
583 for (i
= 0; i
< c_len
; lst
= SCM_CDR (lst
), i
++)
585 item
= SCM_CAR (lst
);
587 if (EXPECT_TRUE (SCM_I_INUMP (item
)))
591 c_item
= SCM_I_INUM (item
);
592 if (EXPECT_TRUE ((c_item
>= 0) && (c_item
< 256)))
593 c_bv
[i
] = (unsigned char) c_item
;
604 scm_wrong_type_arg (FUNC_NAME
, 1, item
);
610 /* Compute the two's complement of VALUE (a positive integer) on SIZE octets
611 using (2^(SIZE * 8) - VALUE). */
613 twos_complement (mpz_t value
, size_t size
)
615 unsigned long bit_count
;
617 /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
618 checking on SIZE performed earlier. */
619 bit_count
= (unsigned long) size
<< 3UL;
621 if (EXPECT_TRUE (bit_count
< sizeof (unsigned long)))
622 mpz_ui_sub (value
, 1UL << bit_count
, value
);
628 mpz_ui_pow_ui (max
, 2, bit_count
);
629 mpz_sub (value
, max
, value
);
635 bytevector_large_ref (const char *c_bv
, size_t c_size
, int signed_p
,
640 int c_endianness
, negative_p
= 0;
644 if (scm_is_eq (endianness
, scm_sym_big
))
645 negative_p
= c_bv
[0] & 0x80;
647 negative_p
= c_bv
[c_size
- 1] & 0x80;
650 c_endianness
= scm_is_eq (endianness
, scm_sym_big
) ? 1 : -1;
653 mpz_import (c_mpz
, 1 /* 1 word */, 1 /* word order doesn't matter */,
654 c_size
/* word is C_SIZE-byte long */,
656 0 /* nails */, c_bv
);
658 if (signed_p
&& negative_p
)
660 twos_complement (c_mpz
, c_size
);
661 mpz_neg (c_mpz
, c_mpz
);
664 result
= scm_from_mpz (c_mpz
);
665 mpz_clear (c_mpz
); /* FIXME: Needed? */
671 bytevector_large_set (char *c_bv
, size_t c_size
, int signed_p
,
672 SCM value
, SCM endianness
)
675 int c_endianness
, c_sign
, err
= 0;
677 c_endianness
= scm_is_eq (endianness
, scm_sym_big
) ? 1 : -1;
680 scm_to_mpz (value
, c_mpz
);
682 c_sign
= mpz_sgn (c_mpz
);
685 if (EXPECT_TRUE (signed_p
))
687 mpz_neg (c_mpz
, c_mpz
);
688 twos_complement (c_mpz
, c_size
);
699 memset (c_bv
, 0, c_size
);
702 size_t word_count
, value_size
;
704 value_size
= (mpz_sizeinbase (c_mpz
, 2) + (8 * c_size
)) / (8 * c_size
);
705 if (EXPECT_FALSE (value_size
> c_size
))
712 mpz_export (c_bv
, &word_count
, 1 /* word order doesn't matter */,
713 c_size
, c_endianness
,
714 0 /* nails */, c_mpz
);
715 if (EXPECT_FALSE (word_count
!= 1))
716 /* Shouldn't happen since we already checked with VALUE_SIZE. */
726 #define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \
727 unsigned c_len, c_index, c_size; \
730 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv); \
731 c_index = scm_to_uint (index); \
732 c_size = scm_to_uint (size); \
734 c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv); \
735 c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv); \
737 /* C_SIZE must have its 3 higher bits set to zero so that \
738 multiplying it by 8 yields a number that fits in an \
740 if (EXPECT_FALSE ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
741 scm_out_of_range (FUNC_NAME, size); \
742 if (EXPECT_FALSE (c_index + c_size > c_len)) \
743 scm_out_of_range (FUNC_NAME, index);
746 /* Template of an integer reference function. */
747 #define GENERIC_INTEGER_REF(_sign) \
755 swap = !scm_is_eq (endianness, native_endianness); \
760 _sign char c_value8; \
761 memcpy (&c_value8, c_bv, 1); \
767 INT_TYPE (16, _sign) c_value16; \
768 memcpy (&c_value16, c_bv, 2); \
770 value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \
779 result = SCM_I_MAKINUM ((_sign int) value); \
782 result = bytevector_large_ref ((char *) c_bv, \
783 c_size, SIGNEDNESS (_sign), \
789 bytevector_signed_ref (const char *c_bv
, size_t c_size
, SCM endianness
)
791 GENERIC_INTEGER_REF (signed);
795 bytevector_unsigned_ref (const char *c_bv
, size_t c_size
, SCM endianness
)
797 GENERIC_INTEGER_REF (unsigned);
801 /* Template of an integer assignment function. */
802 #define GENERIC_INTEGER_SET(_sign) \
807 if (EXPECT_FALSE (!SCM_I_INUMP (value))) \
810 c_value = SCM_I_INUM (value); \
814 if (EXPECT_TRUE (INT_VALID_P (8, _sign) (c_value))) \
816 _sign char c_value8; \
817 c_value8 = (_sign char) c_value; \
818 memcpy (c_bv, &c_value8, 1); \
825 if (EXPECT_TRUE (INT_VALID_P (16, _sign) (c_value))) \
828 INT_TYPE (16, _sign) c_value16; \
830 swap = !scm_is_eq (endianness, native_endianness); \
833 swap ? bswap_16 (c_value) : c_value; \
834 memcpy (c_bv, &c_value16, 2); \
848 err = bytevector_large_set (c_bv, c_size, \
849 SIGNEDNESS (_sign), \
850 value, endianness); \
858 scm_out_of_range (FUNC_NAME, value); \
862 bytevector_signed_set (char *c_bv
, size_t c_size
,
863 SCM value
, SCM endianness
,
864 const char *func_name
)
865 #define FUNC_NAME func_name
867 GENERIC_INTEGER_SET (signed);
872 bytevector_unsigned_set (char *c_bv
, size_t c_size
,
873 SCM value
, SCM endianness
,
874 const char *func_name
)
875 #define FUNC_NAME func_name
877 GENERIC_INTEGER_SET (unsigned);
881 #undef GENERIC_INTEGER_SET
882 #undef GENERIC_INTEGER_REF
885 SCM_DEFINE (scm_r6rs_bytevector_uint_ref
, "bytevector-uint-ref", 4, 0, 0,
886 (SCM bv
, SCM index
, SCM endianness
, SCM size
),
887 "Return the @var{size}-octet long unsigned integer at index "
888 "@var{index} in @var{bv}.")
889 #define FUNC_NAME s_scm_r6rs_bytevector_uint_ref
891 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
893 return (bytevector_unsigned_ref (&c_bv
[c_index
], c_size
, endianness
));
897 SCM_DEFINE (scm_r6rs_bytevector_sint_ref
, "bytevector-sint-ref", 4, 0, 0,
898 (SCM bv
, SCM index
, SCM endianness
, SCM size
),
899 "Return the @var{size}-octet long unsigned integer at index "
900 "@var{index} in @var{bv}.")
901 #define FUNC_NAME s_scm_r6rs_bytevector_sint_ref
903 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
905 return (bytevector_signed_ref (&c_bv
[c_index
], c_size
, endianness
));
909 SCM_DEFINE (scm_r6rs_bytevector_uint_set_x
, "bytevector-uint-set!", 5, 0, 0,
910 (SCM bv
, SCM index
, SCM value
, SCM endianness
, SCM size
),
911 "Set the @var{size}-octet long unsigned integer at @var{index} "
913 #define FUNC_NAME s_scm_r6rs_bytevector_uint_set_x
915 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
917 bytevector_unsigned_set (&c_bv
[c_index
], c_size
, value
, endianness
,
920 return SCM_UNSPECIFIED
;
924 SCM_DEFINE (scm_r6rs_bytevector_sint_set_x
, "bytevector-sint-set!", 5, 0, 0,
925 (SCM bv
, SCM index
, SCM value
, SCM endianness
, SCM size
),
926 "Set the @var{size}-octet long signed integer at @var{index} "
928 #define FUNC_NAME s_scm_r6rs_bytevector_sint_set_x
930 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
932 bytevector_signed_set (&c_bv
[c_index
], c_size
, value
, endianness
,
935 return SCM_UNSPECIFIED
;
941 /* Operations on integers of arbitrary size. */
943 #define INTEGERS_TO_LIST(_sign) \
945 size_t i, c_len, c_size; \
947 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv); \
948 SCM_VALIDATE_SYMBOL (2, endianness); \
949 c_size = scm_to_uint (size); \
951 c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv); \
958 c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv); \
960 lst = scm_make_list (scm_from_uint (c_len / c_size), \
962 for (i = 0, pair = lst; \
963 i <= c_len - c_size; \
964 i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
967 bytevector_ ## _sign ## _ref (c_bv, c_size, \
974 SCM_DEFINE (scm_r6rs_bytevector_to_sint_list
, "bytevector->sint-list",
976 (SCM bv
, SCM endianness
, SCM size
),
977 "Return a list of signed integers of @var{size} octets "
978 "representing the contents of @var{bv}.")
979 #define FUNC_NAME s_scm_r6rs_bytevector_to_sint_list
981 INTEGERS_TO_LIST (signed);
985 SCM_DEFINE (scm_r6rs_bytevector_to_uint_list
, "bytevector->uint-list",
987 (SCM bv
, SCM endianness
, SCM size
),
988 "Return a list of unsigned integers of @var{size} octets "
989 "representing the contents of @var{bv}.")
990 #define FUNC_NAME s_scm_r6rs_bytevector_to_uint_list
992 INTEGERS_TO_LIST (unsigned);
996 #undef INTEGER_TO_LIST
999 #define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
1001 size_t c_len, c_size; \
1002 char *c_bv, *c_bv_ptr; \
1004 SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
1005 SCM_VALIDATE_SYMBOL (2, endianness); \
1006 c_size = scm_to_uint (size); \
1008 if (EXPECT_FALSE ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
1009 scm_out_of_range (FUNC_NAME, size); \
1011 bv = make_bytevector (c_len * c_size); \
1012 c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv); \
1014 for (c_bv_ptr = c_bv; \
1015 !scm_is_null (lst); \
1016 lst = SCM_CDR (lst), c_bv_ptr += c_size) \
1018 bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
1019 SCM_CAR (lst), endianness, \
1026 SCM_DEFINE (scm_r6rs_uint_list_to_bytevector
, "uint-list->bytevector",
1028 (SCM lst
, SCM endianness
, SCM size
),
1029 "Return a bytevector containing the unsigned integers "
1030 "listed in @var{lst} and encoded on @var{size} octets "
1031 "according to @var{endianness}.")
1032 #define FUNC_NAME s_scm_r6rs_uint_list_to_bytevector
1034 INTEGER_LIST_TO_BYTEVECTOR (unsigned);
1038 SCM_DEFINE (scm_r6rs_sint_list_to_bytevector
, "sint-list->bytevector",
1040 (SCM lst
, SCM endianness
, SCM size
),
1041 "Return a bytevector containing the signed integers "
1042 "listed in @var{lst} and encoded on @var{size} octets "
1043 "according to @var{endianness}.")
1044 #define FUNC_NAME s_scm_r6rs_sint_list_to_bytevector
1046 INTEGER_LIST_TO_BYTEVECTOR (signed);
1050 #undef INTEGER_LIST_TO_BYTEVECTOR
1054 /* Operations on 16-bit integers. */
1056 SCM_DEFINE (scm_r6rs_bytevector_u16_ref
, "bytevector-u16-ref",
1058 (SCM bv
, SCM index
, SCM endianness
),
1059 "Return the unsigned 16-bit integer from @var{bv} at "
1061 #define FUNC_NAME s_scm_r6rs_bytevector_u16_ref
1063 INTEGER_REF (16, unsigned);
1067 SCM_DEFINE (scm_r6rs_bytevector_s16_ref
, "bytevector-s16-ref",
1069 (SCM bv
, SCM index
, SCM endianness
),
1070 "Return the signed 16-bit integer from @var{bv} at "
1072 #define FUNC_NAME s_scm_r6rs_bytevector_s16_ref
1074 INTEGER_REF (16, signed);
1078 SCM_DEFINE (scm_r6rs_bytevector_u16_native_ref
, "bytevector-u16-native-ref",
1080 (SCM bv
, SCM index
),
1081 "Return the unsigned 16-bit integer from @var{bv} at "
1082 "@var{index} using the native endianness.")
1083 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_ref
1085 INTEGER_NATIVE_REF (16, unsigned);
1089 SCM_DEFINE (scm_r6rs_bytevector_s16_native_ref
, "bytevector-s16-native-ref",
1091 (SCM bv
, SCM index
),
1092 "Return the unsigned 16-bit integer from @var{bv} at "
1093 "@var{index} using the native endianness.")
1094 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_ref
1096 INTEGER_NATIVE_REF (16, signed);
1100 SCM_DEFINE (scm_r6rs_bytevector_u16_set_x
, "bytevector-u16-set!",
1102 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1103 "Store @var{value} in @var{bv} at @var{index} according to "
1104 "@var{endianness}.")
1105 #define FUNC_NAME s_scm_r6rs_bytevector_u16_set_x
1107 INTEGER_SET (16, unsigned);
1111 SCM_DEFINE (scm_r6rs_bytevector_s16_set_x
, "bytevector-s16-set!",
1113 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1114 "Store @var{value} in @var{bv} at @var{index} according to "
1115 "@var{endianness}.")
1116 #define FUNC_NAME s_scm_r6rs_bytevector_s16_set_x
1118 INTEGER_SET (16, signed);
1122 SCM_DEFINE (scm_r6rs_bytevector_u16_native_set_x
, "bytevector-u16-native-set!",
1124 (SCM bv
, SCM index
, SCM value
),
1125 "Store the unsigned integer @var{value} at index @var{index} "
1126 "of @var{bv} using the native endianness.")
1127 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_set_x
1129 INTEGER_NATIVE_SET (16, unsigned);
1133 SCM_DEFINE (scm_r6rs_bytevector_s16_native_set_x
, "bytevector-s16-native-set!",
1135 (SCM bv
, SCM index
, SCM value
),
1136 "Store the signed integer @var{value} at index @var{index} "
1137 "of @var{bv} using the native endianness.")
1138 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_set_x
1140 INTEGER_NATIVE_SET (16, signed);
1146 /* Operations on 32-bit integers. */
1148 /* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
1149 arbitrary 32-bit integers. Thus we fall back to using the
1150 `large_{ref,set}' variants on 32-bit machines. */
1152 #define LARGE_INTEGER_REF(_len, _sign) \
1153 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1154 SCM_VALIDATE_SYMBOL (3, endianness); \
1156 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1157 SIGNEDNESS (_sign), endianness));
1159 #define LARGE_INTEGER_SET(_len, _sign) \
1161 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1162 SCM_VALIDATE_SYMBOL (4, endianness); \
1164 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1165 SIGNEDNESS (_sign), value, endianness); \
1166 if (EXPECT_FALSE (err)) \
1167 scm_out_of_range (FUNC_NAME, value); \
1169 return SCM_UNSPECIFIED;
1171 #define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
1172 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1173 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1174 SIGNEDNESS (_sign), native_endianness));
1176 #define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
1178 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1180 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1181 SIGNEDNESS (_sign), value, \
1182 native_endianness); \
1183 if (EXPECT_FALSE (err)) \
1184 scm_out_of_range (FUNC_NAME, value); \
1186 return SCM_UNSPECIFIED;
1189 SCM_DEFINE (scm_r6rs_bytevector_u32_ref
, "bytevector-u32-ref",
1191 (SCM bv
, SCM index
, SCM endianness
),
1192 "Return the unsigned 32-bit integer from @var{bv} at "
1194 #define FUNC_NAME s_scm_r6rs_bytevector_u32_ref
1196 #if SIZEOF_VOID_P > 4
1197 INTEGER_REF (32, unsigned);
1199 LARGE_INTEGER_REF (32, unsigned);
1204 SCM_DEFINE (scm_r6rs_bytevector_s32_ref
, "bytevector-s32-ref",
1206 (SCM bv
, SCM index
, SCM endianness
),
1207 "Return the signed 32-bit integer from @var{bv} at "
1209 #define FUNC_NAME s_scm_r6rs_bytevector_s32_ref
1211 #if SIZEOF_VOID_P > 4
1212 INTEGER_REF (32, signed);
1214 LARGE_INTEGER_REF (32, signed);
1219 SCM_DEFINE (scm_r6rs_bytevector_u32_native_ref
, "bytevector-u32-native-ref",
1221 (SCM bv
, SCM index
),
1222 "Return the unsigned 32-bit integer from @var{bv} at "
1223 "@var{index} using the native endianness.")
1224 #define FUNC_NAME s_scm_r6rs_bytevector_u32_native_ref
1226 #if SIZEOF_VOID_P > 4
1227 INTEGER_NATIVE_REF (32, unsigned);
1229 LARGE_INTEGER_NATIVE_REF (32, unsigned);
1234 SCM_DEFINE (scm_r6rs_bytevector_s32_native_ref
, "bytevector-s32-native-ref",
1236 (SCM bv
, SCM index
),
1237 "Return the unsigned 32-bit integer from @var{bv} at "
1238 "@var{index} using the native endianness.")
1239 #define FUNC_NAME s_scm_r6rs_bytevector_u32_native_ref
1241 #if SIZEOF_VOID_P > 4
1242 INTEGER_NATIVE_REF (32, signed);
1244 LARGE_INTEGER_NATIVE_REF (32, signed);
1249 SCM_DEFINE (scm_r6rs_bytevector_u32_set_x
, "bytevector-u32-set!",
1251 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1252 "Store @var{value} in @var{bv} at @var{index} according to "
1253 "@var{endianness}.")
1254 #define FUNC_NAME s_scm_r6rs_bytevector_u32_set_x
1256 #if SIZEOF_VOID_P > 4
1257 INTEGER_SET (32, unsigned);
1259 LARGE_INTEGER_SET (32, unsigned);
1264 SCM_DEFINE (scm_r6rs_bytevector_s32_set_x
, "bytevector-s32-set!",
1266 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1267 "Store @var{value} in @var{bv} at @var{index} according to "
1268 "@var{endianness}.")
1269 #define FUNC_NAME s_scm_r6rs_bytevector_s32_set_x
1271 #if SIZEOF_VOID_P > 4
1272 INTEGER_SET (32, signed);
1274 LARGE_INTEGER_SET (32, signed);
1279 SCM_DEFINE (scm_r6rs_bytevector_u32_native_set_x
, "bytevector-u32-native-set!",
1281 (SCM bv
, SCM index
, SCM value
),
1282 "Store the unsigned integer @var{value} at index @var{index} "
1283 "of @var{bv} using the native endianness.")
1284 #define FUNC_NAME s_scm_r6rs_bytevector_u32_native_set_x
1286 #if SIZEOF_VOID_P > 4
1287 INTEGER_NATIVE_SET (32, unsigned);
1289 LARGE_INTEGER_NATIVE_SET (32, unsigned);
1294 SCM_DEFINE (scm_r6rs_bytevector_s32_native_set_x
, "bytevector-s32-native-set!",
1296 (SCM bv
, SCM index
, SCM value
),
1297 "Store the signed integer @var{value} at index @var{index} "
1298 "of @var{bv} using the native endianness.")
1299 #define FUNC_NAME s_scm_r6rs_bytevector_u32_native_set_x
1301 #if SIZEOF_VOID_P > 4
1302 INTEGER_NATIVE_SET (32, signed);
1304 LARGE_INTEGER_NATIVE_SET (32, signed);
1311 /* Operations on 64-bit integers. */
1313 /* For 64-bit integers, we use only the `large_{ref,set}' variant. */
1315 SCM_DEFINE (scm_r6rs_bytevector_u64_ref
, "bytevector-u64-ref",
1317 (SCM bv
, SCM index
, SCM endianness
),
1318 "Return the unsigned 64-bit integer from @var{bv} at "
1320 #define FUNC_NAME s_scm_r6rs_bytevector_u64_ref
1322 LARGE_INTEGER_REF (64, unsigned);
1326 SCM_DEFINE (scm_r6rs_bytevector_s64_ref
, "bytevector-s64-ref",
1328 (SCM bv
, SCM index
, SCM endianness
),
1329 "Return the signed 64-bit integer from @var{bv} at "
1331 #define FUNC_NAME s_scm_r6rs_bytevector_s64_ref
1333 LARGE_INTEGER_REF (64, signed);
1337 SCM_DEFINE (scm_r6rs_bytevector_u64_native_ref
, "bytevector-u64-native-ref",
1339 (SCM bv
, SCM index
),
1340 "Return the unsigned 64-bit integer from @var{bv} at "
1341 "@var{index} using the native endianness.")
1342 #define FUNC_NAME s_scm_r6rs_bytevector_u64_native_ref
1344 LARGE_INTEGER_NATIVE_REF (64, unsigned);
1348 SCM_DEFINE (scm_r6rs_bytevector_s64_native_ref
, "bytevector-s64-native-ref",
1350 (SCM bv
, SCM index
),
1351 "Return the unsigned 64-bit integer from @var{bv} at "
1352 "@var{index} using the native endianness.")
1353 #define FUNC_NAME s_scm_r6rs_bytevector_u64_native_ref
1355 LARGE_INTEGER_NATIVE_REF (64, signed);
1359 SCM_DEFINE (scm_r6rs_bytevector_u64_set_x
, "bytevector-u64-set!",
1361 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1362 "Store @var{value} in @var{bv} at @var{index} according to "
1363 "@var{endianness}.")
1364 #define FUNC_NAME s_scm_r6rs_bytevector_u64_set_x
1366 LARGE_INTEGER_SET (64, unsigned);
1370 SCM_DEFINE (scm_r6rs_bytevector_s64_set_x
, "bytevector-s64-set!",
1372 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1373 "Store @var{value} in @var{bv} at @var{index} according to "
1374 "@var{endianness}.")
1375 #define FUNC_NAME s_scm_r6rs_bytevector_s64_set_x
1377 LARGE_INTEGER_SET (64, signed);
1381 SCM_DEFINE (scm_r6rs_bytevector_u64_native_set_x
, "bytevector-u64-native-set!",
1383 (SCM bv
, SCM index
, SCM value
),
1384 "Store the unsigned integer @var{value} at index @var{index} "
1385 "of @var{bv} using the native endianness.")
1386 #define FUNC_NAME s_scm_r6rs_bytevector_u64_native_set_x
1388 LARGE_INTEGER_NATIVE_SET (64, unsigned);
1392 SCM_DEFINE (scm_r6rs_bytevector_s64_native_set_x
, "bytevector-s64-native-set!",
1394 (SCM bv
, SCM index
, SCM value
),
1395 "Store the signed integer @var{value} at index @var{index} "
1396 "of @var{bv} using the native endianness.")
1397 #define FUNC_NAME s_scm_r6rs_bytevector_u64_native_set_x
1399 LARGE_INTEGER_NATIVE_SET (64, signed);
1405 /* Operations on IEEE-754 numbers. */
1407 /* XXX: There are not only two encodings (big and little endian), as implied
1408 by the API, but rather three (in the case of little endian, there are two
1409 possible word endians, as visible in glibc's <ieee754.h>). When the
1410 endianness is `little', we assume little endian for both the byte order
1411 and the word order. */
1413 /* Convert to/from a floating-point number with different endianness. This
1414 method is probably not the most efficient but it should be portable. */
1417 float_to_foreign_endianness (union scm_r6rs_ieee754_float
*target
,
1420 union scm_r6rs_ieee754_float src
;
1424 #ifdef WORDS_BIGENDIAN
1425 /* Assuming little endian for both byte and word order. */
1426 target
->little_endian
.negative
= src
.big_endian
.negative
;
1427 target
->little_endian
.exponent
= src
.big_endian
.exponent
;
1428 target
->little_endian
.mantissa
= src
.big_endian
.mantissa
;
1430 target
->big_endian
.negative
= src
.little_endian
.negative
;
1431 target
->big_endian
.exponent
= src
.little_endian
.exponent
;
1432 target
->big_endian
.mantissa
= src
.little_endian
.mantissa
;
1437 float_from_foreign_endianness (const union scm_r6rs_ieee754_float
*source
)
1439 union scm_r6rs_ieee754_float result
;
1441 #ifdef WORDS_BIGENDIAN
1442 /* Assuming little endian for both byte and word order. */
1443 result
.big_endian
.negative
= source
->little_endian
.negative
;
1444 result
.big_endian
.exponent
= source
->little_endian
.exponent
;
1445 result
.big_endian
.mantissa
= source
->little_endian
.mantissa
;
1447 result
.little_endian
.negative
= source
->big_endian
.negative
;
1448 result
.little_endian
.exponent
= source
->big_endian
.exponent
;
1449 result
.little_endian
.mantissa
= source
->big_endian
.mantissa
;
1456 double_to_foreign_endianness (union scm_r6rs_ieee754_double
*target
,
1459 union scm_r6rs_ieee754_double src
;
1463 #ifdef WORDS_BIGENDIAN
1464 /* Assuming little endian for both byte and word order. */
1465 target
->little_little_endian
.negative
= src
.big_endian
.negative
;
1466 target
->little_little_endian
.exponent
= src
.big_endian
.exponent
;
1467 target
->little_little_endian
.mantissa0
= src
.big_endian
.mantissa0
;
1468 target
->little_little_endian
.mantissa1
= src
.big_endian
.mantissa1
;
1470 target
->big_endian
.negative
= src
.little_little_endian
.negative
;
1471 target
->big_endian
.exponent
= src
.little_little_endian
.exponent
;
1472 target
->big_endian
.mantissa0
= src
.little_little_endian
.mantissa0
;
1473 target
->big_endian
.mantissa1
= src
.little_little_endian
.mantissa1
;
1477 static inline double
1478 double_from_foreign_endianness (const union scm_r6rs_ieee754_double
*source
)
1480 union scm_r6rs_ieee754_double result
;
1482 #ifdef WORDS_BIGENDIAN
1483 /* Assuming little endian for both byte and word order. */
1484 result
.big_endian
.negative
= source
->little_little_endian
.negative
;
1485 result
.big_endian
.exponent
= source
->little_little_endian
.exponent
;
1486 result
.big_endian
.mantissa0
= source
->little_little_endian
.mantissa0
;
1487 result
.big_endian
.mantissa1
= source
->little_little_endian
.mantissa1
;
1489 result
.little_little_endian
.negative
= source
->big_endian
.negative
;
1490 result
.little_little_endian
.exponent
= source
->big_endian
.exponent
;
1491 result
.little_little_endian
.mantissa0
= source
->big_endian
.mantissa0
;
1492 result
.little_little_endian
.mantissa1
= source
->big_endian
.mantissa1
;
1498 /* Template macros to abstract over doubles and floats.
1499 XXX: Guile can only convert to/from doubles. */
1500 #define IEEE754_UNION(_c_type) union scm_r6rs_ieee754_ ## _c_type
1501 #define IEEE754_TO_SCM(_c_type) scm_from_double
1502 #define IEEE754_FROM_SCM(_c_type) scm_to_double
1503 #define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
1504 _c_type ## _from_foreign_endianness
1505 #define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
1506 _c_type ## _to_foreign_endianness
1509 /* Templace getters and setters. */
1511 #define IEEE754_ACCESSOR_PROLOGUE(_type) \
1512 INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
1514 #define IEEE754_REF(_type) \
1517 IEEE754_ACCESSOR_PROLOGUE (_type); \
1518 SCM_VALIDATE_SYMBOL (3, endianness); \
1520 if (scm_is_eq (endianness, native_endianness)) \
1521 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1524 IEEE754_UNION (_type) c_raw; \
1526 memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
1528 IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
1531 return (IEEE754_TO_SCM (_type) (c_result));
1533 #define IEEE754_NATIVE_REF(_type) \
1536 IEEE754_ACCESSOR_PROLOGUE (_type); \
1538 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1539 return (IEEE754_TO_SCM (_type) (c_result));
1541 #define IEEE754_SET(_type) \
1544 IEEE754_ACCESSOR_PROLOGUE (_type); \
1545 SCM_VALIDATE_REAL (3, value); \
1546 SCM_VALIDATE_SYMBOL (4, endianness); \
1547 c_value = IEEE754_FROM_SCM (_type) (value); \
1549 if (scm_is_eq (endianness, native_endianness)) \
1550 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1553 IEEE754_UNION (_type) c_raw; \
1555 IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
1556 memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
1559 return SCM_UNSPECIFIED;
1561 #define IEEE754_NATIVE_SET(_type) \
1564 IEEE754_ACCESSOR_PROLOGUE (_type); \
1565 SCM_VALIDATE_REAL (3, value); \
1566 c_value = IEEE754_FROM_SCM (_type) (value); \
1568 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1569 return SCM_UNSPECIFIED;
1572 /* Single precision. */
1574 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_ref
,
1575 "bytevector-ieee-single-ref",
1577 (SCM bv
, SCM index
, SCM endianness
),
1578 "Return the IEEE-754 single from @var{bv} at "
1580 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_ref
1582 IEEE754_REF (float);
1586 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_native_ref
,
1587 "bytevector-ieee-single-native-ref",
1589 (SCM bv
, SCM index
),
1590 "Return the IEEE-754 single from @var{bv} at "
1591 "@var{index} using the native endianness.")
1592 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_native_ref
1594 IEEE754_NATIVE_REF (float);
1598 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_set_x
,
1599 "bytevector-ieee-single-set!",
1601 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1602 "Store real @var{value} in @var{bv} at @var{index} according to "
1603 "@var{endianness}.")
1604 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_set_x
1606 IEEE754_SET (float);
1610 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_native_set_x
,
1611 "bytevector-ieee-single-native-set!",
1613 (SCM bv
, SCM index
, SCM value
),
1614 "Store the real @var{value} at index @var{index} "
1615 "of @var{bv} using the native endianness.")
1616 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_native_set_x
1618 IEEE754_NATIVE_SET (float);
1623 /* Double precision. */
1625 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_ref
,
1626 "bytevector-ieee-double-ref",
1628 (SCM bv
, SCM index
, SCM endianness
),
1629 "Return the IEEE-754 double from @var{bv} at "
1631 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_ref
1633 IEEE754_REF (double);
1637 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_native_ref
,
1638 "bytevector-ieee-double-native-ref",
1640 (SCM bv
, SCM index
),
1641 "Return the IEEE-754 double from @var{bv} at "
1642 "@var{index} using the native endianness.")
1643 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_native_ref
1645 IEEE754_NATIVE_REF (double);
1649 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_set_x
,
1650 "bytevector-ieee-double-set!",
1652 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1653 "Store real @var{value} in @var{bv} at @var{index} according to "
1654 "@var{endianness}.")
1655 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_set_x
1657 IEEE754_SET (double);
1661 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_native_set_x
,
1662 "bytevector-ieee-double-native-set!",
1664 (SCM bv
, SCM index
, SCM value
),
1665 "Store the real @var{value} at index @var{index} "
1666 "of @var{bv} using the native endianness.")
1667 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_native_set_x
1669 IEEE754_NATIVE_SET (double);
1674 #undef IEEE754_UNION
1675 #undef IEEE754_TO_SCM
1676 #undef IEEE754_FROM_SCM
1677 #undef IEEE754_FROM_FOREIGN_ENDIANNESS
1678 #undef IEEE754_TO_FOREIGN_ENDIANNESS
1680 #undef IEEE754_NATIVE_REF
1682 #undef IEEE754_NATIVE_SET
1685 /* Operations on strings. */
1688 /* Produce a function that returns the length of a UTF-encoded string. */
1689 #define UTF_STRLEN_FUNCTION(_utf_width) \
1690 static inline size_t \
1691 utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
1694 const uint ## _utf_width ## _t *ptr; \
1702 return (len * ((_utf_width) / 8)); \
1705 UTF_STRLEN_FUNCTION (8)
1708 /* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
1709 #define UTF_STRLEN(_utf_width, _str) \
1710 utf ## _utf_width ## _strlen (_str)
1712 /* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
1713 ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
1716 utf_encoding_name (char *name
, size_t utf_width
, SCM endianness
)
1718 strcpy (name
, "UTF-");
1719 strcat (name
, ((utf_width
== 8)
1721 : ((utf_width
== 16)
1723 : ((utf_width
== 32)
1727 ((scm_is_eq (endianness
, scm_sym_big
))
1729 : ((scm_is_eq (endianness
, scm_sym_little
))
1734 /* Maximum length of a UTF encoding name. */
1735 #define MAX_UTF_ENCODING_NAME_LEN 16
1737 /* Produce the body of a `string->utf' function. */
1738 #define STRING_TO_UTF(_utf_width) \
1742 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1743 char *c_utf = NULL, *c_locale; \
1744 size_t c_strlen, c_raw_strlen, c_utf_len = 0; \
1746 SCM_VALIDATE_STRING (1, str); \
1747 if (endianness == SCM_UNDEFINED) \
1748 endianness = scm_sym_big; \
1750 SCM_VALIDATE_SYMBOL (2, endianness); \
1752 c_strlen = scm_c_string_length (str); \
1753 c_raw_strlen = c_strlen * ((_utf_width) / 8); \
1756 c_str = (char *) alloca (c_raw_strlen + 1); \
1757 c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \
1759 while (c_raw_strlen > c_strlen); \
1760 c_str[c_raw_strlen] = '\0'; \
1762 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1764 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1765 strcpy (c_locale, locale_charset ()); \
1767 err = mem_iconveh (c_str, c_raw_strlen, \
1768 c_locale, c_utf_name, \
1769 iconveh_question_mark, NULL, \
1770 &c_utf, &c_utf_len); \
1771 if (EXPECT_FALSE (err)) \
1772 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1773 scm_list_1 (str), err); \
1775 /* C_UTF is null-terminated. */ \
1776 utf = scm_r6rs_c_take_bytevector ((signed char *) c_utf, \
1783 SCM_DEFINE (scm_r6rs_string_to_utf8
, "string->utf8",
1786 "Return a newly allocated bytevector that contains the UTF-8 "
1787 "encoding of @var{str}.")
1788 #define FUNC_NAME s_scm_r6rs_string_to_utf8
1793 size_t c_strlen
, c_raw_strlen
;
1795 SCM_VALIDATE_STRING (1, str
);
1797 c_strlen
= scm_c_string_length (str
);
1798 c_raw_strlen
= c_strlen
;
1801 c_str
= (char *) alloca (c_raw_strlen
+ 1);
1802 c_raw_strlen
= scm_to_locale_stringbuf (str
, c_str
, c_strlen
);
1804 while (c_raw_strlen
> c_strlen
);
1805 c_str
[c_raw_strlen
] = '\0';
1807 c_utf
= u8_strconv_from_locale (c_str
);
1808 if (EXPECT_FALSE (c_utf
== NULL
))
1809 scm_syserror (FUNC_NAME
);
1811 /* C_UTF is null-terminated. */
1812 utf
= scm_r6rs_c_take_bytevector ((signed char *) c_utf
,
1813 UTF_STRLEN (8, c_utf
));
1819 SCM_DEFINE (scm_r6rs_string_to_utf16
, "string->utf16",
1821 (SCM str
, SCM endianness
),
1822 "Return a newly allocated bytevector that contains the UTF-16 "
1823 "encoding of @var{str}.")
1824 #define FUNC_NAME s_scm_r6rs_string_to_utf16
1830 SCM_DEFINE (scm_r6rs_string_to_utf32
, "string->utf32",
1832 (SCM str
, SCM endianness
),
1833 "Return a newly allocated bytevector that contains the UTF-32 "
1834 "encoding of @var{str}.")
1835 #define FUNC_NAME s_scm_r6rs_string_to_utf32
1842 /* Produce the body of a function that converts a UTF-encoded bytevector to a
1844 #define UTF_TO_STRING(_utf_width) \
1845 SCM str = SCM_BOOL_F; \
1847 char *c_str = NULL, *c_locale; \
1848 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1849 const char *c_utf; \
1850 size_t c_strlen = 0, c_utf_len; \
1852 SCM_VALIDATE_R6RS_BYTEVECTOR (1, utf); \
1853 if (endianness == SCM_UNDEFINED) \
1854 endianness = scm_sym_big; \
1856 SCM_VALIDATE_SYMBOL (2, endianness); \
1858 c_utf_len = SCM_R6RS_BYTEVECTOR_LENGTH (utf); \
1859 c_utf = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (utf); \
1860 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1862 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1863 strcpy (c_locale, locale_charset ()); \
1865 err = mem_iconveh (c_utf, c_utf_len, \
1866 c_utf_name, c_locale, \
1867 iconveh_question_mark, NULL, \
1868 &c_str, &c_strlen); \
1869 if (EXPECT_FALSE (err)) \
1870 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
1871 scm_list_1 (utf), err); \
1873 /* C_STR is null-terminated. */ \
1874 str = scm_take_locale_stringn (c_str, c_strlen); \
1879 SCM_DEFINE (scm_r6rs_utf8_to_string
, "utf8->string",
1882 "Return a newly allocate string that contains from the UTF-8-"
1883 "encoded contents of bytevector @var{utf}.")
1884 #define FUNC_NAME s_scm_r6rs_utf8_to_string
1888 char *c_str
= NULL
, *c_locale
;
1890 size_t c_utf_len
, c_strlen
= 0;
1892 SCM_VALIDATE_R6RS_BYTEVECTOR (1, utf
);
1894 c_utf_len
= SCM_R6RS_BYTEVECTOR_LENGTH (utf
);
1896 c_locale
= (char *) alloca (strlen (locale_charset ()) + 1);
1897 strcpy (c_locale
, locale_charset ());
1899 c_utf
= (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (utf
);
1900 err
= mem_iconveh (c_utf
, c_utf_len
,
1902 iconveh_question_mark
, NULL
,
1904 if (EXPECT_FALSE (err
))
1905 scm_syserror_msg (FUNC_NAME
, "failed to convert to string: ~A",
1906 scm_list_1 (utf
), err
);
1908 /* C_STR is null-terminated. */
1909 str
= scm_take_locale_stringn (c_str
, c_strlen
);
1915 SCM_DEFINE (scm_r6rs_utf16_to_string
, "utf16->string",
1917 (SCM utf
, SCM endianness
),
1918 "Return a newly allocate string that contains from the UTF-17-"
1919 "encoded contents of bytevector @var{utf}.")
1920 #define FUNC_NAME s_scm_r6rs_utf16_to_string
1926 SCM_DEFINE (scm_r6rs_utf32_to_string
, "utf32->string",
1928 (SCM utf
, SCM endianness
),
1929 "Return a newly allocate string that contains from the UTF-17-"
1930 "encoded contents of bytevector @var{utf}.")
1931 #define FUNC_NAME s_scm_r6rs_utf32_to_string
1939 /* Initialization. */
1942 scm_init_r6rs_bytevector (void)
1944 #include "bytevector.x"
1946 #ifdef WORDS_BIGENDIAN
1947 native_endianness
= scm_sym_big
;
1949 native_endianness
= scm_sym_little
;
1952 scm_r6rs_null_bytevector
=
1953 scm_gc_protect_object (make_bytevector_from_buffer (0, NULL
));
1956 /* arch-tag: e5a30664-90fc-40d7-8036-ee767aea5fb6