HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
bytevectors: Use `size_t' rather than `unsigned' for sizes.
[bpt/guile.git] / libguile / bytevectors.c
CommitLineData
1ee2c72e
LC		 1/* Copyright (C) 2009 Free Software Foundation, Inc.
2 *
3 * This library is free software; you can redistribute it and/or
53befeb7
NJ		 4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
1ee2c72e 7 *
53befeb7
NJ		 8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
1ee2c72e
LC		 10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
12 *
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
53befeb7
NJ		 15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
16 * 02110-1301 USA
1ee2c72e
LC		 17 */
18
19
20#ifdef HAVE_CONFIG_H
21# include <config.h>
22#endif
23
24#include <alloca.h>
25
26#include <gmp.h>
27
28#include "libguile/_scm.h"
29#include "libguile/bytevectors.h"
30#include "libguile/strings.h"
31#include "libguile/validate.h"
32#include "libguile/ieee-754.h"
782a82ee
AW		 33#include "libguile/unif.h"
34#include "libguile/srfi-4.h"
1ee2c72e
LC		 35
36#include <byteswap.h>
37#include <striconveh.h>
38#include <uniconv.h>
39
40#ifdef HAVE_LIMITS_H
41# include <limits.h>
42#else
43/* Assuming 32-bit longs. */
44# define ULONG_MAX 4294967295UL
45#endif
46
47#include <string.h>
48
49
50\f
51/* Utilities. */
52
53/* Convenience macros. These are used by the various templates (macros) that
54 are parameterized by integer signedness. */
55#define INT8_T_signed scm_t_int8
56#define INT8_T_unsigned scm_t_uint8
57#define INT16_T_signed scm_t_int16
58#define INT16_T_unsigned scm_t_uint16
59#define INT32_T_signed scm_t_int32
60#define INT32_T_unsigned scm_t_uint32
61#define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L))
62#define is_unsigned_int8(_x) ((_x) <= 255UL)
63#define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
64#define is_unsigned_int16(_x) ((_x) <= 65535UL)
65#define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L))
66#define is_unsigned_int32(_x) ((_x) <= 4294967295UL)
67#define SIGNEDNESS_signed 1
68#define SIGNEDNESS_unsigned 0
69
70#define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign
71#define INT_SWAP(_size) bswap_ ## _size
72#define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
73#define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
74
75
76#define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \
2d34e924 77 size_t c_len, c_index; \
1ee2c72e
LC		 78 _sign char *c_bv; \
79 \
80 SCM_VALIDATE_BYTEVECTOR (1, bv); \
81 c_index = scm_to_uint (index); \
82 \
83 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
84 c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \
85 \
86 if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
87 scm_out_of_range (FUNC_NAME, index);
88
89/* Template for fixed-size integer access (only 8, 16 or 32-bit). */
90#define INTEGER_REF(_len, _sign) \
91 SCM result; \
92 \
93 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
94 SCM_VALIDATE_SYMBOL (3, endianness); \
95 \
96 { \
97 INT_TYPE (_len, _sign) c_result; \
98 \
99 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
100 if (!scm_is_eq (endianness, native_endianness)) \
101 c_result = INT_SWAP (_len) (c_result); \
102 \
103 result = SCM_I_MAKINUM (c_result); \
104 } \
105 \
106 return result;
107
108/* Template for fixed-size integer access using the native endianness. */
109#define INTEGER_NATIVE_REF(_len, _sign) \
110 SCM result; \
111 \
112 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
113 \
114 { \
115 INT_TYPE (_len, _sign) c_result; \
116 \
117 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
118 result = SCM_I_MAKINUM (c_result); \
119 } \
120 \
121 return result;
122
123/* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
124#define INTEGER_SET(_len, _sign) \
125 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
126 SCM_VALIDATE_SYMBOL (3, endianness); \
127 \
128 { \
129 _sign long c_value; \
130 INT_TYPE (_len, _sign) c_value_short; \
131 \
132 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
133 scm_wrong_type_arg (FUNC_NAME, 3, value); \
134 \
135 c_value = SCM_I_INUM (value); \
136 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
137 scm_out_of_range (FUNC_NAME, value); \
138 \
139 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
140 if (!scm_is_eq (endianness, native_endianness)) \
141 c_value_short = INT_SWAP (_len) (c_value_short); \
142 \
143 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
144 } \
145 \
146 return SCM_UNSPECIFIED;
147
148/* Template for fixed-size integer modification using the native
149 endianness. */
150#define INTEGER_NATIVE_SET(_len, _sign) \
151 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
152 \
153 { \
154 _sign long c_value; \
155 INT_TYPE (_len, _sign) c_value_short; \
156 \
157 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
158 scm_wrong_type_arg (FUNC_NAME, 3, value); \
159 \
160 c_value = SCM_I_INUM (value); \
161 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
162 scm_out_of_range (FUNC_NAME, value); \
163 \
164 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
165 \
166 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
167 } \
168 \
169 return SCM_UNSPECIFIED;
170
171
172\f
173/* Bytevector type. */
174
175SCM_GLOBAL_SMOB (scm_tc16_bytevector, "r6rs-bytevector", 0);
176
177#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
178 SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len))
179#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
180 SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf))
181
182/* The empty bytevector. */
183SCM scm_null_bytevector = SCM_UNSPECIFIED;
184
185
186static inline SCM
2d34e924 187make_bytevector_from_buffer (size_t len, signed char *contents)
1ee2c72e
LC		 188{
189 /* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */
190 SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector, len, contents);
191}
192
193static inline SCM
2d34e924 194make_bytevector (size_t len)
1ee2c72e
LC		 195{
196 SCM bv;
197
198 if (SCM_UNLIKELY (len == 0))
199 bv = scm_null_bytevector;
200 else
201 {
202 signed char *contents = NULL;
203
204 if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len))
205 contents = (signed char *) scm_gc_malloc (len, SCM_GC_BYTEVECTOR);
206
207 bv = make_bytevector_from_buffer (len, contents);
208 }
209
210 return bv;
211}
212
213/* Return a new bytevector of size LEN octets. */
214SCM
2d34e924 215scm_c_make_bytevector (size_t len)
1ee2c72e
LC		 216{
217 return (make_bytevector (len));
218}
219
220/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
221 by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
222SCM
2d34e924 223scm_c_take_bytevector (signed char *contents, size_t len)
1ee2c72e
LC		 224{
225 SCM bv;
226
227 if (SCM_UNLIKELY (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len)))
228 {
229 /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */
230 signed char *c_bv;
231
232 bv = make_bytevector (len);
233 c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
234 memcpy (c_bv, contents, len);
235 scm_gc_free (contents, len, SCM_GC_BYTEVECTOR);
236 }
237 else
238 bv = make_bytevector_from_buffer (len, contents);
239
240 return bv;
241}
242
243/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
244 size) and return BV. */
245SCM
2d34e924 246scm_i_shrink_bytevector (SCM bv, size_t c_new_len)
1ee2c72e
LC		 247{
248 if (!SCM_BYTEVECTOR_INLINE_P (bv))
249 {
2d34e924 250 size_t c_len;
1ee2c72e
LC		 251 signed char *c_bv, *c_new_bv;
252
253 c_len = SCM_BYTEVECTOR_LENGTH (bv);
254 c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
255
256 SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
257
258 if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len))
259 {
260 /* Copy to the in-line buffer and free the current buffer. */
261 c_new_bv = SCM_BYTEVECTOR_CONTENTS (bv);
262 memcpy (c_new_bv, c_bv, c_new_len);
263 scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
264 }
265 else
266 {
267 /* Resize the existing buffer. */
268 c_new_bv = scm_gc_realloc (c_bv, c_len, c_new_len,
269 SCM_GC_BYTEVECTOR);
270 SCM_BYTEVECTOR_SET_CONTENTS (bv, c_new_bv);
271 }
272 }
273
274 return bv;
275}
276
277SCM_SMOB_PRINT (scm_tc16_bytevector, print_bytevector,
278 bv, port, pstate)
279{
280 unsigned c_len, i;
281 unsigned char *c_bv;
282
283 c_len = SCM_BYTEVECTOR_LENGTH (bv);
284 c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
285
286 scm_puts ("#vu8(", port);
287 for (i = 0; i < c_len; i++)
288 {
289 if (i > 0)
290 scm_putc (' ', port);
291
292 scm_uintprint (c_bv[i], 10, port);
293 }
294
295 scm_putc (')', port);
296
297 /* Make GCC think we use it. */
298 scm_remember_upto_here ((SCM) pstate);
299
300 return 1;
301}
302
55bf8cb7
LC		 303SCM_SMOB_EQUALP (scm_tc16_bytevector, bytevector_equal_p, bv1, bv2)
304{
305 return scm_bytevector_eq_p (bv1, bv2);
306}
307
1ee2c72e
LC		 308SCM_SMOB_FREE (scm_tc16_bytevector, free_bytevector, bv)
309{
310
311 if (!SCM_BYTEVECTOR_INLINE_P (bv))
312 {
313 unsigned c_len;
314 signed char *c_bv;
315
316 c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
317 c_len = SCM_BYTEVECTOR_LENGTH (bv);
318
319 scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
320 }
321
322 return 0;
323}
324
325
326\f
327/* General operations. */
328
329SCM_SYMBOL (scm_sym_big, "big");
330SCM_SYMBOL (scm_sym_little, "little");
331
332SCM scm_endianness_big, scm_endianness_little;
333
334/* Host endianness (a symbol). */
335static SCM native_endianness = SCM_UNSPECIFIED;
336
337/* Byte-swapping. */
338#ifndef bswap_24
339# define bswap_24(_x) \
340 ((((_x) & 0xff0000) >> 16) | \
341 (((_x) & 0x00ff00)) | \
342 (((_x) & 0x0000ff) << 16))
343#endif
344
345
346SCM_DEFINE (scm_native_endianness, "native-endianness", 0, 0, 0,
347 (void),
348 "Return a symbol denoting the machine's native endianness.")
349#define FUNC_NAME s_scm_native_endianness
350{
351 return native_endianness;
352}
353#undef FUNC_NAME
354
355SCM_DEFINE (scm_bytevector_p, "bytevector?", 1, 0, 0,
356 (SCM obj),
357 "Return true if @var{obj} is a bytevector.")
358#define FUNC_NAME s_scm_bytevector_p
359{
360 return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_bytevector,
361 obj)));
362}
363#undef FUNC_NAME
364
365SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0,
366 (SCM len, SCM fill),
367 "Return a newly allocated bytevector of @var{len} bytes, "
368 "optionally filled with @var{fill}.")
369#define FUNC_NAME s_scm_make_bytevector
370{
371 SCM bv;
372 unsigned c_len;
373 signed char c_fill = '\0';
374
375 SCM_VALIDATE_UINT_COPY (1, len, c_len);
376 if (fill != SCM_UNDEFINED)
377 {
378 int value;
379
380 value = scm_to_int (fill);
381 if (SCM_UNLIKELY ((value < -128) || (value > 255)))
382 scm_out_of_range (FUNC_NAME, fill);
383 c_fill = (signed char) value;
384 }
385
386 bv = make_bytevector (c_len);
387 if (fill != SCM_UNDEFINED)
388 {
389 unsigned i;
390 signed char *contents;
391
392 contents = SCM_BYTEVECTOR_CONTENTS (bv);
393 for (i = 0; i < c_len; i++)
394 contents[i] = c_fill;
395 }
396
397 return bv;
398}
399#undef FUNC_NAME
400
401SCM_DEFINE (scm_bytevector_length, "bytevector-length", 1, 0, 0,
402 (SCM bv),
403 "Return the length (in bytes) of @var{bv}.")
404#define FUNC_NAME s_scm_bytevector_length
405{
406 SCM_VALIDATE_BYTEVECTOR (1, bv);
407
408 return (scm_from_uint (SCM_BYTEVECTOR_LENGTH (bv)));
409}
410#undef FUNC_NAME
411
412SCM_DEFINE (scm_bytevector_eq_p, "bytevector=?", 2, 0, 0,
413 (SCM bv1, SCM bv2),
414 "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
415 "have the same length and contents.")
416#define FUNC_NAME s_scm_bytevector_eq_p
417{
418 SCM result = SCM_BOOL_F;
419 unsigned c_len1, c_len2;
420
421 SCM_VALIDATE_BYTEVECTOR (1, bv1);
422 SCM_VALIDATE_BYTEVECTOR (2, bv2);
423
424 c_len1 = SCM_BYTEVECTOR_LENGTH (bv1);
425 c_len2 = SCM_BYTEVECTOR_LENGTH (bv2);
426
427 if (c_len1 == c_len2)
428 {
429 signed char *c_bv1, *c_bv2;
430
431 c_bv1 = SCM_BYTEVECTOR_CONTENTS (bv1);
432 c_bv2 = SCM_BYTEVECTOR_CONTENTS (bv2);
433
434 result = scm_from_bool (!memcmp (c_bv1, c_bv2, c_len1));
435 }
436
437 return result;
438}
439#undef FUNC_NAME
440
441SCM_DEFINE (scm_bytevector_fill_x, "bytevector-fill!", 2, 0, 0,
442 (SCM bv, SCM fill),
443 "Fill bytevector @var{bv} with @var{fill}, a byte.")
444#define FUNC_NAME s_scm_bytevector_fill_x
445{
446 unsigned c_len, i;
447 signed char *c_bv, c_fill;
448
449 SCM_VALIDATE_BYTEVECTOR (1, bv);
450 c_fill = scm_to_int8 (fill);
451
452 c_len = SCM_BYTEVECTOR_LENGTH (bv);
453 c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
454
455 for (i = 0; i < c_len; i++)
456 c_bv[i] = c_fill;
457
458 return SCM_UNSPECIFIED;
459}
460#undef FUNC_NAME
461
462SCM_DEFINE (scm_bytevector_copy_x, "bytevector-copy!", 5, 0, 0,
463 (SCM source, SCM source_start, SCM target, SCM target_start,
464 SCM len),
465 "Copy @var{len} bytes from @var{source} into @var{target}, "
466 "starting reading from @var{source_start} (a positive index "
467 "within @var{source}) and start writing at "
468 "@var{target_start}.")
469#define FUNC_NAME s_scm_bytevector_copy_x
470{
471 unsigned c_len, c_source_len, c_target_len;
472 unsigned c_source_start, c_target_start;
473 signed char *c_source, *c_target;
474
475 SCM_VALIDATE_BYTEVECTOR (1, source);
476 SCM_VALIDATE_BYTEVECTOR (3, target);
477
478 c_len = scm_to_uint (len);
479 c_source_start = scm_to_uint (source_start);
480 c_target_start = scm_to_uint (target_start);
481
482 c_source = SCM_BYTEVECTOR_CONTENTS (source);
483 c_target = SCM_BYTEVECTOR_CONTENTS (target);
484 c_source_len = SCM_BYTEVECTOR_LENGTH (source);
485 c_target_len = SCM_BYTEVECTOR_LENGTH (target);
486
487 if (SCM_UNLIKELY (c_source_start + c_len > c_source_len))
488 scm_out_of_range (FUNC_NAME, source_start);
489 if (SCM_UNLIKELY (c_target_start + c_len > c_target_len))
490 scm_out_of_range (FUNC_NAME, target_start);
491
492 memcpy (c_target + c_target_start,
493 c_source + c_source_start,
494 c_len);
495
496 return SCM_UNSPECIFIED;
497}
498#undef FUNC_NAME
499
500SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0,
501 (SCM bv),
502 "Return a newly allocated copy of @var{bv}.")
503#define FUNC_NAME s_scm_bytevector_copy
504{
505 SCM copy;
506 unsigned c_len;
507 signed char *c_bv, *c_copy;
508
509 SCM_VALIDATE_BYTEVECTOR (1, bv);
510
511 c_len = SCM_BYTEVECTOR_LENGTH (bv);
512 c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
513
514 copy = make_bytevector (c_len);
515 c_copy = SCM_BYTEVECTOR_CONTENTS (copy);
516 memcpy (c_copy, c_bv, c_len);
517
518 return copy;
519}
520#undef FUNC_NAME
521
782a82ee
AW		 522SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector",
523 1, 0, 0, (SCM array),
524 "Return a newly allocated bytevector whose contents\n"
525 "will be copied from the uniform array @var{array}.")
526#define FUNC_NAME s_scm_uniform_array_to_bytevector
527{
528 SCM contents, ret;
529 size_t len;
530 scm_t_array_handle h;
531 const void *base;
532 size_t sz;
533
534 contents = scm_array_contents (array, SCM_BOOL_T);
535 if (scm_is_false (contents))
536 scm_wrong_type_arg_msg (FUNC_NAME, 0, array, "uniform contiguous array");
537
538 scm_array_get_handle (contents, &h);
539
540 base = scm_array_handle_uniform_elements (&h);
541 len = h.dims->inc * (h.dims->ubnd - h.dims->lbnd + 1);
542 sz = scm_array_handle_uniform_element_size (&h);
543
544 ret = make_bytevector (len * sz);
545 memcpy (SCM_BYTEVECTOR_CONTENTS (ret), base, len * sz);
546
547 scm_array_handle_release (&h);
548
549 return ret;
550}
551#undef FUNC_NAME
552
1ee2c72e
LC		 553\f
554/* Operations on bytes and octets. */
555
556SCM_DEFINE (scm_bytevector_u8_ref, "bytevector-u8-ref", 2, 0, 0,
557 (SCM bv, SCM index),
558 "Return the octet located at @var{index} in @var{bv}.")
559#define FUNC_NAME s_scm_bytevector_u8_ref
560{
561 INTEGER_NATIVE_REF (8, unsigned);
562}
563#undef FUNC_NAME
564
565SCM_DEFINE (scm_bytevector_s8_ref, "bytevector-s8-ref", 2, 0, 0,
566 (SCM bv, SCM index),
567 "Return the byte located at @var{index} in @var{bv}.")
568#define FUNC_NAME s_scm_bytevector_s8_ref
569{
570 INTEGER_NATIVE_REF (8, signed);
571}
572#undef FUNC_NAME
573
574SCM_DEFINE (scm_bytevector_u8_set_x, "bytevector-u8-set!", 3, 0, 0,
575 (SCM bv, SCM index, SCM value),
576 "Return the octet located at @var{index} in @var{bv}.")
577#define FUNC_NAME s_scm_bytevector_u8_set_x
578{
579 INTEGER_NATIVE_SET (8, unsigned);
580}
581#undef FUNC_NAME
582
583SCM_DEFINE (scm_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0,
584 (SCM bv, SCM index, SCM value),
585 "Return the octet located at @var{index} in @var{bv}.")
cabf1b31 586#define FUNC_NAME s_scm_bytevector_s8_set_x
1ee2c72e
LC		 587{
588 INTEGER_NATIVE_SET (8, signed);
589}
590#undef FUNC_NAME
591
592#undef OCTET_ACCESSOR_PROLOGUE
593
594
595SCM_DEFINE (scm_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0,
596 (SCM bv),
597 "Return a newly allocated list of octets containing the "
598 "contents of @var{bv}.")
599#define FUNC_NAME s_scm_bytevector_to_u8_list
600{
601 SCM lst, pair;
602 unsigned c_len, i;
603 unsigned char *c_bv;
604
605 SCM_VALIDATE_BYTEVECTOR (1, bv);
606
607 c_len = SCM_BYTEVECTOR_LENGTH (bv);
608 c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
609
610 lst = scm_make_list (scm_from_uint (c_len), SCM_UNSPECIFIED);
611 for (i = 0, pair = lst;
612 i < c_len;
613 i++, pair = SCM_CDR (pair))
614 {
615 SCM_SETCAR (pair, SCM_I_MAKINUM (c_bv[i]));
616 }
617
618 return lst;
619}
620#undef FUNC_NAME
621
622SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0,
623 (SCM lst),
624 "Turn @var{lst}, a list of octets, into a bytevector.")
625#define FUNC_NAME s_scm_u8_list_to_bytevector
626{
627 SCM bv, item;
628 long c_len, i;
629 unsigned char *c_bv;
630
631 SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);
632
633 bv = make_bytevector (c_len);
634 c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
635
636 for (i = 0; i < c_len; lst = SCM_CDR (lst), i++)
637 {
638 item = SCM_CAR (lst);
639
640 if (SCM_LIKELY (SCM_I_INUMP (item)))
641 {
642 long c_item;
643
644 c_item = SCM_I_INUM (item);
645 if (SCM_LIKELY ((c_item >= 0) && (c_item < 256)))
646 c_bv[i] = (unsigned char) c_item;
647 else
648 goto type_error;
649 }
650 else
651 goto type_error;
652 }
653
654 return bv;
655
656 type_error:
657 scm_wrong_type_arg (FUNC_NAME, 1, item);
658
659 return SCM_BOOL_F;
660}
661#undef FUNC_NAME
662
663/* Compute the two's complement of VALUE (a positive integer) on SIZE octets
664 using (2^(SIZE * 8) - VALUE). */
665static inline void
666twos_complement (mpz_t value, size_t size)
667{
668 unsigned long bit_count;
669
670 /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
671 checking on SIZE performed earlier. */
672 bit_count = (unsigned long) size << 3UL;
673
674 if (SCM_LIKELY (bit_count < sizeof (unsigned long)))
675 mpz_ui_sub (value, 1UL << bit_count, value);
676 else
677 {
678 mpz_t max;
679
680 mpz_init (max);
681 mpz_ui_pow_ui (max, 2, bit_count);
682 mpz_sub (value, max, value);
683 mpz_clear (max);
684 }
685}
686
687static inline SCM
688bytevector_large_ref (const char *c_bv, size_t c_size, int signed_p,
689 SCM endianness)
690{
691 SCM result;
692 mpz_t c_mpz;
693 int c_endianness, negative_p = 0;
694
695 if (signed_p)
696 {
697 if (scm_is_eq (endianness, scm_sym_big))
698 negative_p = c_bv[0] & 0x80;
699 else
700 negative_p = c_bv[c_size - 1] & 0x80;
701 }
702
703 c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
704
705 mpz_init (c_mpz);
706 mpz_import (c_mpz, 1 /* 1 word */, 1 /* word order doesn't matter */,
707 c_size /* word is C_SIZE-byte long */,
708 c_endianness,
709 0 /* nails */, c_bv);
710
711 if (signed_p && negative_p)
712 {
713 twos_complement (c_mpz, c_size);
714 mpz_neg (c_mpz, c_mpz);
715 }
716
717 result = scm_from_mpz (c_mpz);
718 mpz_clear (c_mpz); /* FIXME: Needed? */
719
720 return result;
721}
722
723static inline int
724bytevector_large_set (char *c_bv, size_t c_size, int signed_p,
725 SCM value, SCM endianness)
726{
727 mpz_t c_mpz;
728 int c_endianness, c_sign, err = 0;
729
730 c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
731
732 mpz_init (c_mpz);
733 scm_to_mpz (value, c_mpz);
734
735 c_sign = mpz_sgn (c_mpz);
736 if (c_sign < 0)
737 {
738 if (SCM_LIKELY (signed_p))
739 {
740 mpz_neg (c_mpz, c_mpz);
741 twos_complement (c_mpz, c_size);
742 }
743 else
744 {
745 err = -1;
746 goto finish;
747 }
748 }
749
750 if (c_sign == 0)
751 /* Zero. */
752 memset (c_bv, 0, c_size);
753 else
754 {
755 size_t word_count, value_size;
756
757 value_size = (mpz_sizeinbase (c_mpz, 2) + (8 * c_size)) / (8 * c_size);
758 if (SCM_UNLIKELY (value_size > c_size))
759 {
760 err = -2;
761 goto finish;
762 }
763
764
765 mpz_export (c_bv, &word_count, 1 /* word order doesn't matter */,
766 c_size, c_endianness,
767 0 /* nails */, c_mpz);
768 if (SCM_UNLIKELY (word_count != 1))
769 /* Shouldn't happen since we already checked with VALUE_SIZE. */
770 abort ();
771 }
772
773 finish:
774 mpz_clear (c_mpz);
775
776 return err;
777}
778
779#define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \
780 unsigned long c_len, c_index, c_size; \
781 char *c_bv; \
782 \
783 SCM_VALIDATE_BYTEVECTOR (1, bv); \
784 c_index = scm_to_ulong (index); \
785 c_size = scm_to_ulong (size); \
786 \
787 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
788 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
789 \
790 /* C_SIZE must have its 3 higher bits set to zero so that \
791 multiplying it by 8 yields a number that fits in an \
792 unsigned long. */ \
793 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
794 scm_out_of_range (FUNC_NAME, size); \
795 if (SCM_UNLIKELY (c_index + c_size > c_len)) \
796 scm_out_of_range (FUNC_NAME, index);
797
798
799/* Template of an integer reference function. */
800#define GENERIC_INTEGER_REF(_sign) \
801 SCM result; \
802 \
803 if (c_size < 3) \
804 { \
805 int swap; \
806 _sign int value; \
807 \
808 swap = !scm_is_eq (endianness, native_endianness); \
809 switch (c_size) \
810 { \
811 case 1: \
812 { \
813 _sign char c_value8; \
814 memcpy (&c_value8, c_bv, 1); \
815 value = c_value8; \
816 } \
817 break; \
818 case 2: \
819 { \
820 INT_TYPE (16, _sign) c_value16; \
821 memcpy (&c_value16, c_bv, 2); \
822 if (swap) \
823 value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \
824 else \
825 value = c_value16; \
826 } \
827 break; \
828 default: \
829 abort (); \
830 } \
831 \
832 result = SCM_I_MAKINUM ((_sign int) value); \
833 } \
834 else \
835 result = bytevector_large_ref ((char *) c_bv, \
836 c_size, SIGNEDNESS (_sign), \
837 endianness); \
838 \
839 return result;
840
841static inline SCM
842bytevector_signed_ref (const char *c_bv, size_t c_size, SCM endianness)
843{
844 GENERIC_INTEGER_REF (signed);
845}
846
847static inline SCM
848bytevector_unsigned_ref (const char *c_bv, size_t c_size, SCM endianness)
849{
850 GENERIC_INTEGER_REF (unsigned);
851}
852
853
854/* Template of an integer assignment function. */
855#define GENERIC_INTEGER_SET(_sign) \
856 if (c_size < 3) \
857 { \
858 _sign int c_value; \
859 \
860 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
861 goto range_error; \
862 \
863 c_value = SCM_I_INUM (value); \
864 switch (c_size) \
865 { \
866 case 1: \
867 if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \
868 { \
869 _sign char c_value8; \
870 c_value8 = (_sign char) c_value; \
871 memcpy (c_bv, &c_value8, 1); \
872 } \
873 else \
874 goto range_error; \
875 break; \
876 \
877 case 2: \
878 if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \
879 { \
880 int swap; \
881 INT_TYPE (16, _sign) c_value16; \
882 \
883 swap = !scm_is_eq (endianness, native_endianness); \
884 \
885 if (swap) \
886 c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \
887 else \
888 c_value16 = c_value; \
889 \
890 memcpy (c_bv, &c_value16, 2); \
891 } \
892 else \
893 goto range_error; \
894 break; \
895 \
896 default: \
897 abort (); \
898 } \
899 } \
900 else \
901 { \
902 int err; \
903 \
904 err = bytevector_large_set (c_bv, c_size, \
905 SIGNEDNESS (_sign), \
906 value, endianness); \
907 if (err) \
908 goto range_error; \
909 } \
910 \
911 return; \
912 \
913 range_error: \
914 scm_out_of_range (FUNC_NAME, value); \
915 return;
916
917static inline void
918bytevector_signed_set (char *c_bv, size_t c_size,
919 SCM value, SCM endianness,
920 const char *func_name)
921#define FUNC_NAME func_name
922{
923 GENERIC_INTEGER_SET (signed);
924}
925#undef FUNC_NAME
926
927static inline void
928bytevector_unsigned_set (char *c_bv, size_t c_size,
929 SCM value, SCM endianness,
930 const char *func_name)
931#define FUNC_NAME func_name
932{
933 GENERIC_INTEGER_SET (unsigned);
934}
935#undef FUNC_NAME
936
937#undef GENERIC_INTEGER_SET
938#undef GENERIC_INTEGER_REF
939
940
941SCM_DEFINE (scm_bytevector_uint_ref, "bytevector-uint-ref", 4, 0, 0,
942 (SCM bv, SCM index, SCM endianness, SCM size),
943 "Return the @var{size}-octet long unsigned integer at index "
944 "@var{index} in @var{bv}.")
945#define FUNC_NAME s_scm_bytevector_uint_ref
946{
947 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
948
949 return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness));
950}
951#undef FUNC_NAME
952
953SCM_DEFINE (scm_bytevector_sint_ref, "bytevector-sint-ref", 4, 0, 0,
954 (SCM bv, SCM index, SCM endianness, SCM size),
955 "Return the @var{size}-octet long unsigned integer at index "
956 "@var{index} in @var{bv}.")
957#define FUNC_NAME s_scm_bytevector_sint_ref
958{
959 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
960
961 return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness));
962}
963#undef FUNC_NAME
964
965SCM_DEFINE (scm_bytevector_uint_set_x, "bytevector-uint-set!", 5, 0, 0,
966 (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
967 "Set the @var{size}-octet long unsigned integer at @var{index} "
968 "to @var{value}.")
969#define FUNC_NAME s_scm_bytevector_uint_set_x
970{
971 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
972
973 bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness,
974 FUNC_NAME);
975
976 return SCM_UNSPECIFIED;
977}
978#undef FUNC_NAME
979
980SCM_DEFINE (scm_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0,
981 (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
982 "Set the @var{size}-octet long signed integer at @var{index} "
983 "to @var{value}.")
984#define FUNC_NAME s_scm_bytevector_sint_set_x
985{
986 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
987
988 bytevector_signed_set (&c_bv[c_index], c_size, value, endianness,
989 FUNC_NAME);
990
991 return SCM_UNSPECIFIED;
992}
993#undef FUNC_NAME
994
995
996\f
997/* Operations on integers of arbitrary size. */
998
999#define INTEGERS_TO_LIST(_sign) \
1000 SCM lst, pair; \
1001 size_t i, c_len, c_size; \
1002 \
1003 SCM_VALIDATE_BYTEVECTOR (1, bv); \
1004 SCM_VALIDATE_SYMBOL (2, endianness); \
1005 c_size = scm_to_uint (size); \
1006 \
1007 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
1008 if (SCM_UNLIKELY (c_len == 0)) \
1009 lst = SCM_EOL; \
1010 else if (SCM_UNLIKELY (c_len < c_size)) \
1011 scm_out_of_range (FUNC_NAME, size); \
1012 else \
1013 { \
1014 const char *c_bv; \
1015 \
1016 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1017 \
1018 lst = scm_make_list (scm_from_uint (c_len / c_size), \
1019 SCM_UNSPECIFIED); \
1020 for (i = 0, pair = lst; \
1021 i <= c_len - c_size; \
1022 i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
1023 { \
1024 SCM_SETCAR (pair, \
1025 bytevector_ ## _sign ## _ref (c_bv, c_size, \
1026 endianness)); \
1027 } \
1028 } \
1029 \
1030 return lst;
1031
1032SCM_DEFINE (scm_bytevector_to_sint_list, "bytevector->sint-list",
1033 3, 0, 0,
1034 (SCM bv, SCM endianness, SCM size),
1035 "Return a list of signed integers of @var{size} octets "
1036 "representing the contents of @var{bv}.")
1037#define FUNC_NAME s_scm_bytevector_to_sint_list
1038{
1039 INTEGERS_TO_LIST (signed);
1040}
1041#undef FUNC_NAME
1042
1043SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list",
1044 3, 0, 0,
1045 (SCM bv, SCM endianness, SCM size),
1046 "Return a list of unsigned integers of @var{size} octets "
1047 "representing the contents of @var{bv}.")
1048#define FUNC_NAME s_scm_bytevector_to_uint_list
1049{
1050 INTEGERS_TO_LIST (unsigned);
1051}
1052#undef FUNC_NAME
1053
1054#undef INTEGER_TO_LIST
1055
1056
1057#define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
1058 SCM bv; \
1059 long c_len; \
1060 size_t c_size; \
1061 char *c_bv, *c_bv_ptr; \
1062 \
1063 SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
1064 SCM_VALIDATE_SYMBOL (2, endianness); \
1065 c_size = scm_to_uint (size); \
1066 \
1067 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
1068 scm_out_of_range (FUNC_NAME, size); \
1069 \
1070 bv = make_bytevector (c_len * c_size); \
1071 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1072 \
1073 for (c_bv_ptr = c_bv; \
1074 !scm_is_null (lst); \
1075 lst = SCM_CDR (lst), c_bv_ptr += c_size) \
1076 { \
1077 bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
1078 SCM_CAR (lst), endianness, \
1079 FUNC_NAME); \
1080 } \
1081 \
1082 return bv;
1083
1084
1085SCM_DEFINE (scm_uint_list_to_bytevector, "uint-list->bytevector",
1086 3, 0, 0,
1087 (SCM lst, SCM endianness, SCM size),
1088 "Return a bytevector containing the unsigned integers "
1089 "listed in @var{lst} and encoded on @var{size} octets "
1090 "according to @var{endianness}.")
1091#define FUNC_NAME s_scm_uint_list_to_bytevector
1092{
1093 INTEGER_LIST_TO_BYTEVECTOR (unsigned);
1094}
1095#undef FUNC_NAME
1096
1097SCM_DEFINE (scm_sint_list_to_bytevector, "sint-list->bytevector",
1098 3, 0, 0,
1099 (SCM lst, SCM endianness, SCM size),
1100 "Return a bytevector containing the signed integers "
1101 "listed in @var{lst} and encoded on @var{size} octets "
1102 "according to @var{endianness}.")
1103#define FUNC_NAME s_scm_sint_list_to_bytevector
1104{
1105 INTEGER_LIST_TO_BYTEVECTOR (signed);
1106}
1107#undef FUNC_NAME
1108
1109#undef INTEGER_LIST_TO_BYTEVECTOR
1110
1111
1112\f
1113/* Operations on 16-bit integers. */
1114
1115SCM_DEFINE (scm_bytevector_u16_ref, "bytevector-u16-ref",
1116 3, 0, 0,
1117 (SCM bv, SCM index, SCM endianness),
1118 "Return the unsigned 16-bit integer from @var{bv} at "
1119 "@var{index}.")
1120#define FUNC_NAME s_scm_bytevector_u16_ref
1121{
1122 INTEGER_REF (16, unsigned);
1123}
1124#undef FUNC_NAME
1125
1126SCM_DEFINE (scm_bytevector_s16_ref, "bytevector-s16-ref",
1127 3, 0, 0,
1128 (SCM bv, SCM index, SCM endianness),
1129 "Return the signed 16-bit integer from @var{bv} at "
1130 "@var{index}.")
1131#define FUNC_NAME s_scm_bytevector_s16_ref
1132{
1133 INTEGER_REF (16, signed);
1134}
1135#undef FUNC_NAME
1136
1137SCM_DEFINE (scm_bytevector_u16_native_ref, "bytevector-u16-native-ref",
1138 2, 0, 0,
1139 (SCM bv, SCM index),
1140 "Return the unsigned 16-bit integer from @var{bv} at "
1141 "@var{index} using the native endianness.")
1142#define FUNC_NAME s_scm_bytevector_u16_native_ref
1143{
1144 INTEGER_NATIVE_REF (16, unsigned);
1145}
1146#undef FUNC_NAME
1147
1148SCM_DEFINE (scm_bytevector_s16_native_ref, "bytevector-s16-native-ref",
1149 2, 0, 0,
1150 (SCM bv, SCM index),
1151 "Return the unsigned 16-bit integer from @var{bv} at "
1152 "@var{index} using the native endianness.")
1153#define FUNC_NAME s_scm_bytevector_s16_native_ref
1154{
1155 INTEGER_NATIVE_REF (16, signed);
1156}
1157#undef FUNC_NAME
1158
1159SCM_DEFINE (scm_bytevector_u16_set_x, "bytevector-u16-set!",
1160 4, 0, 0,
1161 (SCM bv, SCM index, SCM value, SCM endianness),
1162 "Store @var{value} in @var{bv} at @var{index} according to "
1163 "@var{endianness}.")
1164#define FUNC_NAME s_scm_bytevector_u16_set_x
1165{
1166 INTEGER_SET (16, unsigned);
1167}
1168#undef FUNC_NAME
1169
1170SCM_DEFINE (scm_bytevector_s16_set_x, "bytevector-s16-set!",
1171 4, 0, 0,
1172 (SCM bv, SCM index, SCM value, SCM endianness),
1173 "Store @var{value} in @var{bv} at @var{index} according to "
1174 "@var{endianness}.")
1175#define FUNC_NAME s_scm_bytevector_s16_set_x
1176{
1177 INTEGER_SET (16, signed);
1178}
1179#undef FUNC_NAME
1180
1181SCM_DEFINE (scm_bytevector_u16_native_set_x, "bytevector-u16-native-set!",
1182 3, 0, 0,
1183 (SCM bv, SCM index, SCM value),
1184 "Store the unsigned integer @var{value} at index @var{index} "
1185 "of @var{bv} using the native endianness.")
1186#define FUNC_NAME s_scm_bytevector_u16_native_set_x
1187{
1188 INTEGER_NATIVE_SET (16, unsigned);
1189}
1190#undef FUNC_NAME
1191
1192SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!",
1193 3, 0, 0,
1194 (SCM bv, SCM index, SCM value),
1195 "Store the signed integer @var{value} at index @var{index} "
1196 "of @var{bv} using the native endianness.")
1197#define FUNC_NAME s_scm_bytevector_s16_native_set_x
1198{
1199 INTEGER_NATIVE_SET (16, signed);
1200}
1201#undef FUNC_NAME
1202
1203
1204\f
1205/* Operations on 32-bit integers. */
1206
1207/* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
1208 arbitrary 32-bit integers. Thus we fall back to using the
1209 `large_{ref,set}' variants on 32-bit machines. */
1210
1211#define LARGE_INTEGER_REF(_len, _sign) \
1212 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1213 SCM_VALIDATE_SYMBOL (3, endianness); \
1214 \
1215 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1216 SIGNEDNESS (_sign), endianness));
1217
1218#define LARGE_INTEGER_SET(_len, _sign) \
1219 int err; \
1220 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1221 SCM_VALIDATE_SYMBOL (4, endianness); \
1222 \
1223 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1224 SIGNEDNESS (_sign), value, endianness); \
1225 if (SCM_UNLIKELY (err)) \
1226 scm_out_of_range (FUNC_NAME, value); \
1227 \
1228 return SCM_UNSPECIFIED;
1229
1230#define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
1231 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1232 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1233 SIGNEDNESS (_sign), native_endianness));
1234
1235#define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
1236 int err; \
1237 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1238 \
1239 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1240 SIGNEDNESS (_sign), value, \
1241 native_endianness); \
1242 if (SCM_UNLIKELY (err)) \
1243 scm_out_of_range (FUNC_NAME, value); \
1244 \
1245 return SCM_UNSPECIFIED;
1246
1247
1248SCM_DEFINE (scm_bytevector_u32_ref, "bytevector-u32-ref",
1249 3, 0, 0,
1250 (SCM bv, SCM index, SCM endianness),
1251 "Return the unsigned 32-bit integer from @var{bv} at "
1252 "@var{index}.")
1253#define FUNC_NAME s_scm_bytevector_u32_ref
1254{
1255#if SIZEOF_VOID_P > 4
1256 INTEGER_REF (32, unsigned);
1257#else
1258 LARGE_INTEGER_REF (32, unsigned);
1259#endif
1260}
1261#undef FUNC_NAME
1262
1263SCM_DEFINE (scm_bytevector_s32_ref, "bytevector-s32-ref",
1264 3, 0, 0,
1265 (SCM bv, SCM index, SCM endianness),
1266 "Return the signed 32-bit integer from @var{bv} at "
1267 "@var{index}.")
1268#define FUNC_NAME s_scm_bytevector_s32_ref
1269{
1270#if SIZEOF_VOID_P > 4
1271 INTEGER_REF (32, signed);
1272#else
1273 LARGE_INTEGER_REF (32, signed);
1274#endif
1275}
1276#undef FUNC_NAME
1277
1278SCM_DEFINE (scm_bytevector_u32_native_ref, "bytevector-u32-native-ref",
1279 2, 0, 0,
1280 (SCM bv, SCM index),
1281 "Return the unsigned 32-bit integer from @var{bv} at "
1282 "@var{index} using the native endianness.")
1283#define FUNC_NAME s_scm_bytevector_u32_native_ref
1284{
1285#if SIZEOF_VOID_P > 4
1286 INTEGER_NATIVE_REF (32, unsigned);
1287#else
1288 LARGE_INTEGER_NATIVE_REF (32, unsigned);
1289#endif
1290}
1291#undef FUNC_NAME
1292
1293SCM_DEFINE (scm_bytevector_s32_native_ref, "bytevector-s32-native-ref",
1294 2, 0, 0,
1295 (SCM bv, SCM index),
1296 "Return the unsigned 32-bit integer from @var{bv} at "
1297 "@var{index} using the native endianness.")
1298#define FUNC_NAME s_scm_bytevector_s32_native_ref
1299{
1300#if SIZEOF_VOID_P > 4
1301 INTEGER_NATIVE_REF (32, signed);
1302#else
1303 LARGE_INTEGER_NATIVE_REF (32, signed);
1304#endif
1305}
1306#undef FUNC_NAME
1307
1308SCM_DEFINE (scm_bytevector_u32_set_x, "bytevector-u32-set!",
1309 4, 0, 0,
1310 (SCM bv, SCM index, SCM value, SCM endianness),
1311 "Store @var{value} in @var{bv} at @var{index} according to "
1312 "@var{endianness}.")
1313#define FUNC_NAME s_scm_bytevector_u32_set_x
1314{
1315#if SIZEOF_VOID_P > 4
1316 INTEGER_SET (32, unsigned);
1317#else
1318 LARGE_INTEGER_SET (32, unsigned);
1319#endif
1320}
1321#undef FUNC_NAME
1322
1323SCM_DEFINE (scm_bytevector_s32_set_x, "bytevector-s32-set!",
1324 4, 0, 0,
1325 (SCM bv, SCM index, SCM value, SCM endianness),
1326 "Store @var{value} in @var{bv} at @var{index} according to "
1327 "@var{endianness}.")
1328#define FUNC_NAME s_scm_bytevector_s32_set_x
1329{
1330#if SIZEOF_VOID_P > 4
1331 INTEGER_SET (32, signed);
1332#else
1333 LARGE_INTEGER_SET (32, signed);
1334#endif
1335}
1336#undef FUNC_NAME
1337
1338SCM_DEFINE (scm_bytevector_u32_native_set_x, "bytevector-u32-native-set!",
1339 3, 0, 0,
1340 (SCM bv, SCM index, SCM value),
1341 "Store the unsigned integer @var{value} at index @var{index} "
1342 "of @var{bv} using the native endianness.")
1343#define FUNC_NAME s_scm_bytevector_u32_native_set_x
1344{
1345#if SIZEOF_VOID_P > 4
1346 INTEGER_NATIVE_SET (32, unsigned);
1347#else
1348 LARGE_INTEGER_NATIVE_SET (32, unsigned);
1349#endif
1350}
1351#undef FUNC_NAME
1352
1353SCM_DEFINE (scm_bytevector_s32_native_set_x, "bytevector-s32-native-set!",
1354 3, 0, 0,
1355 (SCM bv, SCM index, SCM value),
1356 "Store the signed integer @var{value} at index @var{index} "
1357 "of @var{bv} using the native endianness.")
1358#define FUNC_NAME s_scm_bytevector_s32_native_set_x
1359{
1360#if SIZEOF_VOID_P > 4
1361 INTEGER_NATIVE_SET (32, signed);
1362#else
1363 LARGE_INTEGER_NATIVE_SET (32, signed);
1364#endif
1365}
1366#undef FUNC_NAME
1367
1368
1369\f
1370/* Operations on 64-bit integers. */
1371
1372/* For 64-bit integers, we use only the `large_{ref,set}' variant. */
1373
1374SCM_DEFINE (scm_bytevector_u64_ref, "bytevector-u64-ref",
1375 3, 0, 0,
1376 (SCM bv, SCM index, SCM endianness),
1377 "Return the unsigned 64-bit integer from @var{bv} at "
1378 "@var{index}.")
1379#define FUNC_NAME s_scm_bytevector_u64_ref
1380{
1381 LARGE_INTEGER_REF (64, unsigned);
1382}
1383#undef FUNC_NAME
1384
1385SCM_DEFINE (scm_bytevector_s64_ref, "bytevector-s64-ref",
1386 3, 0, 0,
1387 (SCM bv, SCM index, SCM endianness),
1388 "Return the signed 64-bit integer from @var{bv} at "
1389 "@var{index}.")
1390#define FUNC_NAME s_scm_bytevector_s64_ref
1391{
1392 LARGE_INTEGER_REF (64, signed);
1393}
1394#undef FUNC_NAME
1395
1396SCM_DEFINE (scm_bytevector_u64_native_ref, "bytevector-u64-native-ref",
1397 2, 0, 0,
1398 (SCM bv, SCM index),
1399 "Return the unsigned 64-bit integer from @var{bv} at "
1400 "@var{index} using the native endianness.")
1401#define FUNC_NAME s_scm_bytevector_u64_native_ref
1402{
1403 LARGE_INTEGER_NATIVE_REF (64, unsigned);
1404}
1405#undef FUNC_NAME
1406
1407SCM_DEFINE (scm_bytevector_s64_native_ref, "bytevector-s64-native-ref",
1408 2, 0, 0,
1409 (SCM bv, SCM index),
1410 "Return the unsigned 64-bit integer from @var{bv} at "
1411 "@var{index} using the native endianness.")
1412#define FUNC_NAME s_scm_bytevector_s64_native_ref
1413{
1414 LARGE_INTEGER_NATIVE_REF (64, signed);
1415}
1416#undef FUNC_NAME
1417
1418SCM_DEFINE (scm_bytevector_u64_set_x, "bytevector-u64-set!",
1419 4, 0, 0,
1420 (SCM bv, SCM index, SCM value, SCM endianness),
1421 "Store @var{value} in @var{bv} at @var{index} according to "
1422 "@var{endianness}.")
1423#define FUNC_NAME s_scm_bytevector_u64_set_x
1424{
1425 LARGE_INTEGER_SET (64, unsigned);
1426}
1427#undef FUNC_NAME
1428
1429SCM_DEFINE (scm_bytevector_s64_set_x, "bytevector-s64-set!",
1430 4, 0, 0,
1431 (SCM bv, SCM index, SCM value, SCM endianness),
1432 "Store @var{value} in @var{bv} at @var{index} according to "
1433 "@var{endianness}.")
1434#define FUNC_NAME s_scm_bytevector_s64_set_x
1435{
1436 LARGE_INTEGER_SET (64, signed);
1437}
1438#undef FUNC_NAME
1439
1440SCM_DEFINE (scm_bytevector_u64_native_set_x, "bytevector-u64-native-set!",
1441 3, 0, 0,
1442 (SCM bv, SCM index, SCM value),
1443 "Store the unsigned integer @var{value} at index @var{index} "
1444 "of @var{bv} using the native endianness.")
1445#define FUNC_NAME s_scm_bytevector_u64_native_set_x
1446{
1447 LARGE_INTEGER_NATIVE_SET (64, unsigned);
1448}
1449#undef FUNC_NAME
1450
1451SCM_DEFINE (scm_bytevector_s64_native_set_x, "bytevector-s64-native-set!",
1452 3, 0, 0,
1453 (SCM bv, SCM index, SCM value),
1454 "Store the signed integer @var{value} at index @var{index} "
1455 "of @var{bv} using the native endianness.")
1456#define FUNC_NAME s_scm_bytevector_s64_native_set_x
1457{
1458 LARGE_INTEGER_NATIVE_SET (64, signed);
1459}
1460#undef FUNC_NAME
1461
1462
1463\f
1464/* Operations on IEEE-754 numbers. */
1465
1466/* There are two possible word endians, visible in glibc's <ieee754.h>.
1467 However, in R6RS, when the endianness is `little', little endian is
1468 assumed for both the byte order and the word order. This is clear from
1469 Section 2.1 of R6RS-lib (in response to
1470 http://www.r6rs.org/formal-comments/comment-187.txt). */
1471
1472
1473/* Convert to/from a floating-point number with different endianness. This
1474 method is probably not the most efficient but it should be portable. */
1475
1476static inline void
1477float_to_foreign_endianness (union scm_ieee754_float *target,
1478 float source)
1479{
1480 union scm_ieee754_float src;
1481
1482 src.f = source;
1483
1484#ifdef WORDS_BIGENDIAN
1485 /* Assuming little endian for both byte and word order. */
1486 target->little_endian.negative = src.big_endian.negative;
1487 target->little_endian.exponent = src.big_endian.exponent;
1488 target->little_endian.mantissa = src.big_endian.mantissa;
1489#else
1490 target->big_endian.negative = src.little_endian.negative;
1491 target->big_endian.exponent = src.little_endian.exponent;
1492 target->big_endian.mantissa = src.little_endian.mantissa;
1493#endif
1494}
1495
1496static inline float
1497float_from_foreign_endianness (const union scm_ieee754_float *source)
1498{
1499 union scm_ieee754_float result;
1500
1501#ifdef WORDS_BIGENDIAN
1502 /* Assuming little endian for both byte and word order. */
1503 result.big_endian.negative = source->little_endian.negative;
1504 result.big_endian.exponent = source->little_endian.exponent;
1505 result.big_endian.mantissa = source->little_endian.mantissa;
1506#else
1507 result.little_endian.negative = source->big_endian.negative;
1508 result.little_endian.exponent = source->big_endian.exponent;
1509 result.little_endian.mantissa = source->big_endian.mantissa;
1510#endif
1511
1512 return (result.f);
1513}
1514
1515static inline void
1516double_to_foreign_endianness (union scm_ieee754_double *target,
1517 double source)
1518{
1519 union scm_ieee754_double src;
1520
1521 src.d = source;
1522
1523#ifdef WORDS_BIGENDIAN
1524 /* Assuming little endian for both byte and word order. */
1525 target->little_little_endian.negative = src.big_endian.negative;
1526 target->little_little_endian.exponent = src.big_endian.exponent;
1527 target->little_little_endian.mantissa0 = src.big_endian.mantissa0;
1528 target->little_little_endian.mantissa1 = src.big_endian.mantissa1;
1529#else
1530 target->big_endian.negative = src.little_little_endian.negative;
1531 target->big_endian.exponent = src.little_little_endian.exponent;
1532 target->big_endian.mantissa0 = src.little_little_endian.mantissa0;
1533 target->big_endian.mantissa1 = src.little_little_endian.mantissa1;
1534#endif
1535}
1536
1537static inline double
1538double_from_foreign_endianness (const union scm_ieee754_double *source)
1539{
1540 union scm_ieee754_double result;
1541
1542#ifdef WORDS_BIGENDIAN
1543 /* Assuming little endian for both byte and word order. */
1544 result.big_endian.negative = source->little_little_endian.negative;
1545 result.big_endian.exponent = source->little_little_endian.exponent;
1546 result.big_endian.mantissa0 = source->little_little_endian.mantissa0;
1547 result.big_endian.mantissa1 = source->little_little_endian.mantissa1;
1548#else
1549 result.little_little_endian.negative = source->big_endian.negative;
1550 result.little_little_endian.exponent = source->big_endian.exponent;
1551 result.little_little_endian.mantissa0 = source->big_endian.mantissa0;
1552 result.little_little_endian.mantissa1 = source->big_endian.mantissa1;
1553#endif
1554
1555 return (result.d);
1556}
1557
1558/* Template macros to abstract over doubles and floats.
1559 XXX: Guile can only convert to/from doubles. */
1560#define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type
1561#define IEEE754_TO_SCM(_c_type) scm_from_double
1562#define IEEE754_FROM_SCM(_c_type) scm_to_double
1563#define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
1564 _c_type ## _from_foreign_endianness
1565#define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
1566 _c_type ## _to_foreign_endianness
1567
1568
1569/* Templace getters and setters. */
1570
1571#define IEEE754_ACCESSOR_PROLOGUE(_type) \
1572 INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
1573
1574#define IEEE754_REF(_type) \
1575 _type c_result; \
1576 \
1577 IEEE754_ACCESSOR_PROLOGUE (_type); \
1578 SCM_VALIDATE_SYMBOL (3, endianness); \
1579 \
1580 if (scm_is_eq (endianness, native_endianness)) \
1581 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1582 else \
1583 { \
1584 IEEE754_UNION (_type) c_raw; \
1585 \
1586 memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
1587 c_result = \
1588 IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
1589 } \
1590 \
1591 return (IEEE754_TO_SCM (_type) (c_result));
1592
1593#define IEEE754_NATIVE_REF(_type) \
1594 _type c_result; \
1595 \
1596 IEEE754_ACCESSOR_PROLOGUE (_type); \
1597 \
1598 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1599 return (IEEE754_TO_SCM (_type) (c_result));
1600
1601#define IEEE754_SET(_type) \
1602 _type c_value; \
1603 \
1604 IEEE754_ACCESSOR_PROLOGUE (_type); \
1605 SCM_VALIDATE_REAL (3, value); \
1606 SCM_VALIDATE_SYMBOL (4, endianness); \
1607 c_value = IEEE754_FROM_SCM (_type) (value); \
1608 \
1609 if (scm_is_eq (endianness, native_endianness)) \
1610 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1611 else \
1612 { \
1613 IEEE754_UNION (_type) c_raw; \
1614 \
1615 IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
1616 memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
1617 } \
1618 \
1619 return SCM_UNSPECIFIED;
1620
1621#define IEEE754_NATIVE_SET(_type) \
1622 _type c_value; \
1623 \
1624 IEEE754_ACCESSOR_PROLOGUE (_type); \
1625 SCM_VALIDATE_REAL (3, value); \
1626 c_value = IEEE754_FROM_SCM (_type) (value); \
1627 \
1628 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1629 return SCM_UNSPECIFIED;
1630
1631
1632/* Single precision. */
1633
1634SCM_DEFINE (scm_bytevector_ieee_single_ref,
1635 "bytevector-ieee-single-ref",
1636 3, 0, 0,
1637 (SCM bv, SCM index, SCM endianness),
1638 "Return the IEEE-754 single from @var{bv} at "
1639 "@var{index}.")
1640#define FUNC_NAME s_scm_bytevector_ieee_single_ref
1641{
1642 IEEE754_REF (float);
1643}
1644#undef FUNC_NAME
1645
1646SCM_DEFINE (scm_bytevector_ieee_single_native_ref,
1647 "bytevector-ieee-single-native-ref",
1648 2, 0, 0,
1649 (SCM bv, SCM index),
1650 "Return the IEEE-754 single from @var{bv} at "
1651 "@var{index} using the native endianness.")
1652#define FUNC_NAME s_scm_bytevector_ieee_single_native_ref
1653{
1654 IEEE754_NATIVE_REF (float);
1655}
1656#undef FUNC_NAME
1657
1658SCM_DEFINE (scm_bytevector_ieee_single_set_x,
1659 "bytevector-ieee-single-set!",
1660 4, 0, 0,
1661 (SCM bv, SCM index, SCM value, SCM endianness),
1662 "Store real @var{value} in @var{bv} at @var{index} according to "
1663 "@var{endianness}.")
1664#define FUNC_NAME s_scm_bytevector_ieee_single_set_x
1665{
1666 IEEE754_SET (float);
1667}
1668#undef FUNC_NAME
1669
1670SCM_DEFINE (scm_bytevector_ieee_single_native_set_x,
1671 "bytevector-ieee-single-native-set!",
1672 3, 0, 0,
1673 (SCM bv, SCM index, SCM value),
1674 "Store the real @var{value} at index @var{index} "
1675 "of @var{bv} using the native endianness.")
1676#define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x
1677{
1678 IEEE754_NATIVE_SET (float);
1679}
1680#undef FUNC_NAME
1681
1682
1683/* Double precision. */
1684
1685SCM_DEFINE (scm_bytevector_ieee_double_ref,
1686 "bytevector-ieee-double-ref",
1687 3, 0, 0,
1688 (SCM bv, SCM index, SCM endianness),
1689 "Return the IEEE-754 double from @var{bv} at "
1690 "@var{index}.")
1691#define FUNC_NAME s_scm_bytevector_ieee_double_ref
1692{
1693 IEEE754_REF (double);
1694}
1695#undef FUNC_NAME
1696
1697SCM_DEFINE (scm_bytevector_ieee_double_native_ref,
1698 "bytevector-ieee-double-native-ref",
1699 2, 0, 0,
1700 (SCM bv, SCM index),
1701 "Return the IEEE-754 double from @var{bv} at "
1702 "@var{index} using the native endianness.")
1703#define FUNC_NAME s_scm_bytevector_ieee_double_native_ref
1704{
1705 IEEE754_NATIVE_REF (double);
1706}
1707#undef FUNC_NAME
1708
1709SCM_DEFINE (scm_bytevector_ieee_double_set_x,
1710 "bytevector-ieee-double-set!",
1711 4, 0, 0,
1712 (SCM bv, SCM index, SCM value, SCM endianness),
1713 "Store real @var{value} in @var{bv} at @var{index} according to "
1714 "@var{endianness}.")
1715#define FUNC_NAME s_scm_bytevector_ieee_double_set_x
1716{
1717 IEEE754_SET (double);
1718}
1719#undef FUNC_NAME
1720
1721SCM_DEFINE (scm_bytevector_ieee_double_native_set_x,
1722 "bytevector-ieee-double-native-set!",
1723 3, 0, 0,
1724 (SCM bv, SCM index, SCM value),
1725 "Store the real @var{value} at index @var{index} "
1726 "of @var{bv} using the native endianness.")
1727#define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x
1728{
1729 IEEE754_NATIVE_SET (double);
1730}
1731#undef FUNC_NAME
1732
1733
1734#undef IEEE754_UNION
1735#undef IEEE754_TO_SCM
1736#undef IEEE754_FROM_SCM
1737#undef IEEE754_FROM_FOREIGN_ENDIANNESS
1738#undef IEEE754_TO_FOREIGN_ENDIANNESS
1739#undef IEEE754_REF
1740#undef IEEE754_NATIVE_REF
1741#undef IEEE754_SET
1742#undef IEEE754_NATIVE_SET
1743
1744\f
1745/* Operations on strings. */
1746
1747
1748/* Produce a function that returns the length of a UTF-encoded string. */
1749#define UTF_STRLEN_FUNCTION(_utf_width) \
1750static inline size_t \
1751utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
1752{ \
1753 size_t len = 0; \
1754 const uint ## _utf_width ## _t *ptr; \
1755 for (ptr = str; \
1756 *ptr != 0; \
1757 ptr++) \
1758 { \
1759 len++; \
1760 } \
1761 \
1762 return (len * ((_utf_width) / 8)); \
1763}
1764
1765UTF_STRLEN_FUNCTION (8)
1766
1767
1768/* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
1769#define UTF_STRLEN(_utf_width, _str) \
1770 utf ## _utf_width ## _strlen (_str)
1771
1772/* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
1773 ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
1774 encoding name). */
1775static inline void
1776utf_encoding_name (char *name, size_t utf_width, SCM endianness)
1777{
1778 strcpy (name, "UTF-");
1779 strcat (name, ((utf_width == 8)
1780 ? "8"
1781 : ((utf_width == 16)
1782 ? "16"
1783 : ((utf_width == 32)
1784 ? "32"
1785 : "??"))));
1786 strcat (name,
1787 ((scm_is_eq (endianness, scm_sym_big))
1788 ? "BE"
1789 : ((scm_is_eq (endianness, scm_sym_little))
1790 ? "LE"
1791 : "unknown")));
1792}
1793
1794/* Maximum length of a UTF encoding name. */
1795#define MAX_UTF_ENCODING_NAME_LEN 16
1796
1797/* Produce the body of a `string->utf' function. */
1798#define STRING_TO_UTF(_utf_width) \
1799 SCM utf; \
1800 int err; \
1801 char *c_str; \
1802 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1803 char *c_utf = NULL, *c_locale; \
1804 size_t c_strlen, c_raw_strlen, c_utf_len = 0; \
1805 \
1806 SCM_VALIDATE_STRING (1, str); \
1807 if (endianness == SCM_UNDEFINED) \
1808 endianness = scm_sym_big; \
1809 else \
1810 SCM_VALIDATE_SYMBOL (2, endianness); \
1811 \
1812 c_strlen = scm_c_string_length (str); \
1813 c_raw_strlen = c_strlen * ((_utf_width) / 8); \
1814 do \
1815 { \
1816 c_str = (char *) alloca (c_raw_strlen + 1); \
1817 c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \
1818 } \
1819 while (c_raw_strlen > c_strlen); \
1820 c_str[c_raw_strlen] = '\0'; \
1821 \
1822 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1823 \
1824 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1825 strcpy (c_locale, locale_charset ()); \
1826 \
1827 err = mem_iconveh (c_str, c_raw_strlen, \
1828 c_locale, c_utf_name, \
1829 iconveh_question_mark, NULL, \
1830 &c_utf, &c_utf_len); \
1831 if (SCM_UNLIKELY (err)) \
1832 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1833 scm_list_1 (str), err); \
1834 else \
1835 /* C_UTF is null-terminated. */ \
1836 utf = scm_c_take_bytevector ((signed char *) c_utf, \
1837 c_utf_len); \
1838 \
1839 return (utf);
1840
1841
1842
1843SCM_DEFINE (scm_string_to_utf8, "string->utf8",
1844 1, 0, 0,
1845 (SCM str),
1846 "Return a newly allocated bytevector that contains the UTF-8 "
1847 "encoding of @var{str}.")
1848#define FUNC_NAME s_scm_string_to_utf8
1849{
1850 SCM utf;
1851 char *c_str;
1852 uint8_t *c_utf;
1853 size_t c_strlen, c_raw_strlen;
1854
1855 SCM_VALIDATE_STRING (1, str);
1856
1857 c_strlen = scm_c_string_length (str);
1858 c_raw_strlen = c_strlen;
1859 do
1860 {
1861 c_str = (char *) alloca (c_raw_strlen + 1);
1862 c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen);
1863 }
1864 while (c_raw_strlen > c_strlen);
1865 c_str[c_raw_strlen] = '\0';
1866
1867 c_utf = u8_strconv_from_locale (c_str);
1868 if (SCM_UNLIKELY (c_utf == NULL))
1869 scm_syserror (FUNC_NAME);
1870 else
1871 /* C_UTF is null-terminated. */
1872 utf = scm_c_take_bytevector ((signed char *) c_utf,
1873 UTF_STRLEN (8, c_utf));
1874
1875 return (utf);
1876}
1877#undef FUNC_NAME
1878
1879SCM_DEFINE (scm_string_to_utf16, "string->utf16",
1880 1, 1, 0,
1881 (SCM str, SCM endianness),
1882 "Return a newly allocated bytevector that contains the UTF-16 "
1883 "encoding of @var{str}.")
1884#define FUNC_NAME s_scm_string_to_utf16
1885{
1886 STRING_TO_UTF (16);
1887}
1888#undef FUNC_NAME
1889
1890SCM_DEFINE (scm_string_to_utf32, "string->utf32",
1891 1, 1, 0,
1892 (SCM str, SCM endianness),
1893 "Return a newly allocated bytevector that contains the UTF-32 "
1894 "encoding of @var{str}.")
1895#define FUNC_NAME s_scm_string_to_utf32
1896{
1897 STRING_TO_UTF (32);
1898}
1899#undef FUNC_NAME
1900
1901
1902/* Produce the body of a function that converts a UTF-encoded bytevector to a
1903 string. */
1904#define UTF_TO_STRING(_utf_width) \
1905 SCM str = SCM_BOOL_F; \
1906 int err; \
1907 char *c_str = NULL, *c_locale; \
1908 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1909 const char *c_utf; \
1910 size_t c_strlen = 0, c_utf_len; \
1911 \
1912 SCM_VALIDATE_BYTEVECTOR (1, utf); \
1913 if (endianness == SCM_UNDEFINED) \
1914 endianness = scm_sym_big; \
1915 else \
1916 SCM_VALIDATE_SYMBOL (2, endianness); \
1917 \
1918 c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \
1919 c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
1920 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1921 \
1922 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1923 strcpy (c_locale, locale_charset ()); \
1924 \
1925 err = mem_iconveh (c_utf, c_utf_len, \
1926 c_utf_name, c_locale, \
1927 iconveh_question_mark, NULL, \
1928 &c_str, &c_strlen); \
1929 if (SCM_UNLIKELY (err)) \
1930 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
1931 scm_list_1 (utf), err); \
1932 else \
1933 /* C_STR is null-terminated. */ \
1934 str = scm_take_locale_stringn (c_str, c_strlen); \
1935 \
1936 return (str);
1937
1938
1939SCM_DEFINE (scm_utf8_to_string, "utf8->string",
1940 1, 0, 0,
1941 (SCM utf),
1942 "Return a newly allocate string that contains from the UTF-8-"
1943 "encoded contents of bytevector @var{utf}.")
1944#define FUNC_NAME s_scm_utf8_to_string
1945{
1946 SCM str;
1947 int err;
1948 char *c_str = NULL, *c_locale;
1949 const char *c_utf;
1950 size_t c_utf_len, c_strlen = 0;
1951
1952 SCM_VALIDATE_BYTEVECTOR (1, utf);
1953
1954 c_utf_len = SCM_BYTEVECTOR_LENGTH (utf);
1955
1956 c_locale = (char *) alloca (strlen (locale_charset ()) + 1);
1957 strcpy (c_locale, locale_charset ());
1958
1959 c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf);
1960 err = mem_iconveh (c_utf, c_utf_len,
1961 "UTF-8", c_locale,
1962 iconveh_question_mark, NULL,
1963 &c_str, &c_strlen);
1964 if (SCM_UNLIKELY (err))
1965 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A",
1966 scm_list_1 (utf), err);
1967 else
1968 /* C_STR is null-terminated. */
1969 str = scm_take_locale_stringn (c_str, c_strlen);
1970
1971 return (str);
1972}
1973#undef FUNC_NAME
1974
1975SCM_DEFINE (scm_utf16_to_string, "utf16->string",
1976 1, 1, 0,
1977 (SCM utf, SCM endianness),
1978 "Return a newly allocate string that contains from the UTF-16-"
1979 "encoded contents of bytevector @var{utf}.")
1980#define FUNC_NAME s_scm_utf16_to_string
1981{
1982 UTF_TO_STRING (16);
1983}
1984#undef FUNC_NAME
1985
1986SCM_DEFINE (scm_utf32_to_string, "utf32->string",
1987 1, 1, 0,
1988 (SCM utf, SCM endianness),
1989 "Return a newly allocate string that contains from the UTF-32-"
1990 "encoded contents of bytevector @var{utf}.")
1991#define FUNC_NAME s_scm_utf32_to_string
1992{
1993 UTF_TO_STRING (32);
1994}
1995#undef FUNC_NAME
1996
1997
1998\f
1999/* Initialization. */
2000
2001void
2002scm_init_bytevectors (void)
2003{
2004#include "libguile/bytevectors.x"
2005
2006#ifdef WORDS_BIGENDIAN
2007 native_endianness = scm_sym_big;
2008#else
2009 native_endianness = scm_sym_little;
2010#endif
2011
2012 scm_endianness_big = scm_sym_big;
2013 scm_endianness_little = scm_sym_little;
2014
2015 scm_null_bytevector =
2016 scm_gc_protect_object (make_bytevector_from_buffer (0, NULL));
2017}
Unnamed repository; edit this file 'description' to name the repository.