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