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