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