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