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