HCoop / bpt / guile.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
build: Don't include <config.h> in native programs when cross-compiling.
[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_unsigned_integer (size, 1, (size_t) -1); \
1103 \
1104 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
1105 if (SCM_UNLIKELY (c_len < c_size)) \
1106 lst = SCM_EOL; \
1107 else \
1108 { \
1109 const char *c_bv; \
1110 \
1111 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1112 \
1113 lst = scm_make_list (scm_from_size_t (c_len / c_size), \
1114 SCM_UNSPECIFIED); \
1115 for (i = 0, pair = lst; \
1116 i <= c_len - c_size; \
1117 i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
1118 { \
1119 SCM_SETCAR (pair, \
1120 bytevector_ ## _sign ## _ref (c_bv, c_size, \
1121 endianness)); \
1122 } \
1123 } \
1124 \
1125 return lst;
1126
1127 SCM_DEFINE (scm_bytevector_to_sint_list, "bytevector->sint-list",
1128 3, 0, 0,
1129 (SCM bv, SCM endianness, SCM size),
1130 "Return a list of signed integers of @var{size} octets "
1131 "representing the contents of @var{bv}.")
1132 #define FUNC_NAME s_scm_bytevector_to_sint_list
1133 {
1134 INTEGERS_TO_LIST (signed);
1135 }
1136 #undef FUNC_NAME
1137
1138 SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list",
1139 3, 0, 0,
1140 (SCM bv, SCM endianness, SCM size),
1141 "Return a list of unsigned integers of @var{size} octets "
1142 "representing the contents of @var{bv}.")
1143 #define FUNC_NAME s_scm_bytevector_to_uint_list
1144 {
1145 INTEGERS_TO_LIST (unsigned);
1146 }
1147 #undef FUNC_NAME
1148
1149 #undef INTEGER_TO_LIST
1150
1151
1152 #define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
1153 SCM bv; \
1154 long c_len; \
1155 size_t c_size; \
1156 char *c_bv, *c_bv_ptr; \
1157 \
1158 SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
1159 SCM_VALIDATE_SYMBOL (2, endianness); \
1160 c_size = scm_to_uint (size); \
1161 \
1162 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
1163 scm_out_of_range (FUNC_NAME, size); \
1164 \
1165 bv = make_bytevector (c_len * c_size, SCM_ARRAY_ELEMENT_TYPE_VU8); \
1166 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1167 \
1168 for (c_bv_ptr = c_bv; \
1169 !scm_is_null (lst); \
1170 lst = SCM_CDR (lst), c_bv_ptr += c_size) \
1171 { \
1172 bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
1173 SCM_CAR (lst), endianness, \
1174 FUNC_NAME); \
1175 } \
1176 \
1177 return bv;
1178
1179
1180 SCM_DEFINE (scm_uint_list_to_bytevector, "uint-list->bytevector",
1181 3, 0, 0,
1182 (SCM lst, SCM endianness, SCM size),
1183 "Return a bytevector containing the unsigned integers "
1184 "listed in @var{lst} and encoded on @var{size} octets "
1185 "according to @var{endianness}.")
1186 #define FUNC_NAME s_scm_uint_list_to_bytevector
1187 {
1188 INTEGER_LIST_TO_BYTEVECTOR (unsigned);
1189 }
1190 #undef FUNC_NAME
1191
1192 SCM_DEFINE (scm_sint_list_to_bytevector, "sint-list->bytevector",
1193 3, 0, 0,
1194 (SCM lst, SCM endianness, SCM size),
1195 "Return a bytevector containing the signed integers "
1196 "listed in @var{lst} and encoded on @var{size} octets "
1197 "according to @var{endianness}.")
1198 #define FUNC_NAME s_scm_sint_list_to_bytevector
1199 {
1200 INTEGER_LIST_TO_BYTEVECTOR (signed);
1201 }
1202 #undef FUNC_NAME
1203
1204 #undef INTEGER_LIST_TO_BYTEVECTOR
1205
1206
1207 \f
1208 /* Operations on 16-bit integers. */
1209
1210 SCM_DEFINE (scm_bytevector_u16_ref, "bytevector-u16-ref",
1211 3, 0, 0,
1212 (SCM bv, SCM index, SCM endianness),
1213 "Return the unsigned 16-bit integer from @var{bv} at "
1214 "@var{index}.")
1215 #define FUNC_NAME s_scm_bytevector_u16_ref
1216 {
1217 INTEGER_REF (16, unsigned);
1218 }
1219 #undef FUNC_NAME
1220
1221 SCM_DEFINE (scm_bytevector_s16_ref, "bytevector-s16-ref",
1222 3, 0, 0,
1223 (SCM bv, SCM index, SCM endianness),
1224 "Return the signed 16-bit integer from @var{bv} at "
1225 "@var{index}.")
1226 #define FUNC_NAME s_scm_bytevector_s16_ref
1227 {
1228 INTEGER_REF (16, signed);
1229 }
1230 #undef FUNC_NAME
1231
1232 SCM_DEFINE (scm_bytevector_u16_native_ref, "bytevector-u16-native-ref",
1233 2, 0, 0,
1234 (SCM bv, SCM index),
1235 "Return the unsigned 16-bit integer from @var{bv} at "
1236 "@var{index} using the native endianness.")
1237 #define FUNC_NAME s_scm_bytevector_u16_native_ref
1238 {
1239 INTEGER_NATIVE_REF (16, unsigned);
1240 }
1241 #undef FUNC_NAME
1242
1243 SCM_DEFINE (scm_bytevector_s16_native_ref, "bytevector-s16-native-ref",
1244 2, 0, 0,
1245 (SCM bv, SCM index),
1246 "Return the unsigned 16-bit integer from @var{bv} at "
1247 "@var{index} using the native endianness.")
1248 #define FUNC_NAME s_scm_bytevector_s16_native_ref
1249 {
1250 INTEGER_NATIVE_REF (16, signed);
1251 }
1252 #undef FUNC_NAME
1253
1254 SCM_DEFINE (scm_bytevector_u16_set_x, "bytevector-u16-set!",
1255 4, 0, 0,
1256 (SCM bv, SCM index, SCM value, SCM endianness),
1257 "Store @var{value} in @var{bv} at @var{index} according to "
1258 "@var{endianness}.")
1259 #define FUNC_NAME s_scm_bytevector_u16_set_x
1260 {
1261 INTEGER_SET (16, unsigned);
1262 }
1263 #undef FUNC_NAME
1264
1265 SCM_DEFINE (scm_bytevector_s16_set_x, "bytevector-s16-set!",
1266 4, 0, 0,
1267 (SCM bv, SCM index, SCM value, SCM endianness),
1268 "Store @var{value} in @var{bv} at @var{index} according to "
1269 "@var{endianness}.")
1270 #define FUNC_NAME s_scm_bytevector_s16_set_x
1271 {
1272 INTEGER_SET (16, signed);
1273 }
1274 #undef FUNC_NAME
1275
1276 SCM_DEFINE (scm_bytevector_u16_native_set_x, "bytevector-u16-native-set!",
1277 3, 0, 0,
1278 (SCM bv, SCM index, SCM value),
1279 "Store the unsigned integer @var{value} at index @var{index} "
1280 "of @var{bv} using the native endianness.")
1281 #define FUNC_NAME s_scm_bytevector_u16_native_set_x
1282 {
1283 INTEGER_NATIVE_SET (16, unsigned);
1284 }
1285 #undef FUNC_NAME
1286
1287 SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!",
1288 3, 0, 0,
1289 (SCM bv, SCM index, SCM value),
1290 "Store the signed integer @var{value} at index @var{index} "
1291 "of @var{bv} using the native endianness.")
1292 #define FUNC_NAME s_scm_bytevector_s16_native_set_x
1293 {
1294 INTEGER_NATIVE_SET (16, signed);
1295 }
1296 #undef FUNC_NAME
1297
1298
1299 \f
1300 /* Operations on 32-bit integers. */
1301
1302 /* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
1303 arbitrary 32-bit integers. Thus we fall back to using the
1304 `large_{ref,set}' variants on 32-bit machines. */
1305
1306 #define LARGE_INTEGER_REF(_len, _sign) \
1307 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1308 SCM_VALIDATE_SYMBOL (3, endianness); \
1309 \
1310 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1311 SIGNEDNESS (_sign), endianness));
1312
1313 #define LARGE_INTEGER_SET(_len, _sign) \
1314 int err; \
1315 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1316 SCM_VALIDATE_SYMBOL (4, endianness); \
1317 \
1318 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1319 SIGNEDNESS (_sign), value, endianness); \
1320 if (SCM_UNLIKELY (err)) \
1321 scm_out_of_range (FUNC_NAME, value); \
1322 \
1323 return SCM_UNSPECIFIED;
1324
1325 #define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
1326 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1327 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1328 SIGNEDNESS (_sign), scm_i_native_endianness));
1329
1330 #define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
1331 int err; \
1332 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1333 \
1334 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1335 SIGNEDNESS (_sign), value, \
1336 scm_i_native_endianness); \
1337 if (SCM_UNLIKELY (err)) \
1338 scm_out_of_range (FUNC_NAME, value); \
1339 \
1340 return SCM_UNSPECIFIED;
1341
1342
1343 SCM_DEFINE (scm_bytevector_u32_ref, "bytevector-u32-ref",
1344 3, 0, 0,
1345 (SCM bv, SCM index, SCM endianness),
1346 "Return the unsigned 32-bit integer from @var{bv} at "
1347 "@var{index}.")
1348 #define FUNC_NAME s_scm_bytevector_u32_ref
1349 {
1350 #if SIZEOF_VOID_P > 4
1351 INTEGER_REF (32, unsigned);
1352 #else
1353 LARGE_INTEGER_REF (32, unsigned);
1354 #endif
1355 }
1356 #undef FUNC_NAME
1357
1358 SCM_DEFINE (scm_bytevector_s32_ref, "bytevector-s32-ref",
1359 3, 0, 0,
1360 (SCM bv, SCM index, SCM endianness),
1361 "Return the signed 32-bit integer from @var{bv} at "
1362 "@var{index}.")
1363 #define FUNC_NAME s_scm_bytevector_s32_ref
1364 {
1365 #if SIZEOF_VOID_P > 4
1366 INTEGER_REF (32, signed);
1367 #else
1368 LARGE_INTEGER_REF (32, signed);
1369 #endif
1370 }
1371 #undef FUNC_NAME
1372
1373 SCM_DEFINE (scm_bytevector_u32_native_ref, "bytevector-u32-native-ref",
1374 2, 0, 0,
1375 (SCM bv, SCM index),
1376 "Return the unsigned 32-bit integer from @var{bv} at "
1377 "@var{index} using the native endianness.")
1378 #define FUNC_NAME s_scm_bytevector_u32_native_ref
1379 {
1380 #if SIZEOF_VOID_P > 4
1381 INTEGER_NATIVE_REF (32, unsigned);
1382 #else
1383 LARGE_INTEGER_NATIVE_REF (32, unsigned);
1384 #endif
1385 }
1386 #undef FUNC_NAME
1387
1388 SCM_DEFINE (scm_bytevector_s32_native_ref, "bytevector-s32-native-ref",
1389 2, 0, 0,
1390 (SCM bv, SCM index),
1391 "Return the unsigned 32-bit integer from @var{bv} at "
1392 "@var{index} using the native endianness.")
1393 #define FUNC_NAME s_scm_bytevector_s32_native_ref
1394 {
1395 #if SIZEOF_VOID_P > 4
1396 INTEGER_NATIVE_REF (32, signed);
1397 #else
1398 LARGE_INTEGER_NATIVE_REF (32, signed);
1399 #endif
1400 }
1401 #undef FUNC_NAME
1402
1403 SCM_DEFINE (scm_bytevector_u32_set_x, "bytevector-u32-set!",
1404 4, 0, 0,
1405 (SCM bv, SCM index, SCM value, SCM endianness),
1406 "Store @var{value} in @var{bv} at @var{index} according to "
1407 "@var{endianness}.")
1408 #define FUNC_NAME s_scm_bytevector_u32_set_x
1409 {
1410 #if SIZEOF_VOID_P > 4
1411 INTEGER_SET (32, unsigned);
1412 #else
1413 LARGE_INTEGER_SET (32, unsigned);
1414 #endif
1415 }
1416 #undef FUNC_NAME
1417
1418 SCM_DEFINE (scm_bytevector_s32_set_x, "bytevector-s32-set!",
1419 4, 0, 0,
1420 (SCM bv, SCM index, SCM value, SCM endianness),
1421 "Store @var{value} in @var{bv} at @var{index} according to "
1422 "@var{endianness}.")
1423 #define FUNC_NAME s_scm_bytevector_s32_set_x
1424 {
1425 #if SIZEOF_VOID_P > 4
1426 INTEGER_SET (32, signed);
1427 #else
1428 LARGE_INTEGER_SET (32, signed);
1429 #endif
1430 }
1431 #undef FUNC_NAME
1432
1433 SCM_DEFINE (scm_bytevector_u32_native_set_x, "bytevector-u32-native-set!",
1434 3, 0, 0,
1435 (SCM bv, SCM index, SCM value),
1436 "Store the unsigned integer @var{value} at index @var{index} "
1437 "of @var{bv} using the native endianness.")
1438 #define FUNC_NAME s_scm_bytevector_u32_native_set_x
1439 {
1440 #if SIZEOF_VOID_P > 4
1441 INTEGER_NATIVE_SET (32, unsigned);
1442 #else
1443 LARGE_INTEGER_NATIVE_SET (32, unsigned);
1444 #endif
1445 }
1446 #undef FUNC_NAME
1447
1448 SCM_DEFINE (scm_bytevector_s32_native_set_x, "bytevector-s32-native-set!",
1449 3, 0, 0,
1450 (SCM bv, SCM index, SCM value),
1451 "Store the signed integer @var{value} at index @var{index} "
1452 "of @var{bv} using the native endianness.")
1453 #define FUNC_NAME s_scm_bytevector_s32_native_set_x
1454 {
1455 #if SIZEOF_VOID_P > 4
1456 INTEGER_NATIVE_SET (32, signed);
1457 #else
1458 LARGE_INTEGER_NATIVE_SET (32, signed);
1459 #endif
1460 }
1461 #undef FUNC_NAME
1462
1463
1464 \f
1465 /* Operations on 64-bit integers. */
1466
1467 /* For 64-bit integers, we use only the `large_{ref,set}' variant. */
1468
1469 SCM_DEFINE (scm_bytevector_u64_ref, "bytevector-u64-ref",
1470 3, 0, 0,
1471 (SCM bv, SCM index, SCM endianness),
1472 "Return the unsigned 64-bit integer from @var{bv} at "
1473 "@var{index}.")
1474 #define FUNC_NAME s_scm_bytevector_u64_ref
1475 {
1476 LARGE_INTEGER_REF (64, unsigned);
1477 }
1478 #undef FUNC_NAME
1479
1480 SCM_DEFINE (scm_bytevector_s64_ref, "bytevector-s64-ref",
1481 3, 0, 0,
1482 (SCM bv, SCM index, SCM endianness),
1483 "Return the signed 64-bit integer from @var{bv} at "
1484 "@var{index}.")
1485 #define FUNC_NAME s_scm_bytevector_s64_ref
1486 {
1487 LARGE_INTEGER_REF (64, signed);
1488 }
1489 #undef FUNC_NAME
1490
1491 SCM_DEFINE (scm_bytevector_u64_native_ref, "bytevector-u64-native-ref",
1492 2, 0, 0,
1493 (SCM bv, SCM index),
1494 "Return the unsigned 64-bit integer from @var{bv} at "
1495 "@var{index} using the native endianness.")
1496 #define FUNC_NAME s_scm_bytevector_u64_native_ref
1497 {
1498 LARGE_INTEGER_NATIVE_REF (64, unsigned);
1499 }
1500 #undef FUNC_NAME
1501
1502 SCM_DEFINE (scm_bytevector_s64_native_ref, "bytevector-s64-native-ref",
1503 2, 0, 0,
1504 (SCM bv, SCM index),
1505 "Return the unsigned 64-bit integer from @var{bv} at "
1506 "@var{index} using the native endianness.")
1507 #define FUNC_NAME s_scm_bytevector_s64_native_ref
1508 {
1509 LARGE_INTEGER_NATIVE_REF (64, signed);
1510 }
1511 #undef FUNC_NAME
1512
1513 SCM_DEFINE (scm_bytevector_u64_set_x, "bytevector-u64-set!",
1514 4, 0, 0,
1515 (SCM bv, SCM index, SCM value, SCM endianness),
1516 "Store @var{value} in @var{bv} at @var{index} according to "
1517 "@var{endianness}.")
1518 #define FUNC_NAME s_scm_bytevector_u64_set_x
1519 {
1520 LARGE_INTEGER_SET (64, unsigned);
1521 }
1522 #undef FUNC_NAME
1523
1524 SCM_DEFINE (scm_bytevector_s64_set_x, "bytevector-s64-set!",
1525 4, 0, 0,
1526 (SCM bv, SCM index, SCM value, SCM endianness),
1527 "Store @var{value} in @var{bv} at @var{index} according to "
1528 "@var{endianness}.")
1529 #define FUNC_NAME s_scm_bytevector_s64_set_x
1530 {
1531 LARGE_INTEGER_SET (64, signed);
1532 }
1533 #undef FUNC_NAME
1534
1535 SCM_DEFINE (scm_bytevector_u64_native_set_x, "bytevector-u64-native-set!",
1536 3, 0, 0,
1537 (SCM bv, SCM index, SCM value),
1538 "Store the unsigned integer @var{value} at index @var{index} "
1539 "of @var{bv} using the native endianness.")
1540 #define FUNC_NAME s_scm_bytevector_u64_native_set_x
1541 {
1542 LARGE_INTEGER_NATIVE_SET (64, unsigned);
1543 }
1544 #undef FUNC_NAME
1545
1546 SCM_DEFINE (scm_bytevector_s64_native_set_x, "bytevector-s64-native-set!",
1547 3, 0, 0,
1548 (SCM bv, SCM index, SCM value),
1549 "Store the signed integer @var{value} at index @var{index} "
1550 "of @var{bv} using the native endianness.")
1551 #define FUNC_NAME s_scm_bytevector_s64_native_set_x
1552 {
1553 LARGE_INTEGER_NATIVE_SET (64, signed);
1554 }
1555 #undef FUNC_NAME
1556
1557
1558 \f
1559 /* Operations on IEEE-754 numbers. */
1560
1561 /* There are two possible word endians, visible in glibc's <ieee754.h>.
1562 However, in R6RS, when the endianness is `little', little endian is
1563 assumed for both the byte order and the word order. This is clear from
1564 Section 2.1 of R6RS-lib (in response to
1565 http://www.r6rs.org/formal-comments/comment-187.txt). */
1566
1567 union scm_ieee754_float
1568 {
1569 float f;
1570 scm_t_uint32 i;
1571 };
1572
1573 union scm_ieee754_double
1574 {
1575 double d;
1576 scm_t_uint64 i;
1577 };
1578
1579
1580 /* Convert to/from a floating-point number with different endianness. This
1581 method is probably not the most efficient but it should be portable. */
1582
1583 static inline void
1584 float_to_foreign_endianness (union scm_ieee754_float *target,
1585 float source)
1586 {
1587 union scm_ieee754_float input;
1588
1589 input.f = source;
1590 target->i = bswap_32 (input.i);
1591 }
1592
1593 static inline float
1594 float_from_foreign_endianness (const union scm_ieee754_float *source)
1595 {
1596 union scm_ieee754_float result;
1597
1598 result.i = bswap_32 (source->i);
1599
1600 return (result.f);
1601 }
1602
1603 static inline void
1604 double_to_foreign_endianness (union scm_ieee754_double *target,
1605 double source)
1606 {
1607 union scm_ieee754_double input;
1608
1609 input.d = source;
1610 target->i = bswap_64 (input.i);
1611 }
1612
1613 static inline double
1614 double_from_foreign_endianness (const union scm_ieee754_double *source)
1615 {
1616 union scm_ieee754_double result;
1617
1618 result.i = bswap_64 (source->i);
1619
1620 return (result.d);
1621 }
1622
1623 /* Template macros to abstract over doubles and floats.
1624 XXX: Guile can only convert to/from doubles. */
1625 #define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type
1626 #define IEEE754_TO_SCM(_c_type) scm_from_double
1627 #define IEEE754_FROM_SCM(_c_type) scm_to_double
1628 #define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
1629 _c_type ## _from_foreign_endianness
1630 #define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
1631 _c_type ## _to_foreign_endianness
1632
1633
1634 /* FIXME: SCM_VALIDATE_REAL rejects integers, etc. grrr */
1635 #define VALIDATE_REAL(pos, v) \
1636 do { \
1637 SCM_ASSERT_TYPE (scm_is_real (v), v, pos, FUNC_NAME, "real"); \
1638 } while (0)
1639
1640 /* Templace getters and setters. */
1641
1642 #define IEEE754_ACCESSOR_PROLOGUE(_type) \
1643 INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
1644
1645 #define IEEE754_REF(_type) \
1646 _type c_result; \
1647 \
1648 IEEE754_ACCESSOR_PROLOGUE (_type); \
1649 SCM_VALIDATE_SYMBOL (3, endianness); \
1650 \
1651 if (scm_is_eq (endianness, scm_i_native_endianness)) \
1652 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1653 else \
1654 { \
1655 IEEE754_UNION (_type) c_raw; \
1656 \
1657 memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
1658 c_result = \
1659 IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
1660 } \
1661 \
1662 return (IEEE754_TO_SCM (_type) (c_result));
1663
1664 #define IEEE754_NATIVE_REF(_type) \
1665 _type c_result; \
1666 \
1667 IEEE754_ACCESSOR_PROLOGUE (_type); \
1668 \
1669 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1670 return (IEEE754_TO_SCM (_type) (c_result));
1671
1672 #define IEEE754_SET(_type) \
1673 _type c_value; \
1674 \
1675 IEEE754_ACCESSOR_PROLOGUE (_type); \
1676 VALIDATE_REAL (3, value); \
1677 SCM_VALIDATE_SYMBOL (4, endianness); \
1678 c_value = IEEE754_FROM_SCM (_type) (value); \
1679 \
1680 if (scm_is_eq (endianness, scm_i_native_endianness)) \
1681 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1682 else \
1683 { \
1684 IEEE754_UNION (_type) c_raw; \
1685 \
1686 IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
1687 memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
1688 } \
1689 \
1690 return SCM_UNSPECIFIED;
1691
1692 #define IEEE754_NATIVE_SET(_type) \
1693 _type c_value; \
1694 \
1695 IEEE754_ACCESSOR_PROLOGUE (_type); \
1696 VALIDATE_REAL (3, value); \
1697 c_value = IEEE754_FROM_SCM (_type) (value); \
1698 \
1699 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1700 return SCM_UNSPECIFIED;
1701
1702
1703 /* Single precision. */
1704
1705 SCM_DEFINE (scm_bytevector_ieee_single_ref,
1706 "bytevector-ieee-single-ref",
1707 3, 0, 0,
1708 (SCM bv, SCM index, SCM endianness),
1709 "Return the IEEE-754 single from @var{bv} at "
1710 "@var{index}.")
1711 #define FUNC_NAME s_scm_bytevector_ieee_single_ref
1712 {
1713 IEEE754_REF (float);
1714 }
1715 #undef FUNC_NAME
1716
1717 SCM_DEFINE (scm_bytevector_ieee_single_native_ref,
1718 "bytevector-ieee-single-native-ref",
1719 2, 0, 0,
1720 (SCM bv, SCM index),
1721 "Return the IEEE-754 single from @var{bv} at "
1722 "@var{index} using the native endianness.")
1723 #define FUNC_NAME s_scm_bytevector_ieee_single_native_ref
1724 {
1725 IEEE754_NATIVE_REF (float);
1726 }
1727 #undef FUNC_NAME
1728
1729 SCM_DEFINE (scm_bytevector_ieee_single_set_x,
1730 "bytevector-ieee-single-set!",
1731 4, 0, 0,
1732 (SCM bv, SCM index, SCM value, SCM endianness),
1733 "Store real @var{value} in @var{bv} at @var{index} according to "
1734 "@var{endianness}.")
1735 #define FUNC_NAME s_scm_bytevector_ieee_single_set_x
1736 {
1737 IEEE754_SET (float);
1738 }
1739 #undef FUNC_NAME
1740
1741 SCM_DEFINE (scm_bytevector_ieee_single_native_set_x,
1742 "bytevector-ieee-single-native-set!",
1743 3, 0, 0,
1744 (SCM bv, SCM index, SCM value),
1745 "Store the real @var{value} at index @var{index} "
1746 "of @var{bv} using the native endianness.")
1747 #define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x
1748 {
1749 IEEE754_NATIVE_SET (float);
1750 }
1751 #undef FUNC_NAME
1752
1753
1754 /* Double precision. */
1755
1756 SCM_DEFINE (scm_bytevector_ieee_double_ref,
1757 "bytevector-ieee-double-ref",
1758 3, 0, 0,
1759 (SCM bv, SCM index, SCM endianness),
1760 "Return the IEEE-754 double from @var{bv} at "
1761 "@var{index}.")
1762 #define FUNC_NAME s_scm_bytevector_ieee_double_ref
1763 {
1764 IEEE754_REF (double);
1765 }
1766 #undef FUNC_NAME
1767
1768 SCM_DEFINE (scm_bytevector_ieee_double_native_ref,
1769 "bytevector-ieee-double-native-ref",
1770 2, 0, 0,
1771 (SCM bv, SCM index),
1772 "Return the IEEE-754 double from @var{bv} at "
1773 "@var{index} using the native endianness.")
1774 #define FUNC_NAME s_scm_bytevector_ieee_double_native_ref
1775 {
1776 IEEE754_NATIVE_REF (double);
1777 }
1778 #undef FUNC_NAME
1779
1780 SCM_DEFINE (scm_bytevector_ieee_double_set_x,
1781 "bytevector-ieee-double-set!",
1782 4, 0, 0,
1783 (SCM bv, SCM index, SCM value, SCM endianness),
1784 "Store real @var{value} in @var{bv} at @var{index} according to "
1785 "@var{endianness}.")
1786 #define FUNC_NAME s_scm_bytevector_ieee_double_set_x
1787 {
1788 IEEE754_SET (double);
1789 }
1790 #undef FUNC_NAME
1791
1792 SCM_DEFINE (scm_bytevector_ieee_double_native_set_x,
1793 "bytevector-ieee-double-native-set!",
1794 3, 0, 0,
1795 (SCM bv, SCM index, SCM value),
1796 "Store the real @var{value} at index @var{index} "
1797 "of @var{bv} using the native endianness.")
1798 #define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x
1799 {
1800 IEEE754_NATIVE_SET (double);
1801 }
1802 #undef FUNC_NAME
1803
1804
1805 #undef IEEE754_UNION
1806 #undef IEEE754_TO_SCM
1807 #undef IEEE754_FROM_SCM
1808 #undef IEEE754_FROM_FOREIGN_ENDIANNESS
1809 #undef IEEE754_TO_FOREIGN_ENDIANNESS
1810 #undef IEEE754_REF
1811 #undef IEEE754_NATIVE_REF
1812 #undef IEEE754_SET
1813 #undef IEEE754_NATIVE_SET
1814
1815 \f
1816 /* Operations on strings. */
1817
1818
1819 /* Produce a function that returns the length of a UTF-encoded string. */
1820 #define UTF_STRLEN_FUNCTION(_utf_width) \
1821 static inline size_t \
1822 utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
1823 { \
1824 size_t len = 0; \
1825 const uint ## _utf_width ## _t *ptr; \
1826 for (ptr = str; \
1827 *ptr != 0; \
1828 ptr++) \
1829 { \
1830 len++; \
1831 } \
1832 \
1833 return (len * ((_utf_width) / 8)); \
1834 }
1835
1836 UTF_STRLEN_FUNCTION (8)
1837
1838
1839 /* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
1840 #define UTF_STRLEN(_utf_width, _str) \
1841 utf ## _utf_width ## _strlen (_str)
1842
1843 /* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
1844 ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
1845 encoding name). */
1846 static inline void
1847 utf_encoding_name (char *name, size_t utf_width, SCM endianness)
1848 {
1849 strcpy (name, "UTF-");
1850 strcat (name, ((utf_width == 8)
1851 ? "8"
1852 : ((utf_width == 16)
1853 ? "16"
1854 : ((utf_width == 32)
1855 ? "32"
1856 : "??"))));
1857 strcat (name,
1858 ((scm_is_eq (endianness, scm_sym_big))
1859 ? "BE"
1860 : ((scm_is_eq (endianness, scm_sym_little))
1861 ? "LE"
1862 : "unknown")));
1863 }
1864
1865 /* Maximum length of a UTF encoding name. */
1866 #define MAX_UTF_ENCODING_NAME_LEN 16
1867
1868 /* Produce the body of a `string->utf' function. */
1869 #define STRING_TO_UTF(_utf_width) \
1870 SCM utf; \
1871 int err; \
1872 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1873 char *c_utf = NULL; \
1874 size_t c_strlen, c_utf_len = 0; \
1875 \
1876 SCM_VALIDATE_STRING (1, str); \
1877 if (scm_is_eq (endianness, SCM_UNDEFINED)) \
1878 endianness = scm_sym_big; \
1879 else \
1880 SCM_VALIDATE_SYMBOL (2, endianness); \
1881 \
1882 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1883 \
1884 c_strlen = scm_i_string_length (str); \
1885 if (scm_i_is_narrow_string (str)) \
1886 { \
1887 err = mem_iconveh (scm_i_string_chars (str), c_strlen, \
1888 "ISO-8859-1", c_utf_name, \
1889 iconveh_question_mark, NULL, \
1890 &c_utf, &c_utf_len); \
1891 if (SCM_UNLIKELY (err)) \
1892 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1893 scm_list_1 (str), err); \
1894 } \
1895 else \
1896 { \
1897 const scm_t_wchar *wbuf = scm_i_string_wide_chars (str); \
1898 c_utf = u32_conv_to_encoding (c_utf_name, \
1899 iconveh_question_mark, \
1900 (scm_t_uint32 *) wbuf, \
1901 c_strlen, NULL, NULL, &c_utf_len); \
1902 if (SCM_UNLIKELY (c_utf == NULL)) \
1903 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1904 scm_list_1 (str), errno); \
1905 } \
1906 scm_dynwind_begin (0); \
1907 scm_dynwind_free (c_utf); \
1908 utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8); \
1909 memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len); \
1910 scm_dynwind_end (); \
1911 \
1912 return (utf);
1913
1914
1915
1916 SCM_DEFINE (scm_string_to_utf8, "string->utf8",
1917 1, 0, 0,
1918 (SCM str),
1919 "Return a newly allocated bytevector that contains the UTF-8 "
1920 "encoding of @var{str}.")
1921 #define FUNC_NAME s_scm_string_to_utf8
1922 {
1923 SCM utf;
1924 scm_t_uint8 *c_utf;
1925 size_t c_utf_len = 0;
1926
1927 SCM_VALIDATE_STRING (1, str);
1928
1929 c_utf = (scm_t_uint8 *) scm_to_utf8_stringn (str, &c_utf_len);
1930 utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
1931 memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len);
1932 free (c_utf);
1933
1934 return (utf);
1935 }
1936 #undef FUNC_NAME
1937
1938 SCM_DEFINE (scm_string_to_utf16, "string->utf16",
1939 1, 1, 0,
1940 (SCM str, SCM endianness),
1941 "Return a newly allocated bytevector that contains the UTF-16 "
1942 "encoding of @var{str}.")
1943 #define FUNC_NAME s_scm_string_to_utf16
1944 {
1945 STRING_TO_UTF (16);
1946 }
1947 #undef FUNC_NAME
1948
1949 static void
1950 swap_u32 (scm_t_wchar *vals, size_t len)
1951 {
1952 size_t n;
1953 for (n = 0; n < len; n++)
1954 vals[n] = bswap_32 (vals[n]);
1955 }
1956
1957 SCM_DEFINE (scm_string_to_utf32, "string->utf32",
1958 1, 1, 0,
1959 (SCM str, SCM endianness),
1960 "Return a newly allocated bytevector that contains the UTF-32 "
1961 "encoding of @var{str}.")
1962 #define FUNC_NAME s_scm_string_to_utf32
1963 {
1964 SCM bv;
1965 scm_t_wchar *wchars;
1966 size_t wchar_len, bytes_len;
1967
1968 wchars = scm_to_utf32_stringn (str, &wchar_len);
1969 bytes_len = wchar_len * sizeof (scm_t_wchar);
1970 if (!scm_is_eq (SCM_UNBNDP (endianness) ? scm_endianness_big : endianness,
1971 scm_i_native_endianness))
1972 swap_u32 (wchars, wchar_len);
1973
1974 bv = make_bytevector (bytes_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
1975 memcpy (SCM_BYTEVECTOR_CONTENTS (bv), wchars, bytes_len);
1976 free (wchars);
1977
1978 return bv;
1979 }
1980 #undef FUNC_NAME
1981
1982
1983 /* Produce the body of a function that converts a UTF-encoded bytevector to a
1984 string. */
1985 #define UTF_TO_STRING(_utf_width) \
1986 SCM str = SCM_BOOL_F; \
1987 int err; \
1988 char *c_str = NULL; \
1989 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1990 char *c_utf; \
1991 size_t c_strlen = 0, c_utf_len = 0; \
1992 \
1993 SCM_VALIDATE_BYTEVECTOR (1, utf); \
1994 if (scm_is_eq (endianness, SCM_UNDEFINED)) \
1995 endianness = scm_sym_big; \
1996 else \
1997 SCM_VALIDATE_SYMBOL (2, endianness); \
1998 \
1999 c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \
2000 c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
2001 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
2002 \
2003 err = mem_iconveh (c_utf, c_utf_len, \
2004 c_utf_name, "UTF-8", \
2005 iconveh_question_mark, NULL, \
2006 &c_str, &c_strlen); \
2007 if (SCM_UNLIKELY (err)) \
2008 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
2009 scm_list_1 (utf), err); \
2010 else \
2011 { \
2012 str = scm_from_stringn (c_str, c_strlen, "UTF-8", \
2013 SCM_FAILED_CONVERSION_ERROR); \
2014 free (c_str); \
2015 } \
2016 return (str);
2017
2018
2019 SCM_DEFINE (scm_utf8_to_string, "utf8->string",
2020 1, 0, 0,
2021 (SCM utf),
2022 "Return a newly allocate string that contains from the UTF-8-"
2023 "encoded contents of bytevector @var{utf}.")
2024 #define FUNC_NAME s_scm_utf8_to_string
2025 {
2026 SCM str;
2027 const char *c_utf;
2028 size_t c_utf_len = 0;
2029
2030 SCM_VALIDATE_BYTEVECTOR (1, utf);
2031
2032 c_utf_len = SCM_BYTEVECTOR_LENGTH (utf);
2033 c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf);
2034 str = scm_from_stringn (c_utf, c_utf_len, "UTF-8",
2035 SCM_FAILED_CONVERSION_ERROR);
2036
2037 return (str);
2038 }
2039 #undef FUNC_NAME
2040
2041 SCM_DEFINE (scm_utf16_to_string, "utf16->string",
2042 1, 1, 0,
2043 (SCM utf, SCM endianness),
2044 "Return a newly allocate string that contains from the UTF-16-"
2045 "encoded contents of bytevector @var{utf}.")
2046 #define FUNC_NAME s_scm_utf16_to_string
2047 {
2048 UTF_TO_STRING (16);
2049 }
2050 #undef FUNC_NAME
2051
2052 SCM_DEFINE (scm_utf32_to_string, "utf32->string",
2053 1, 1, 0,
2054 (SCM utf, SCM endianness),
2055 "Return a newly allocate string that contains from the UTF-32-"
2056 "encoded contents of bytevector @var{utf}.")
2057 #define FUNC_NAME s_scm_utf32_to_string
2058 {
2059 UTF_TO_STRING (32);
2060 }
2061 #undef FUNC_NAME
2062
2063 \f
2064 /* Bytevectors as generalized vectors & arrays. */
2065
2066 #define COMPLEX_ACCESSOR_PROLOGUE(_type) \
2067 size_t c_len, c_index; \
2068 char *c_bv; \
2069 \
2070 SCM_VALIDATE_BYTEVECTOR (1, bv); \
2071 c_index = scm_to_size_t (index); \
2072 \
2073 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
2074 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
2075 \
2076 if (SCM_UNLIKELY (c_index + 2 * sizeof (_type) - 1 >= c_len)) \
2077 scm_out_of_range (FUNC_NAME, index);
2078
2079 /* Template for native access to complex numbers of type TYPE. */
2080 #define COMPLEX_NATIVE_REF(_type) \
2081 SCM result; \
2082 \
2083 COMPLEX_ACCESSOR_PROLOGUE (_type); \
2084 \
2085 { \
2086 _type real, imag; \
2087 \
2088 memcpy (&real, &c_bv[c_index], sizeof (_type)); \
2089 memcpy (&imag, &c_bv[c_index + sizeof (_type)], sizeof (_type)); \
2090 \
2091 result = scm_c_make_rectangular (real, imag); \
2092 } \
2093 \
2094 return result;
2095
2096 static SCM
2097 bytevector_ref_c32 (SCM bv, SCM index)
2098 #define FUNC_NAME "bytevector_ref_c32"
2099 {
2100 COMPLEX_NATIVE_REF (float);
2101 }
2102 #undef FUNC_NAME
2103
2104 static SCM
2105 bytevector_ref_c64 (SCM bv, SCM index)
2106 #define FUNC_NAME "bytevector_ref_c64"
2107 {
2108 COMPLEX_NATIVE_REF (double);
2109 }
2110 #undef FUNC_NAME
2111
2112 typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM);
2113
2114 static const scm_t_bytevector_ref_fn
2115 bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
2116 {
2117 NULL, /* SCM */
2118 NULL, /* CHAR */
2119 NULL, /* BIT */
2120 scm_bytevector_u8_ref, /* VU8 */
2121 scm_bytevector_u8_ref, /* U8 */
2122 scm_bytevector_s8_ref,
2123 scm_bytevector_u16_native_ref,
2124 scm_bytevector_s16_native_ref,
2125 scm_bytevector_u32_native_ref,
2126 scm_bytevector_s32_native_ref,
2127 scm_bytevector_u64_native_ref,
2128 scm_bytevector_s64_native_ref,
2129 scm_bytevector_ieee_single_native_ref,
2130 scm_bytevector_ieee_double_native_ref,
2131 bytevector_ref_c32,
2132 bytevector_ref_c64
2133 };
2134
2135 static SCM
2136 bv_handle_ref (scm_t_array_handle *h, size_t index)
2137 {
2138 SCM byte_index;
2139 scm_t_bytevector_ref_fn ref_fn;
2140
2141 ref_fn = bytevector_ref_fns[h->element_type];
2142 byte_index =
2143 scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
2144 return ref_fn (h->array, byte_index);
2145 }
2146
2147 /* Template for native modification of complex numbers of type TYPE. */
2148 #define COMPLEX_NATIVE_SET(_type) \
2149 COMPLEX_ACCESSOR_PROLOGUE (_type); \
2150 \
2151 { \
2152 _type real, imag; \
2153 real = scm_c_real_part (value); \
2154 imag = scm_c_imag_part (value); \
2155 \
2156 memcpy (&c_bv[c_index], &real, sizeof (_type)); \
2157 memcpy (&c_bv[c_index + sizeof (_type)], &imag, sizeof (_type)); \
2158 } \
2159 \
2160 return SCM_UNSPECIFIED;
2161
2162 static SCM
2163 bytevector_set_c32 (SCM bv, SCM index, SCM value)
2164 #define FUNC_NAME "bytevector_set_c32"
2165 {
2166 COMPLEX_NATIVE_SET (float);
2167 }
2168 #undef FUNC_NAME
2169
2170 static SCM
2171 bytevector_set_c64 (SCM bv, SCM index, SCM value)
2172 #define FUNC_NAME "bytevector_set_c64"
2173 {
2174 COMPLEX_NATIVE_SET (double);
2175 }
2176 #undef FUNC_NAME
2177
2178 typedef SCM (*scm_t_bytevector_set_fn)(SCM, SCM, SCM);
2179
2180 const scm_t_bytevector_set_fn bytevector_set_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
2181 {
2182 NULL, /* SCM */
2183 NULL, /* CHAR */
2184 NULL, /* BIT */
2185 scm_bytevector_u8_set_x, /* VU8 */
2186 scm_bytevector_u8_set_x, /* U8 */
2187 scm_bytevector_s8_set_x,
2188 scm_bytevector_u16_native_set_x,
2189 scm_bytevector_s16_native_set_x,
2190 scm_bytevector_u32_native_set_x,
2191 scm_bytevector_s32_native_set_x,
2192 scm_bytevector_u64_native_set_x,
2193 scm_bytevector_s64_native_set_x,
2194 scm_bytevector_ieee_single_native_set_x,
2195 scm_bytevector_ieee_double_native_set_x,
2196 bytevector_set_c32,
2197 bytevector_set_c64
2198 };
2199
2200 static void
2201 bv_handle_set_x (scm_t_array_handle *h, size_t index, SCM val)
2202 {
2203 SCM byte_index;
2204 scm_t_bytevector_set_fn set_fn;
2205
2206 set_fn = bytevector_set_fns[h->element_type];
2207 byte_index =
2208 scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
2209 set_fn (h->array, byte_index, val);
2210 }
2211
2212 static void
2213 bytevector_get_handle (SCM v, scm_t_array_handle *h)
2214 {
2215 h->array = v;
2216 h->ndims = 1;
2217 h->dims = &h->dim0;
2218 h->dim0.lbnd = 0;
2219 h->dim0.ubnd = SCM_BYTEVECTOR_TYPED_LENGTH (v) - 1;
2220 h->dim0.inc = 1;
2221 h->element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (v);
2222 h->elements = h->writable_elements = SCM_BYTEVECTOR_CONTENTS (v);
2223 }
2224
2225 \f
2226 /* Initialization. */
2227
2228 void
2229 scm_bootstrap_bytevectors (void)
2230 {
2231 /* This must be instantiated here because the generalized-vector API may
2232 want to access bytevectors even though `(rnrs bytevectors)' hasn't been
2233 loaded. */
2234 scm_null_bytevector = make_bytevector (0, SCM_ARRAY_ELEMENT_TYPE_VU8);
2235
2236 #ifdef WORDS_BIGENDIAN
2237 scm_i_native_endianness = scm_from_latin1_symbol ("big");
2238 #else
2239 scm_i_native_endianness = scm_from_latin1_symbol ("little");
2240 #endif
2241
2242 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
2243 "scm_init_bytevectors",
2244 (scm_t_extension_init_func) scm_init_bytevectors,
2245 NULL);
2246
2247 {
2248 scm_t_array_implementation impl;
2249
2250 impl.tag = scm_tc7_bytevector;
2251 impl.mask = 0x7f;
2252 impl.vref = bv_handle_ref;
2253 impl.vset = bv_handle_set_x;
2254 impl.get_handle = bytevector_get_handle;
2255 scm_i_register_array_implementation (&impl);
2256 scm_i_register_vector_constructor
2257 (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8],
2258 scm_make_bytevector);
2259 }
2260 }
2261
2262 void
2263 scm_init_bytevectors (void)
2264 {
2265 #include "libguile/bytevectors.x"
2266
2267 scm_endianness_big = scm_sym_big;
2268 scm_endianness_little = scm_sym_little;
2269 }
Unnamed repository; edit this file 'description' to name the repository.