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