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