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