1 /* Guile-R6RS-Libs --- Implementation of R6RS standard libraries.
2 Copyright (C) 2007, 2008, 2009 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"
28 #include "striconveh.h"
36 /* Assuming 32-bit longs. */
37 # define ULONG_MAX 4294967295UL
46 /* Convenience macros. These are used by the various templates (macros) that
47 are parameterized by integer signedness. */
48 #define INT8_T_signed scm_t_int8
49 #define INT8_T_unsigned scm_t_uint8
50 #define INT16_T_signed scm_t_int16
51 #define INT16_T_unsigned scm_t_uint16
52 #define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L))
53 #define is_unsigned_int8(_x) ((_x) <= 255UL)
54 #define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
55 #define is_unsigned_int16(_x) ((_x) <= 65535UL)
56 #define SIGNEDNESS_signed 1
57 #define SIGNEDNESS_unsigned 0
59 #define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign
60 #define INT_SWAP(_size) bswap_ ## _size
61 #define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
62 #define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
65 #define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \
66 unsigned c_len, c_index; \
69 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv); \
70 c_index = scm_to_uint (index); \
72 c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv); \
73 c_bv = (_sign char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv); \
75 if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
76 scm_out_of_range (FUNC_NAME, index);
78 /* Template for fixed-size integer access (only 8, 16 or 32-bit). */
79 #define INTEGER_REF(_len, _sign) \
82 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
83 SCM_VALIDATE_SYMBOL (3, endianness); \
86 INT_TYPE (_len, _sign) c_result; \
88 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
89 if (!scm_is_eq (endianness, native_endianness)) \
90 c_result = INT_SWAP (_len) (c_result); \
92 result = SCM_I_MAKINUM (c_result); \
97 /* Template for fixed-size integer access using the native endianness. */
98 #define INTEGER_NATIVE_REF(_len, _sign) \
101 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
104 INT_TYPE (_len, _sign) c_result; \
106 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
107 result = SCM_I_MAKINUM (c_result); \
112 /* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
113 #define INTEGER_SET(_len, _sign) \
114 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
115 SCM_VALIDATE_SYMBOL (3, endianness); \
118 _sign long c_value; \
119 INT_TYPE (_len, _sign) c_value_short; \
121 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
122 scm_wrong_type_arg (FUNC_NAME, 3, value); \
124 c_value = SCM_I_INUM (value); \
125 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
126 scm_out_of_range (FUNC_NAME, value); \
128 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
129 if (!scm_is_eq (endianness, native_endianness)) \
130 c_value_short = INT_SWAP (_len) (c_value_short); \
132 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
135 return SCM_UNSPECIFIED;
137 /* Template for fixed-size integer modification using the native
139 #define INTEGER_NATIVE_SET(_len, _sign) \
140 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
143 _sign long c_value; \
144 INT_TYPE (_len, _sign) c_value_short; \
146 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
147 scm_wrong_type_arg (FUNC_NAME, 3, value); \
149 c_value = SCM_I_INUM (value); \
150 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
151 scm_out_of_range (FUNC_NAME, value); \
153 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
155 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
158 return SCM_UNSPECIFIED;
162 /* Bytevector type. */
164 SCM_GLOBAL_SMOB (scm_tc16_r6rs_bytevector
, "r6rs-bytevector", 0);
166 #define SCM_R6RS_BYTEVECTOR_SET_LENGTH(_bv, _len) \
167 SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len))
168 #define SCM_R6RS_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
169 SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf))
171 /* The empty bytevector. */
172 SCM scm_r6rs_null_bytevector
= SCM_UNSPECIFIED
;
176 make_bytevector_from_buffer (unsigned len
, signed char *contents
)
178 /* Assuming LEN > SCM_R6RS_BYTEVECTOR_INLINE_THRESHOLD. */
179 SCM_RETURN_NEWSMOB2 (scm_tc16_r6rs_bytevector
, len
, contents
);
183 make_bytevector (unsigned len
)
187 if (SCM_UNLIKELY (len
== 0))
188 bv
= scm_r6rs_null_bytevector
;
191 signed char *contents
= NULL
;
193 if (!SCM_R6RS_BYTEVECTOR_INLINEABLE_SIZE_P (len
))
194 contents
= (signed char *) scm_gc_malloc (len
, SCM_GC_BYTEVECTOR
);
196 bv
= make_bytevector_from_buffer (len
, contents
);
202 /* Return a new bytevector of size LEN octets. */
204 scm_r6rs_c_make_bytevector (unsigned len
)
206 return (make_bytevector (len
));
209 /* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
210 by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
212 scm_r6rs_c_take_bytevector (signed char *contents
, unsigned len
)
216 if (SCM_UNLIKELY (SCM_R6RS_BYTEVECTOR_INLINEABLE_SIZE_P (len
)))
218 /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */
221 bv
= make_bytevector (len
);
222 c_bv
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
223 memcpy (c_bv
, contents
, len
);
224 scm_gc_free (contents
, len
, SCM_GC_BYTEVECTOR
);
227 bv
= make_bytevector_from_buffer (len
, contents
);
232 /* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
233 size) and return BV. */
235 scm_r6rs_i_shrink_bytevector (SCM bv
, unsigned c_new_len
)
237 if (!SCM_R6RS_BYTEVECTOR_INLINE_P (bv
))
240 signed char *c_bv
, *c_new_bv
;
242 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
243 c_bv
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
245 SCM_R6RS_BYTEVECTOR_SET_LENGTH (bv
, c_new_len
);
247 if (SCM_R6RS_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len
))
249 /* Copy to the in-line buffer and free the current buffer. */
250 c_new_bv
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
251 memcpy (c_new_bv
, c_bv
, c_new_len
);
252 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
256 /* Resize the existing buffer. */
257 c_new_bv
= scm_gc_realloc (c_bv
, c_len
, c_new_len
,
259 SCM_R6RS_BYTEVECTOR_SET_CONTENTS (bv
, c_new_bv
);
266 SCM_SMOB_PRINT (scm_tc16_r6rs_bytevector
, print_bytevector
,
272 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
273 c_bv
= (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
275 scm_puts ("#vu8(", port
);
276 for (i
= 0; i
< c_len
; i
++)
279 scm_putc (' ', port
);
281 scm_uintprint (c_bv
[i
], 10, port
);
284 scm_putc (')', port
);
286 /* Make GCC think we use it. */
287 scm_remember_upto_here ((SCM
) pstate
);
292 SCM_SMOB_FREE (scm_tc16_r6rs_bytevector
, free_bytevector
, bv
)
295 if (!SCM_R6RS_BYTEVECTOR_INLINE_P (bv
))
300 c_bv
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
301 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
303 scm_gc_free (c_bv
, c_len
, SCM_GC_BYTEVECTOR
);
311 /* General operations. */
313 SCM_SYMBOL (scm_sym_big
, "big");
314 SCM_SYMBOL (scm_sym_little
, "little");
316 SCM scm_r6rs_endianness_big
, scm_r6rs_endianness_little
;
318 /* Host endianness (a symbol). */
319 static SCM native_endianness
= SCM_UNSPECIFIED
;
323 # define bswap_24(_x) \
324 ((((_x) & 0xff0000) >> 16) | \
325 (((_x) & 0x00ff00)) | \
326 (((_x) & 0x0000ff) << 16))
330 SCM_DEFINE (scm_r6rs_native_endianness
, "native-endianness", 0, 0, 0,
332 "Return a symbol denoting the machine's native endianness.")
334 return native_endianness
;
337 SCM_DEFINE (scm_r6rs_bytevector_p
, "bytevector?", 1, 0, 0,
339 "Return true if @var{obj} is a bytevector.")
341 return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_r6rs_bytevector
,
345 SCM_DEFINE (scm_r6rs_make_bytevector
, "make-bytevector", 1, 1, 0,
347 "Return a newly allocated bytevector of @var{len} bytes, "
348 "optionally filled with @var{fill}.")
349 #define FUNC_NAME s_scm_r6rs_make_bytevector
353 signed char c_fill
= '\0';
355 SCM_VALIDATE_UINT_COPY (1, len
, c_len
);
356 if (fill
!= SCM_UNDEFINED
)
360 value
= scm_to_int (fill
);
361 if (SCM_UNLIKELY ((value
< -128) || (value
> 255)))
362 scm_out_of_range (FUNC_NAME
, fill
);
363 c_fill
= (signed char) value
;
366 bv
= make_bytevector (c_len
);
367 if (fill
!= SCM_UNDEFINED
)
370 signed char *contents
;
372 contents
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
373 for (i
= 0; i
< c_len
; i
++)
374 contents
[i
] = c_fill
;
381 SCM_DEFINE (scm_r6rs_bytevector_length
, "bytevector-length", 1, 0, 0,
383 "Return the length (in bytes) of @var{bv}.")
384 #define FUNC_NAME s_scm_r6rs_bytevector_length
386 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv
);
388 return (scm_from_uint (SCM_R6RS_BYTEVECTOR_LENGTH (bv
)));
392 SCM_DEFINE (scm_r6rs_bytevector_eq_p
, "bytevector=?", 2, 0, 0,
394 "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
395 "have the same length and contents.")
396 #define FUNC_NAME s_scm_r6rs_bytevector_eq_p
398 SCM result
= SCM_BOOL_F
;
399 unsigned c_len1
, c_len2
;
401 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv1
);
402 SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv2
);
404 c_len1
= SCM_R6RS_BYTEVECTOR_LENGTH (bv1
);
405 c_len2
= SCM_R6RS_BYTEVECTOR_LENGTH (bv2
);
407 if (c_len1
== c_len2
)
409 signed char *c_bv1
, *c_bv2
;
411 c_bv1
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv1
);
412 c_bv2
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv2
);
414 result
= scm_from_bool (!memcmp (c_bv1
, c_bv2
, c_len1
));
421 SCM_DEFINE (scm_r6rs_bytevector_fill_x
, "bytevector-fill!", 2, 0, 0,
423 "Fill bytevector @var{bv} with @var{fill}, a byte.")
424 #define FUNC_NAME s_scm_r6rs_bytevector_fill_x
427 signed char *c_bv
, c_fill
;
429 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv
);
430 c_fill
= scm_to_int8 (fill
);
432 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
433 c_bv
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
435 for (i
= 0; i
< c_len
; i
++)
438 return SCM_UNSPECIFIED
;
442 SCM_DEFINE (scm_r6rs_bytevector_copy_x
, "bytevector-copy!", 5, 0, 0,
443 (SCM source
, SCM source_start
, SCM target
, SCM target_start
,
445 "Copy @var{len} bytes from @var{source} into @var{target}, "
446 "starting reading from @var{source_start} (a positive index "
447 "within @var{source}) and start writing at "
448 "@var{target_start}.")
449 #define FUNC_NAME s_scm_r6rs_bytevector_copy_x
451 unsigned c_len
, c_source_len
, c_target_len
;
452 unsigned c_source_start
, c_target_start
;
453 signed char *c_source
, *c_target
;
455 SCM_VALIDATE_R6RS_BYTEVECTOR (1, source
);
456 SCM_VALIDATE_R6RS_BYTEVECTOR (3, target
);
458 c_len
= scm_to_uint (len
);
459 c_source_start
= scm_to_uint (source_start
);
460 c_target_start
= scm_to_uint (target_start
);
462 c_source
= SCM_R6RS_BYTEVECTOR_CONTENTS (source
);
463 c_target
= SCM_R6RS_BYTEVECTOR_CONTENTS (target
);
464 c_source_len
= SCM_R6RS_BYTEVECTOR_LENGTH (source
);
465 c_target_len
= SCM_R6RS_BYTEVECTOR_LENGTH (target
);
467 if (SCM_UNLIKELY (c_source_start
+ c_len
> c_source_len
))
468 scm_out_of_range (FUNC_NAME
, source_start
);
469 if (SCM_UNLIKELY (c_target_start
+ c_len
> c_target_len
))
470 scm_out_of_range (FUNC_NAME
, target_start
);
472 memcpy (c_target
+ c_target_start
,
473 c_source
+ c_source_start
,
476 return SCM_UNSPECIFIED
;
480 SCM_DEFINE (scm_r6rs_bytevector_copy
, "bytevector-copy", 1, 0, 0,
482 "Return a newly allocated copy of @var{bv}.")
483 #define FUNC_NAME s_scm_r6rs_bytevector_copy
487 signed char *c_bv
, *c_copy
;
489 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv
);
491 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
492 c_bv
= SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
494 copy
= make_bytevector (c_len
);
495 c_copy
= SCM_R6RS_BYTEVECTOR_CONTENTS (copy
);
496 memcpy (c_copy
, c_bv
, c_len
);
503 /* Operations on bytes and octets. */
505 SCM_DEFINE (scm_r6rs_bytevector_u8_ref
, "bytevector-u8-ref", 2, 0, 0,
507 "Return the octet located at @var{index} in @var{bv}.")
508 #define FUNC_NAME s_scm_r6rs_bytevector_u8_ref
510 INTEGER_NATIVE_REF (8, unsigned);
514 SCM_DEFINE (scm_r6rs_bytevector_s8_ref
, "bytevector-s8-ref", 2, 0, 0,
516 "Return the byte located at @var{index} in @var{bv}.")
517 #define FUNC_NAME s_scm_r6rs_bytevector_u8_ref
519 INTEGER_NATIVE_REF (8, signed);
523 SCM_DEFINE (scm_r6rs_bytevector_u8_set_x
, "bytevector-u8-set!", 3, 0, 0,
524 (SCM bv
, SCM index
, SCM value
),
525 "Return the octet located at @var{index} in @var{bv}.")
526 #define FUNC_NAME s_scm_r6rs_bytevector_u8_set_x
528 INTEGER_NATIVE_SET (8, unsigned);
532 SCM_DEFINE (scm_r6rs_bytevector_s8_set_x
, "bytevector-s8-set!", 3, 0, 0,
533 (SCM bv
, SCM index
, SCM value
),
534 "Return the octet located at @var{index} in @var{bv}.")
535 #define FUNC_NAME s_scm_r6rs_bytevector_u8_set_x
537 INTEGER_NATIVE_SET (8, signed);
541 #undef OCTET_ACCESSOR_PROLOGUE
544 SCM_DEFINE (scm_r6rs_bytevector_to_u8_list
, "bytevector->u8-list", 1, 0, 0,
546 "Return a newly allocated list of octets containing the "
547 "contents of @var{bv}.")
548 #define FUNC_NAME s_scm_r6rs_bytevector_to_u8_list
554 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv
);
556 c_len
= SCM_R6RS_BYTEVECTOR_LENGTH (bv
);
557 c_bv
= (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
559 lst
= scm_make_list (scm_from_uint (c_len
), SCM_UNSPECIFIED
);
560 for (i
= 0, pair
= lst
;
562 i
++, pair
= SCM_CDR (pair
))
564 SCM_SETCAR (pair
, SCM_I_MAKINUM (c_bv
[i
]));
571 SCM_DEFINE (scm_r6rs_u8_list_to_bytevector
, "u8-list->bytevector", 1, 0, 0,
573 "Turn @var{lst}, a list of octets, into a bytevector.")
574 #define FUNC_NAME s_scm_r6rs_u8_list_to_bytevector
580 SCM_VALIDATE_LIST_COPYLEN (1, lst
, c_len
);
582 bv
= make_bytevector (c_len
);
583 c_bv
= (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv
);
585 for (i
= 0; i
< c_len
; lst
= SCM_CDR (lst
), i
++)
587 item
= SCM_CAR (lst
);
589 if (SCM_LIKELY (SCM_I_INUMP (item
)))
593 c_item
= SCM_I_INUM (item
);
594 if (SCM_LIKELY ((c_item
>= 0) && (c_item
< 256)))
595 c_bv
[i
] = (unsigned char) c_item
;
606 scm_wrong_type_arg (FUNC_NAME
, 1, item
);
612 /* Compute the two's complement of VALUE (a positive integer) on SIZE octets
613 using (2^(SIZE * 8) - VALUE). */
615 twos_complement (mpz_t value
, size_t size
)
617 unsigned long bit_count
;
619 /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
620 checking on SIZE performed earlier. */
621 bit_count
= (unsigned long) size
<< 3UL;
623 if (SCM_LIKELY (bit_count
< sizeof (unsigned long)))
624 mpz_ui_sub (value
, 1UL << bit_count
, value
);
630 mpz_ui_pow_ui (max
, 2, bit_count
);
631 mpz_sub (value
, max
, value
);
637 bytevector_large_ref (const char *c_bv
, size_t c_size
, int signed_p
,
642 int c_endianness
, negative_p
= 0;
646 if (scm_is_eq (endianness
, scm_sym_big
))
647 negative_p
= c_bv
[0] & 0x80;
649 negative_p
= c_bv
[c_size
- 1] & 0x80;
652 c_endianness
= scm_is_eq (endianness
, scm_sym_big
) ? 1 : -1;
655 mpz_import (c_mpz
, 1 /* 1 word */, 1 /* word order doesn't matter */,
656 c_size
/* word is C_SIZE-byte long */,
658 0 /* nails */, c_bv
);
660 if (signed_p
&& negative_p
)
662 twos_complement (c_mpz
, c_size
);
663 mpz_neg (c_mpz
, c_mpz
);
666 result
= scm_from_mpz (c_mpz
);
667 mpz_clear (c_mpz
); /* FIXME: Needed? */
673 bytevector_large_set (char *c_bv
, size_t c_size
, int signed_p
,
674 SCM value
, SCM endianness
)
677 int c_endianness
, c_sign
, err
= 0;
679 c_endianness
= scm_is_eq (endianness
, scm_sym_big
) ? 1 : -1;
682 scm_to_mpz (value
, c_mpz
);
684 c_sign
= mpz_sgn (c_mpz
);
687 if (SCM_LIKELY (signed_p
))
689 mpz_neg (c_mpz
, c_mpz
);
690 twos_complement (c_mpz
, c_size
);
701 memset (c_bv
, 0, c_size
);
704 size_t word_count
, value_size
;
706 value_size
= (mpz_sizeinbase (c_mpz
, 2) + (8 * c_size
)) / (8 * c_size
);
707 if (SCM_UNLIKELY (value_size
> c_size
))
714 mpz_export (c_bv
, &word_count
, 1 /* word order doesn't matter */,
715 c_size
, c_endianness
,
716 0 /* nails */, c_mpz
);
717 if (SCM_UNLIKELY (word_count
!= 1))
718 /* Shouldn't happen since we already checked with VALUE_SIZE. */
728 #define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \
729 unsigned c_len, c_index, c_size; \
732 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv); \
733 c_index = scm_to_uint (index); \
734 c_size = scm_to_uint (size); \
736 c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv); \
737 c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv); \
739 /* C_SIZE must have its 3 higher bits set to zero so that \
740 multiplying it by 8 yields a number that fits in an \
742 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
743 scm_out_of_range (FUNC_NAME, size); \
744 if (SCM_UNLIKELY (c_index + c_size > c_len)) \
745 scm_out_of_range (FUNC_NAME, index);
748 /* Template of an integer reference function. */
749 #define GENERIC_INTEGER_REF(_sign) \
757 swap = !scm_is_eq (endianness, native_endianness); \
762 _sign char c_value8; \
763 memcpy (&c_value8, c_bv, 1); \
769 INT_TYPE (16, _sign) c_value16; \
770 memcpy (&c_value16, c_bv, 2); \
772 value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \
781 result = SCM_I_MAKINUM ((_sign int) value); \
784 result = bytevector_large_ref ((char *) c_bv, \
785 c_size, SIGNEDNESS (_sign), \
791 bytevector_signed_ref (const char *c_bv
, size_t c_size
, SCM endianness
)
793 GENERIC_INTEGER_REF (signed);
797 bytevector_unsigned_ref (const char *c_bv
, size_t c_size
, SCM endianness
)
799 GENERIC_INTEGER_REF (unsigned);
803 /* Template of an integer assignment function. */
804 #define GENERIC_INTEGER_SET(_sign) \
809 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
812 c_value = SCM_I_INUM (value); \
816 if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \
818 _sign char c_value8; \
819 c_value8 = (_sign char) c_value; \
820 memcpy (c_bv, &c_value8, 1); \
827 if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \
830 INT_TYPE (16, _sign) c_value16; \
832 swap = !scm_is_eq (endianness, native_endianness); \
835 c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \
837 c_value16 = c_value; \
839 memcpy (c_bv, &c_value16, 2); \
853 err = bytevector_large_set (c_bv, c_size, \
854 SIGNEDNESS (_sign), \
855 value, endianness); \
863 scm_out_of_range (FUNC_NAME, value); \
867 bytevector_signed_set (char *c_bv
, size_t c_size
,
868 SCM value
, SCM endianness
,
869 const char *func_name
)
870 #define FUNC_NAME func_name
872 GENERIC_INTEGER_SET (signed);
877 bytevector_unsigned_set (char *c_bv
, size_t c_size
,
878 SCM value
, SCM endianness
,
879 const char *func_name
)
880 #define FUNC_NAME func_name
882 GENERIC_INTEGER_SET (unsigned);
886 #undef GENERIC_INTEGER_SET
887 #undef GENERIC_INTEGER_REF
890 SCM_DEFINE (scm_r6rs_bytevector_uint_ref
, "bytevector-uint-ref", 4, 0, 0,
891 (SCM bv
, SCM index
, SCM endianness
, SCM size
),
892 "Return the @var{size}-octet long unsigned integer at index "
893 "@var{index} in @var{bv}.")
894 #define FUNC_NAME s_scm_r6rs_bytevector_uint_ref
896 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
898 return (bytevector_unsigned_ref (&c_bv
[c_index
], c_size
, endianness
));
902 SCM_DEFINE (scm_r6rs_bytevector_sint_ref
, "bytevector-sint-ref", 4, 0, 0,
903 (SCM bv
, SCM index
, SCM endianness
, SCM size
),
904 "Return the @var{size}-octet long unsigned integer at index "
905 "@var{index} in @var{bv}.")
906 #define FUNC_NAME s_scm_r6rs_bytevector_sint_ref
908 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
910 return (bytevector_signed_ref (&c_bv
[c_index
], c_size
, endianness
));
914 SCM_DEFINE (scm_r6rs_bytevector_uint_set_x
, "bytevector-uint-set!", 5, 0, 0,
915 (SCM bv
, SCM index
, SCM value
, SCM endianness
, SCM size
),
916 "Set the @var{size}-octet long unsigned integer at @var{index} "
918 #define FUNC_NAME s_scm_r6rs_bytevector_uint_set_x
920 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
922 bytevector_unsigned_set (&c_bv
[c_index
], c_size
, value
, endianness
,
925 return SCM_UNSPECIFIED
;
929 SCM_DEFINE (scm_r6rs_bytevector_sint_set_x
, "bytevector-sint-set!", 5, 0, 0,
930 (SCM bv
, SCM index
, SCM value
, SCM endianness
, SCM size
),
931 "Set the @var{size}-octet long signed integer at @var{index} "
933 #define FUNC_NAME s_scm_r6rs_bytevector_sint_set_x
935 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
937 bytevector_signed_set (&c_bv
[c_index
], c_size
, value
, endianness
,
940 return SCM_UNSPECIFIED
;
946 /* Operations on integers of arbitrary size. */
948 #define INTEGERS_TO_LIST(_sign) \
950 size_t i, c_len, c_size; \
952 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv); \
953 SCM_VALIDATE_SYMBOL (2, endianness); \
954 c_size = scm_to_uint (size); \
956 c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv); \
957 if (SCM_UNLIKELY (c_len == 0)) \
959 else if (SCM_UNLIKELY (c_len < c_size)) \
960 scm_out_of_range (FUNC_NAME, size); \
965 c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv); \
967 lst = scm_make_list (scm_from_uint (c_len / c_size), \
969 for (i = 0, pair = lst; \
970 i <= c_len - c_size; \
971 i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
974 bytevector_ ## _sign ## _ref (c_bv, c_size, \
981 SCM_DEFINE (scm_r6rs_bytevector_to_sint_list
, "bytevector->sint-list",
983 (SCM bv
, SCM endianness
, SCM size
),
984 "Return a list of signed integers of @var{size} octets "
985 "representing the contents of @var{bv}.")
986 #define FUNC_NAME s_scm_r6rs_bytevector_to_sint_list
988 INTEGERS_TO_LIST (signed);
992 SCM_DEFINE (scm_r6rs_bytevector_to_uint_list
, "bytevector->uint-list",
994 (SCM bv
, SCM endianness
, SCM size
),
995 "Return a list of unsigned integers of @var{size} octets "
996 "representing the contents of @var{bv}.")
997 #define FUNC_NAME s_scm_r6rs_bytevector_to_uint_list
999 INTEGERS_TO_LIST (unsigned);
1003 #undef INTEGER_TO_LIST
1006 #define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
1010 char *c_bv, *c_bv_ptr; \
1012 SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
1013 SCM_VALIDATE_SYMBOL (2, endianness); \
1014 c_size = scm_to_uint (size); \
1016 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
1017 scm_out_of_range (FUNC_NAME, size); \
1019 bv = make_bytevector (c_len * c_size); \
1020 c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv); \
1022 for (c_bv_ptr = c_bv; \
1023 !scm_is_null (lst); \
1024 lst = SCM_CDR (lst), c_bv_ptr += c_size) \
1026 bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
1027 SCM_CAR (lst), endianness, \
1034 SCM_DEFINE (scm_r6rs_uint_list_to_bytevector
, "uint-list->bytevector",
1036 (SCM lst
, SCM endianness
, SCM size
),
1037 "Return a bytevector containing the unsigned integers "
1038 "listed in @var{lst} and encoded on @var{size} octets "
1039 "according to @var{endianness}.")
1040 #define FUNC_NAME s_scm_r6rs_uint_list_to_bytevector
1042 INTEGER_LIST_TO_BYTEVECTOR (unsigned);
1046 SCM_DEFINE (scm_r6rs_sint_list_to_bytevector
, "sint-list->bytevector",
1048 (SCM lst
, SCM endianness
, SCM size
),
1049 "Return a bytevector containing the signed integers "
1050 "listed in @var{lst} and encoded on @var{size} octets "
1051 "according to @var{endianness}.")
1052 #define FUNC_NAME s_scm_r6rs_sint_list_to_bytevector
1054 INTEGER_LIST_TO_BYTEVECTOR (signed);
1058 #undef INTEGER_LIST_TO_BYTEVECTOR
1062 /* Operations on 16-bit integers. */
1064 SCM_DEFINE (scm_r6rs_bytevector_u16_ref
, "bytevector-u16-ref",
1066 (SCM bv
, SCM index
, SCM endianness
),
1067 "Return the unsigned 16-bit integer from @var{bv} at "
1069 #define FUNC_NAME s_scm_r6rs_bytevector_u16_ref
1071 INTEGER_REF (16, unsigned);
1075 SCM_DEFINE (scm_r6rs_bytevector_s16_ref
, "bytevector-s16-ref",
1077 (SCM bv
, SCM index
, SCM endianness
),
1078 "Return the signed 16-bit integer from @var{bv} at "
1080 #define FUNC_NAME s_scm_r6rs_bytevector_s16_ref
1082 INTEGER_REF (16, signed);
1086 SCM_DEFINE (scm_r6rs_bytevector_u16_native_ref
, "bytevector-u16-native-ref",
1088 (SCM bv
, SCM index
),
1089 "Return the unsigned 16-bit integer from @var{bv} at "
1090 "@var{index} using the native endianness.")
1091 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_ref
1093 INTEGER_NATIVE_REF (16, unsigned);
1097 SCM_DEFINE (scm_r6rs_bytevector_s16_native_ref
, "bytevector-s16-native-ref",
1099 (SCM bv
, SCM index
),
1100 "Return the unsigned 16-bit integer from @var{bv} at "
1101 "@var{index} using the native endianness.")
1102 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_ref
1104 INTEGER_NATIVE_REF (16, signed);
1108 SCM_DEFINE (scm_r6rs_bytevector_u16_set_x
, "bytevector-u16-set!",
1110 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1111 "Store @var{value} in @var{bv} at @var{index} according to "
1112 "@var{endianness}.")
1113 #define FUNC_NAME s_scm_r6rs_bytevector_u16_set_x
1115 INTEGER_SET (16, unsigned);
1119 SCM_DEFINE (scm_r6rs_bytevector_s16_set_x
, "bytevector-s16-set!",
1121 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1122 "Store @var{value} in @var{bv} at @var{index} according to "
1123 "@var{endianness}.")
1124 #define FUNC_NAME s_scm_r6rs_bytevector_s16_set_x
1126 INTEGER_SET (16, signed);
1130 SCM_DEFINE (scm_r6rs_bytevector_u16_native_set_x
, "bytevector-u16-native-set!",
1132 (SCM bv
, SCM index
, SCM value
),
1133 "Store the unsigned integer @var{value} at index @var{index} "
1134 "of @var{bv} using the native endianness.")
1135 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_set_x
1137 INTEGER_NATIVE_SET (16, unsigned);
1141 SCM_DEFINE (scm_r6rs_bytevector_s16_native_set_x
, "bytevector-s16-native-set!",
1143 (SCM bv
, SCM index
, SCM value
),
1144 "Store the signed integer @var{value} at index @var{index} "
1145 "of @var{bv} using the native endianness.")
1146 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_set_x
1148 INTEGER_NATIVE_SET (16, signed);
1154 /* Operations on 32-bit integers. */
1156 /* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
1157 arbitrary 32-bit integers. Thus we fall back to using the
1158 `large_{ref,set}' variants on 32-bit machines. */
1160 #define LARGE_INTEGER_REF(_len, _sign) \
1161 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1162 SCM_VALIDATE_SYMBOL (3, endianness); \
1164 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1165 SIGNEDNESS (_sign), endianness));
1167 #define LARGE_INTEGER_SET(_len, _sign) \
1169 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1170 SCM_VALIDATE_SYMBOL (4, endianness); \
1172 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1173 SIGNEDNESS (_sign), value, endianness); \
1174 if (SCM_UNLIKELY (err)) \
1175 scm_out_of_range (FUNC_NAME, value); \
1177 return SCM_UNSPECIFIED;
1179 #define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
1180 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1181 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1182 SIGNEDNESS (_sign), native_endianness));
1184 #define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
1186 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1188 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1189 SIGNEDNESS (_sign), value, \
1190 native_endianness); \
1191 if (SCM_UNLIKELY (err)) \
1192 scm_out_of_range (FUNC_NAME, value); \
1194 return SCM_UNSPECIFIED;
1197 SCM_DEFINE (scm_r6rs_bytevector_u32_ref
, "bytevector-u32-ref",
1199 (SCM bv
, SCM index
, SCM endianness
),
1200 "Return the unsigned 32-bit integer from @var{bv} at "
1202 #define FUNC_NAME s_scm_r6rs_bytevector_u32_ref
1204 #if SIZEOF_VOID_P > 4
1205 INTEGER_REF (32, unsigned);
1207 LARGE_INTEGER_REF (32, unsigned);
1212 SCM_DEFINE (scm_r6rs_bytevector_s32_ref
, "bytevector-s32-ref",
1214 (SCM bv
, SCM index
, SCM endianness
),
1215 "Return the signed 32-bit integer from @var{bv} at "
1217 #define FUNC_NAME s_scm_r6rs_bytevector_s32_ref
1219 #if SIZEOF_VOID_P > 4
1220 INTEGER_REF (32, signed);
1222 LARGE_INTEGER_REF (32, signed);
1227 SCM_DEFINE (scm_r6rs_bytevector_u32_native_ref
, "bytevector-u32-native-ref",
1229 (SCM bv
, SCM index
),
1230 "Return the unsigned 32-bit integer from @var{bv} at "
1231 "@var{index} using the native endianness.")
1232 #define FUNC_NAME s_scm_r6rs_bytevector_u32_native_ref
1234 #if SIZEOF_VOID_P > 4
1235 INTEGER_NATIVE_REF (32, unsigned);
1237 LARGE_INTEGER_NATIVE_REF (32, unsigned);
1242 SCM_DEFINE (scm_r6rs_bytevector_s32_native_ref
, "bytevector-s32-native-ref",
1244 (SCM bv
, SCM index
),
1245 "Return the unsigned 32-bit integer from @var{bv} at "
1246 "@var{index} using the native endianness.")
1247 #define FUNC_NAME s_scm_r6rs_bytevector_u32_native_ref
1249 #if SIZEOF_VOID_P > 4
1250 INTEGER_NATIVE_REF (32, signed);
1252 LARGE_INTEGER_NATIVE_REF (32, signed);
1257 SCM_DEFINE (scm_r6rs_bytevector_u32_set_x
, "bytevector-u32-set!",
1259 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1260 "Store @var{value} in @var{bv} at @var{index} according to "
1261 "@var{endianness}.")
1262 #define FUNC_NAME s_scm_r6rs_bytevector_u32_set_x
1264 #if SIZEOF_VOID_P > 4
1265 INTEGER_SET (32, unsigned);
1267 LARGE_INTEGER_SET (32, unsigned);
1272 SCM_DEFINE (scm_r6rs_bytevector_s32_set_x
, "bytevector-s32-set!",
1274 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1275 "Store @var{value} in @var{bv} at @var{index} according to "
1276 "@var{endianness}.")
1277 #define FUNC_NAME s_scm_r6rs_bytevector_s32_set_x
1279 #if SIZEOF_VOID_P > 4
1280 INTEGER_SET (32, signed);
1282 LARGE_INTEGER_SET (32, signed);
1287 SCM_DEFINE (scm_r6rs_bytevector_u32_native_set_x
, "bytevector-u32-native-set!",
1289 (SCM bv
, SCM index
, SCM value
),
1290 "Store the unsigned integer @var{value} at index @var{index} "
1291 "of @var{bv} using the native endianness.")
1292 #define FUNC_NAME s_scm_r6rs_bytevector_u32_native_set_x
1294 #if SIZEOF_VOID_P > 4
1295 INTEGER_NATIVE_SET (32, unsigned);
1297 LARGE_INTEGER_NATIVE_SET (32, unsigned);
1302 SCM_DEFINE (scm_r6rs_bytevector_s32_native_set_x
, "bytevector-s32-native-set!",
1304 (SCM bv
, SCM index
, SCM value
),
1305 "Store the signed integer @var{value} at index @var{index} "
1306 "of @var{bv} using the native endianness.")
1307 #define FUNC_NAME s_scm_r6rs_bytevector_u32_native_set_x
1309 #if SIZEOF_VOID_P > 4
1310 INTEGER_NATIVE_SET (32, signed);
1312 LARGE_INTEGER_NATIVE_SET (32, signed);
1319 /* Operations on 64-bit integers. */
1321 /* For 64-bit integers, we use only the `large_{ref,set}' variant. */
1323 SCM_DEFINE (scm_r6rs_bytevector_u64_ref
, "bytevector-u64-ref",
1325 (SCM bv
, SCM index
, SCM endianness
),
1326 "Return the unsigned 64-bit integer from @var{bv} at "
1328 #define FUNC_NAME s_scm_r6rs_bytevector_u64_ref
1330 LARGE_INTEGER_REF (64, unsigned);
1334 SCM_DEFINE (scm_r6rs_bytevector_s64_ref
, "bytevector-s64-ref",
1336 (SCM bv
, SCM index
, SCM endianness
),
1337 "Return the signed 64-bit integer from @var{bv} at "
1339 #define FUNC_NAME s_scm_r6rs_bytevector_s64_ref
1341 LARGE_INTEGER_REF (64, signed);
1345 SCM_DEFINE (scm_r6rs_bytevector_u64_native_ref
, "bytevector-u64-native-ref",
1347 (SCM bv
, SCM index
),
1348 "Return the unsigned 64-bit integer from @var{bv} at "
1349 "@var{index} using the native endianness.")
1350 #define FUNC_NAME s_scm_r6rs_bytevector_u64_native_ref
1352 LARGE_INTEGER_NATIVE_REF (64, unsigned);
1356 SCM_DEFINE (scm_r6rs_bytevector_s64_native_ref
, "bytevector-s64-native-ref",
1358 (SCM bv
, SCM index
),
1359 "Return the unsigned 64-bit integer from @var{bv} at "
1360 "@var{index} using the native endianness.")
1361 #define FUNC_NAME s_scm_r6rs_bytevector_u64_native_ref
1363 LARGE_INTEGER_NATIVE_REF (64, signed);
1367 SCM_DEFINE (scm_r6rs_bytevector_u64_set_x
, "bytevector-u64-set!",
1369 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1370 "Store @var{value} in @var{bv} at @var{index} according to "
1371 "@var{endianness}.")
1372 #define FUNC_NAME s_scm_r6rs_bytevector_u64_set_x
1374 LARGE_INTEGER_SET (64, unsigned);
1378 SCM_DEFINE (scm_r6rs_bytevector_s64_set_x
, "bytevector-s64-set!",
1380 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1381 "Store @var{value} in @var{bv} at @var{index} according to "
1382 "@var{endianness}.")
1383 #define FUNC_NAME s_scm_r6rs_bytevector_s64_set_x
1385 LARGE_INTEGER_SET (64, signed);
1389 SCM_DEFINE (scm_r6rs_bytevector_u64_native_set_x
, "bytevector-u64-native-set!",
1391 (SCM bv
, SCM index
, SCM value
),
1392 "Store the unsigned integer @var{value} at index @var{index} "
1393 "of @var{bv} using the native endianness.")
1394 #define FUNC_NAME s_scm_r6rs_bytevector_u64_native_set_x
1396 LARGE_INTEGER_NATIVE_SET (64, unsigned);
1400 SCM_DEFINE (scm_r6rs_bytevector_s64_native_set_x
, "bytevector-s64-native-set!",
1402 (SCM bv
, SCM index
, SCM value
),
1403 "Store the signed integer @var{value} at index @var{index} "
1404 "of @var{bv} using the native endianness.")
1405 #define FUNC_NAME s_scm_r6rs_bytevector_u64_native_set_x
1407 LARGE_INTEGER_NATIVE_SET (64, signed);
1413 /* Operations on IEEE-754 numbers. */
1415 /* There are two possible word endians, visible in glibc's <ieee754.h>.
1416 However, in R6RS, when the endianness is `little', little endian is
1417 assumed for both the byte order and the word order. This is clear from
1418 Section 2.1 of R6RS-lib (in response to
1419 http://www.r6rs.org/formal-comments/comment-187.txt). */
1422 /* Convert to/from a floating-point number with different endianness. This
1423 method is probably not the most efficient but it should be portable. */
1426 float_to_foreign_endianness (union scm_r6rs_ieee754_float
*target
,
1429 union scm_r6rs_ieee754_float src
;
1433 #ifdef WORDS_BIGENDIAN
1434 /* Assuming little endian for both byte and word order. */
1435 target
->little_endian
.negative
= src
.big_endian
.negative
;
1436 target
->little_endian
.exponent
= src
.big_endian
.exponent
;
1437 target
->little_endian
.mantissa
= src
.big_endian
.mantissa
;
1439 target
->big_endian
.negative
= src
.little_endian
.negative
;
1440 target
->big_endian
.exponent
= src
.little_endian
.exponent
;
1441 target
->big_endian
.mantissa
= src
.little_endian
.mantissa
;
1446 float_from_foreign_endianness (const union scm_r6rs_ieee754_float
*source
)
1448 union scm_r6rs_ieee754_float result
;
1450 #ifdef WORDS_BIGENDIAN
1451 /* Assuming little endian for both byte and word order. */
1452 result
.big_endian
.negative
= source
->little_endian
.negative
;
1453 result
.big_endian
.exponent
= source
->little_endian
.exponent
;
1454 result
.big_endian
.mantissa
= source
->little_endian
.mantissa
;
1456 result
.little_endian
.negative
= source
->big_endian
.negative
;
1457 result
.little_endian
.exponent
= source
->big_endian
.exponent
;
1458 result
.little_endian
.mantissa
= source
->big_endian
.mantissa
;
1465 double_to_foreign_endianness (union scm_r6rs_ieee754_double
*target
,
1468 union scm_r6rs_ieee754_double src
;
1472 #ifdef WORDS_BIGENDIAN
1473 /* Assuming little endian for both byte and word order. */
1474 target
->little_little_endian
.negative
= src
.big_endian
.negative
;
1475 target
->little_little_endian
.exponent
= src
.big_endian
.exponent
;
1476 target
->little_little_endian
.mantissa0
= src
.big_endian
.mantissa0
;
1477 target
->little_little_endian
.mantissa1
= src
.big_endian
.mantissa1
;
1479 target
->big_endian
.negative
= src
.little_little_endian
.negative
;
1480 target
->big_endian
.exponent
= src
.little_little_endian
.exponent
;
1481 target
->big_endian
.mantissa0
= src
.little_little_endian
.mantissa0
;
1482 target
->big_endian
.mantissa1
= src
.little_little_endian
.mantissa1
;
1486 static inline double
1487 double_from_foreign_endianness (const union scm_r6rs_ieee754_double
*source
)
1489 union scm_r6rs_ieee754_double result
;
1491 #ifdef WORDS_BIGENDIAN
1492 /* Assuming little endian for both byte and word order. */
1493 result
.big_endian
.negative
= source
->little_little_endian
.negative
;
1494 result
.big_endian
.exponent
= source
->little_little_endian
.exponent
;
1495 result
.big_endian
.mantissa0
= source
->little_little_endian
.mantissa0
;
1496 result
.big_endian
.mantissa1
= source
->little_little_endian
.mantissa1
;
1498 result
.little_little_endian
.negative
= source
->big_endian
.negative
;
1499 result
.little_little_endian
.exponent
= source
->big_endian
.exponent
;
1500 result
.little_little_endian
.mantissa0
= source
->big_endian
.mantissa0
;
1501 result
.little_little_endian
.mantissa1
= source
->big_endian
.mantissa1
;
1507 /* Template macros to abstract over doubles and floats.
1508 XXX: Guile can only convert to/from doubles. */
1509 #define IEEE754_UNION(_c_type) union scm_r6rs_ieee754_ ## _c_type
1510 #define IEEE754_TO_SCM(_c_type) scm_from_double
1511 #define IEEE754_FROM_SCM(_c_type) scm_to_double
1512 #define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
1513 _c_type ## _from_foreign_endianness
1514 #define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
1515 _c_type ## _to_foreign_endianness
1518 /* Templace getters and setters. */
1520 #define IEEE754_ACCESSOR_PROLOGUE(_type) \
1521 INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
1523 #define IEEE754_REF(_type) \
1526 IEEE754_ACCESSOR_PROLOGUE (_type); \
1527 SCM_VALIDATE_SYMBOL (3, endianness); \
1529 if (scm_is_eq (endianness, native_endianness)) \
1530 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1533 IEEE754_UNION (_type) c_raw; \
1535 memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
1537 IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
1540 return (IEEE754_TO_SCM (_type) (c_result));
1542 #define IEEE754_NATIVE_REF(_type) \
1545 IEEE754_ACCESSOR_PROLOGUE (_type); \
1547 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1548 return (IEEE754_TO_SCM (_type) (c_result));
1550 #define IEEE754_SET(_type) \
1553 IEEE754_ACCESSOR_PROLOGUE (_type); \
1554 SCM_VALIDATE_REAL (3, value); \
1555 SCM_VALIDATE_SYMBOL (4, endianness); \
1556 c_value = IEEE754_FROM_SCM (_type) (value); \
1558 if (scm_is_eq (endianness, native_endianness)) \
1559 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1562 IEEE754_UNION (_type) c_raw; \
1564 IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
1565 memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
1568 return SCM_UNSPECIFIED;
1570 #define IEEE754_NATIVE_SET(_type) \
1573 IEEE754_ACCESSOR_PROLOGUE (_type); \
1574 SCM_VALIDATE_REAL (3, value); \
1575 c_value = IEEE754_FROM_SCM (_type) (value); \
1577 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1578 return SCM_UNSPECIFIED;
1581 /* Single precision. */
1583 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_ref
,
1584 "bytevector-ieee-single-ref",
1586 (SCM bv
, SCM index
, SCM endianness
),
1587 "Return the IEEE-754 single from @var{bv} at "
1589 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_ref
1591 IEEE754_REF (float);
1595 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_native_ref
,
1596 "bytevector-ieee-single-native-ref",
1598 (SCM bv
, SCM index
),
1599 "Return the IEEE-754 single from @var{bv} at "
1600 "@var{index} using the native endianness.")
1601 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_native_ref
1603 IEEE754_NATIVE_REF (float);
1607 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_set_x
,
1608 "bytevector-ieee-single-set!",
1610 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1611 "Store real @var{value} in @var{bv} at @var{index} according to "
1612 "@var{endianness}.")
1613 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_set_x
1615 IEEE754_SET (float);
1619 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_native_set_x
,
1620 "bytevector-ieee-single-native-set!",
1622 (SCM bv
, SCM index
, SCM value
),
1623 "Store the real @var{value} at index @var{index} "
1624 "of @var{bv} using the native endianness.")
1625 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_native_set_x
1627 IEEE754_NATIVE_SET (float);
1632 /* Double precision. */
1634 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_ref
,
1635 "bytevector-ieee-double-ref",
1637 (SCM bv
, SCM index
, SCM endianness
),
1638 "Return the IEEE-754 double from @var{bv} at "
1640 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_ref
1642 IEEE754_REF (double);
1646 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_native_ref
,
1647 "bytevector-ieee-double-native-ref",
1649 (SCM bv
, SCM index
),
1650 "Return the IEEE-754 double from @var{bv} at "
1651 "@var{index} using the native endianness.")
1652 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_native_ref
1654 IEEE754_NATIVE_REF (double);
1658 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_set_x
,
1659 "bytevector-ieee-double-set!",
1661 (SCM bv
, SCM index
, SCM value
, SCM endianness
),
1662 "Store real @var{value} in @var{bv} at @var{index} according to "
1663 "@var{endianness}.")
1664 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_set_x
1666 IEEE754_SET (double);
1670 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_native_set_x
,
1671 "bytevector-ieee-double-native-set!",
1673 (SCM bv
, SCM index
, SCM value
),
1674 "Store the real @var{value} at index @var{index} "
1675 "of @var{bv} using the native endianness.")
1676 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_native_set_x
1678 IEEE754_NATIVE_SET (double);
1683 #undef IEEE754_UNION
1684 #undef IEEE754_TO_SCM
1685 #undef IEEE754_FROM_SCM
1686 #undef IEEE754_FROM_FOREIGN_ENDIANNESS
1687 #undef IEEE754_TO_FOREIGN_ENDIANNESS
1689 #undef IEEE754_NATIVE_REF
1691 #undef IEEE754_NATIVE_SET
1694 /* Operations on strings. */
1697 /* Produce a function that returns the length of a UTF-encoded string. */
1698 #define UTF_STRLEN_FUNCTION(_utf_width) \
1699 static inline size_t \
1700 utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
1703 const uint ## _utf_width ## _t *ptr; \
1711 return (len * ((_utf_width) / 8)); \
1714 UTF_STRLEN_FUNCTION (8)
1717 /* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
1718 #define UTF_STRLEN(_utf_width, _str) \
1719 utf ## _utf_width ## _strlen (_str)
1721 /* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
1722 ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
1725 utf_encoding_name (char *name
, size_t utf_width
, SCM endianness
)
1727 strcpy (name
, "UTF-");
1728 strcat (name
, ((utf_width
== 8)
1730 : ((utf_width
== 16)
1732 : ((utf_width
== 32)
1736 ((scm_is_eq (endianness
, scm_sym_big
))
1738 : ((scm_is_eq (endianness
, scm_sym_little
))
1743 /* Maximum length of a UTF encoding name. */
1744 #define MAX_UTF_ENCODING_NAME_LEN 16
1746 /* Produce the body of a `string->utf' function. */
1747 #define STRING_TO_UTF(_utf_width) \
1751 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1752 char *c_utf = NULL, *c_locale; \
1753 size_t c_strlen, c_raw_strlen, c_utf_len = 0; \
1755 SCM_VALIDATE_STRING (1, str); \
1756 if (endianness == SCM_UNDEFINED) \
1757 endianness = scm_sym_big; \
1759 SCM_VALIDATE_SYMBOL (2, endianness); \
1761 c_strlen = scm_c_string_length (str); \
1762 c_raw_strlen = c_strlen * ((_utf_width) / 8); \
1765 c_str = (char *) alloca (c_raw_strlen + 1); \
1766 c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \
1768 while (c_raw_strlen > c_strlen); \
1769 c_str[c_raw_strlen] = '\0'; \
1771 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1773 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1774 strcpy (c_locale, locale_charset ()); \
1776 err = mem_iconveh (c_str, c_raw_strlen, \
1777 c_locale, c_utf_name, \
1778 iconveh_question_mark, NULL, \
1779 &c_utf, &c_utf_len); \
1780 if (SCM_UNLIKELY (err)) \
1781 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1782 scm_list_1 (str), err); \
1784 /* C_UTF is null-terminated. */ \
1785 utf = scm_r6rs_c_take_bytevector ((signed char *) c_utf, \
1792 SCM_DEFINE (scm_r6rs_string_to_utf8
, "string->utf8",
1795 "Return a newly allocated bytevector that contains the UTF-8 "
1796 "encoding of @var{str}.")
1797 #define FUNC_NAME s_scm_r6rs_string_to_utf8
1802 size_t c_strlen
, c_raw_strlen
;
1804 SCM_VALIDATE_STRING (1, str
);
1806 c_strlen
= scm_c_string_length (str
);
1807 c_raw_strlen
= c_strlen
;
1810 c_str
= (char *) alloca (c_raw_strlen
+ 1);
1811 c_raw_strlen
= scm_to_locale_stringbuf (str
, c_str
, c_strlen
);
1813 while (c_raw_strlen
> c_strlen
);
1814 c_str
[c_raw_strlen
] = '\0';
1816 c_utf
= u8_strconv_from_locale (c_str
);
1817 if (SCM_UNLIKELY (c_utf
== NULL
))
1818 scm_syserror (FUNC_NAME
);
1820 /* C_UTF is null-terminated. */
1821 utf
= scm_r6rs_c_take_bytevector ((signed char *) c_utf
,
1822 UTF_STRLEN (8, c_utf
));
1828 SCM_DEFINE (scm_r6rs_string_to_utf16
, "string->utf16",
1830 (SCM str
, SCM endianness
),
1831 "Return a newly allocated bytevector that contains the UTF-16 "
1832 "encoding of @var{str}.")
1833 #define FUNC_NAME s_scm_r6rs_string_to_utf16
1839 SCM_DEFINE (scm_r6rs_string_to_utf32
, "string->utf32",
1841 (SCM str
, SCM endianness
),
1842 "Return a newly allocated bytevector that contains the UTF-32 "
1843 "encoding of @var{str}.")
1844 #define FUNC_NAME s_scm_r6rs_string_to_utf32
1851 /* Produce the body of a function that converts a UTF-encoded bytevector to a
1853 #define UTF_TO_STRING(_utf_width) \
1854 SCM str = SCM_BOOL_F; \
1856 char *c_str = NULL, *c_locale; \
1857 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1858 const char *c_utf; \
1859 size_t c_strlen = 0, c_utf_len; \
1861 SCM_VALIDATE_R6RS_BYTEVECTOR (1, utf); \
1862 if (endianness == SCM_UNDEFINED) \
1863 endianness = scm_sym_big; \
1865 SCM_VALIDATE_SYMBOL (2, endianness); \
1867 c_utf_len = SCM_R6RS_BYTEVECTOR_LENGTH (utf); \
1868 c_utf = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (utf); \
1869 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1871 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1872 strcpy (c_locale, locale_charset ()); \
1874 err = mem_iconveh (c_utf, c_utf_len, \
1875 c_utf_name, c_locale, \
1876 iconveh_question_mark, NULL, \
1877 &c_str, &c_strlen); \
1878 if (SCM_UNLIKELY (err)) \
1879 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
1880 scm_list_1 (utf), err); \
1882 /* C_STR is null-terminated. */ \
1883 str = scm_take_locale_stringn (c_str, c_strlen); \
1888 SCM_DEFINE (scm_r6rs_utf8_to_string
, "utf8->string",
1891 "Return a newly allocate string that contains from the UTF-8-"
1892 "encoded contents of bytevector @var{utf}.")
1893 #define FUNC_NAME s_scm_r6rs_utf8_to_string
1897 char *c_str
= NULL
, *c_locale
;
1899 size_t c_utf_len
, c_strlen
= 0;
1901 SCM_VALIDATE_R6RS_BYTEVECTOR (1, utf
);
1903 c_utf_len
= SCM_R6RS_BYTEVECTOR_LENGTH (utf
);
1905 c_locale
= (char *) alloca (strlen (locale_charset ()) + 1);
1906 strcpy (c_locale
, locale_charset ());
1908 c_utf
= (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (utf
);
1909 err
= mem_iconveh (c_utf
, c_utf_len
,
1911 iconveh_question_mark
, NULL
,
1913 if (SCM_UNLIKELY (err
))
1914 scm_syserror_msg (FUNC_NAME
, "failed to convert to string: ~A",
1915 scm_list_1 (utf
), err
);
1917 /* C_STR is null-terminated. */
1918 str
= scm_take_locale_stringn (c_str
, c_strlen
);
1924 SCM_DEFINE (scm_r6rs_utf16_to_string
, "utf16->string",
1926 (SCM utf
, SCM endianness
),
1927 "Return a newly allocate string that contains from the UTF-17-"
1928 "encoded contents of bytevector @var{utf}.")
1929 #define FUNC_NAME s_scm_r6rs_utf16_to_string
1935 SCM_DEFINE (scm_r6rs_utf32_to_string
, "utf32->string",
1937 (SCM utf
, SCM endianness
),
1938 "Return a newly allocate string that contains from the UTF-17-"
1939 "encoded contents of bytevector @var{utf}.")
1940 #define FUNC_NAME s_scm_r6rs_utf32_to_string
1948 /* Initialization. */
1951 scm_init_r6rs_bytevector (void)
1953 #include "bytevector.x"
1955 #ifdef WORDS_BIGENDIAN
1956 native_endianness
= scm_sym_big
;
1958 native_endianness
= scm_sym_little
;
1961 scm_r6rs_endianness_big
= scm_sym_big
;
1962 scm_r6rs_endianness_little
= scm_sym_little
;
1964 scm_r6rs_null_bytevector
=
1965 scm_gc_protect_object (make_bytevector_from_buffer (0, NULL
));