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