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