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