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