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