?  search:
summary | log | graphiclog1 | graphiclog2 | refs | edit | fork

5bc44c936d0cbed0436cc9c3861d04d1b03f887c
[guile-r6rs-libs.git] / src / bytevector.c
blob5bc44c936d0cbed0436cc9c3861d04d1b03f887c
1 /* Guile-R6RS-Libs --- Implementation of R6RS standard libraries.
2 Copyright (C) 2007, 2008, 2009 Ludovic Courtès <ludo@gnu.org>
3
4 Guile-R6RS-Libs is free software; you can redistribute it and/or
5 modify it under the terms of the GNU Lesser General Public
6 License as published by the Free Software Foundation; either
7 version 2.1 of the License, or (at your option) any later version.
8
9 Guile-R6RS-Libs is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 Lesser General Public License for more details.
13
14 You should have received a copy of the GNU Lesser General Public
15 License along with Guile-R6RS-Libs; if not, write to the Free Software
16 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */
17
18 #ifdef HAVE_CONFIG_H
19 # include <config.h>
20 #endif
21
22 #include <alloca.h>
23
24 #include <libguile.h>
25 #include <gmp.h>
26
27 #include "bytevector.h"
28 #include "ieee-754.h"
29 #include "uniconv.h"
30 #include "striconveh.h"
31 #include "utils.h"
32
33 #include <byteswap.h>
34
35 #ifdef HAVE_LIMITS_H
36 # include <limits.h>
37 #else
38 /* Assuming 32-bit longs. */
39 # define ULONG_MAX 4294967295UL
40 #endif
41
42 #include <string.h>
43
44
45 \f
46 /* Utilities. */
47
48 /* Convenience macros. These are used by the various templates (macros) that
49 are parameterized by integer signedness. */
50 #define INT8_T_signed scm_t_int8
51 #define INT8_T_unsigned scm_t_uint8
52 #define INT16_T_signed scm_t_int16
53 #define INT16_T_unsigned scm_t_uint16
54 #define INT32_T_signed scm_t_int32
55 #define INT32_T_unsigned scm_t_uint32
56 #define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L))
57 #define is_unsigned_int8(_x) ((_x) <= 255UL)
58 #define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
59 #define is_unsigned_int16(_x) ((_x) <= 65535UL)
60 #define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L))
61 #define is_unsigned_int32(_x) ((_x) <= 4294967295UL)
62 #define SIGNEDNESS_signed 1
63 #define SIGNEDNESS_unsigned 0
64
65 #define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign
66 #define INT_SWAP(_size) bswap_ ## _size
67 #define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
68 #define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
69
70
71 #define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \
72 unsigned c_len, c_index; \
73 _sign char *c_bv; \
74 \
75 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv); \
76 c_index = scm_to_uint (index); \
77 \
78 c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv); \
79 c_bv = (_sign char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv); \
80 \
81 if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
82 scm_out_of_range (FUNC_NAME, index);
83
84 /* Template for fixed-size integer access (only 8, 16 or 32-bit). */
85 #define INTEGER_REF(_len, _sign) \
86 SCM result; \
87 \
88 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
89 SCM_VALIDATE_SYMBOL (3, endianness); \
90 \
91 { \
92 INT_TYPE (_len, _sign) c_result; \
93 \
94 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
95 if (!scm_is_eq (endianness, native_endianness)) \
96 c_result = INT_SWAP (_len) (c_result); \
97 \
98 result = SCM_I_MAKINUM (c_result); \
99 } \
100 \
101 return result;
102
103 /* Template for fixed-size integer access using the native endianness. */
104 #define INTEGER_NATIVE_REF(_len, _sign) \
105 SCM result; \
106 \
107 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
108 \
109 { \
110 INT_TYPE (_len, _sign) c_result; \
111 \
112 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
113 result = SCM_I_MAKINUM (c_result); \
114 } \
115 \
116 return result;
117
118 /* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
119 #define INTEGER_SET(_len, _sign) \
120 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
121 SCM_VALIDATE_SYMBOL (3, endianness); \
122 \
123 { \
124 _sign long c_value; \
125 INT_TYPE (_len, _sign) c_value_short; \
126 \
127 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
128 scm_wrong_type_arg (FUNC_NAME, 3, value); \
129 \
130 c_value = SCM_I_INUM (value); \
131 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
132 scm_out_of_range (FUNC_NAME, value); \
133 \
134 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
135 if (!scm_is_eq (endianness, native_endianness)) \
136 c_value_short = INT_SWAP (_len) (c_value_short); \
137 \
138 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
139 } \
140 \
141 return SCM_UNSPECIFIED;
142
143 /* Template for fixed-size integer modification using the native
144 endianness. */
145 #define INTEGER_NATIVE_SET(_len, _sign) \
146 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
147 \
148 { \
149 _sign long c_value; \
150 INT_TYPE (_len, _sign) c_value_short; \
151 \
152 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
153 scm_wrong_type_arg (FUNC_NAME, 3, value); \
154 \
155 c_value = SCM_I_INUM (value); \
156 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
157 scm_out_of_range (FUNC_NAME, value); \
158 \
159 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
160 \
161 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
162 } \
163 \
164 return SCM_UNSPECIFIED;
165
166
167 \f
168 /* Bytevector type. */
169
170 SCM_GLOBAL_SMOB (scm_tc16_r6rs_bytevector, "r6rs-bytevector", 0);
171
172 #define SCM_R6RS_BYTEVECTOR_SET_LENGTH(_bv, _len) \
173 SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len))
174 #define SCM_R6RS_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
175 SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf))
176
177 /* The empty bytevector. */
178 SCM scm_r6rs_null_bytevector = SCM_UNSPECIFIED;
179
180
181 static inline SCM
182 make_bytevector_from_buffer (unsigned len, signed char *contents)
183 {
184 /* Assuming LEN > SCM_R6RS_BYTEVECTOR_INLINE_THRESHOLD. */
185 SCM_RETURN_NEWSMOB2 (scm_tc16_r6rs_bytevector, len, contents);
186 }
187
188 static inline SCM
189 make_bytevector (unsigned len)
190 {
191 SCM bv;
192
193 if (SCM_UNLIKELY (len == 0))
194 bv = scm_r6rs_null_bytevector;
195 else
196 {
197 signed char *contents = NULL;
198
199 if (!SCM_R6RS_BYTEVECTOR_INLINEABLE_SIZE_P (len))
200 contents = (signed char *) scm_gc_malloc (len, SCM_GC_BYTEVECTOR);
201
202 bv = make_bytevector_from_buffer (len, contents);
203 }
204
205 return bv;
206 }
207
208 /* Return a new bytevector of size LEN octets. */
209 SCM
210 scm_r6rs_c_make_bytevector (unsigned len)
211 {
212 return (make_bytevector (len));
213 }
214
215 /* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
216 by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
217 SCM
218 scm_r6rs_c_take_bytevector (signed char *contents, unsigned len)
219 {
220 SCM bv;
221
222 if (SCM_UNLIKELY (SCM_R6RS_BYTEVECTOR_INLINEABLE_SIZE_P (len)))
223 {
224 /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */
225 signed char *c_bv;
226
227 bv = make_bytevector (len);
228 c_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
229 memcpy (c_bv, contents, len);
230 scm_gc_free (contents, len, SCM_GC_BYTEVECTOR);
231 }
232 else
233 bv = make_bytevector_from_buffer (len, contents);
234
235 return bv;
236 }
237
238 /* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
239 size) and return BV. */
240 SCM
241 scm_r6rs_i_shrink_bytevector (SCM bv, unsigned c_new_len)
242 {
243 if (!SCM_R6RS_BYTEVECTOR_INLINE_P (bv))
244 {
245 unsigned c_len;
246 signed char *c_bv, *c_new_bv;
247
248 c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
249 c_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
250
251 SCM_R6RS_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
252
253 if (SCM_R6RS_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len))
254 {
255 /* Copy to the in-line buffer and free the current buffer. */
256 c_new_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
257 memcpy (c_new_bv, c_bv, c_new_len);
258 scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
259 }
260 else
261 {
262 /* Resize the existing buffer. */
263 c_new_bv = scm_gc_realloc (c_bv, c_len, c_new_len,
264 SCM_GC_BYTEVECTOR);
265 SCM_R6RS_BYTEVECTOR_SET_CONTENTS (bv, c_new_bv);
266 }
267 }
268
269 return bv;
270 }
271
272 SCM_SMOB_PRINT (scm_tc16_r6rs_bytevector, print_bytevector,
273 bv, port, pstate)
274 {
275 unsigned c_len, i;
276 unsigned char *c_bv;
277
278 c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
279 c_bv = (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
280
281 scm_puts ("#vu8(", port);
282 for (i = 0; i < c_len; i++)
283 {
284 if (i > 0)
285 scm_putc (' ', port);
286
287 scm_uintprint (c_bv[i], 10, port);
288 }
289
290 scm_putc (')', port);
291
292 /* Make GCC think we use it. */
293 scm_remember_upto_here ((SCM) pstate);
294
295 return 1;
296 }
297
298 SCM_SMOB_EQUALP (scm_tc16_r6rs_bytevector, bytevector_equal_p, bv1, bv2)
299 {
300 return scm_r6rs_bytevector_eq_p (bv1, bv2);
301 }
302
303 SCM_SMOB_FREE (scm_tc16_r6rs_bytevector, free_bytevector, bv)
304 {
305
306 if (!SCM_R6RS_BYTEVECTOR_INLINE_P (bv))
307 {
308 unsigned c_len;
309 signed char *c_bv;
310
311 c_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
312 c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
313
314 scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
315 }
316
317 return 0;
318 }
319
320
321 \f
322 /* General operations. */
323
324 SCM_SYMBOL (scm_sym_big, "big");
325 SCM_SYMBOL (scm_sym_little, "little");
326
327 SCM scm_r6rs_endianness_big, scm_r6rs_endianness_little;
328
329 /* Host endianness (a symbol). */
330 static SCM native_endianness = SCM_UNSPECIFIED;
331
332 /* Byte-swapping. */
333 #ifndef bswap_24
334 # define bswap_24(_x) \
335 ((((_x) & 0xff0000) >> 16) | \
336 (((_x) & 0x00ff00)) | \
337 (((_x) & 0x0000ff) << 16))
338 #endif
339
340
341 SCM_DEFINE (scm_r6rs_native_endianness, "native-endianness", 0, 0, 0,
342 (void),
343 "Return a symbol denoting the machine's native endianness.")
344 {
345 return native_endianness;
346 }
347
348 SCM_DEFINE (scm_r6rs_bytevector_p, "bytevector?", 1, 0, 0,
349 (SCM obj),
350 "Return true if @var{obj} is a bytevector.")
351 {
352 return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_r6rs_bytevector,
353 obj)));
354 }
355
356 SCM_DEFINE (scm_r6rs_make_bytevector, "make-bytevector", 1, 1, 0,
357 (SCM len, SCM fill),
358 "Return a newly allocated bytevector of @var{len} bytes, "
359 "optionally filled with @var{fill}.")
360 #define FUNC_NAME s_scm_r6rs_make_bytevector
361 {
362 SCM bv;
363 unsigned c_len;
364 signed char c_fill = '\0';
365
366 SCM_VALIDATE_UINT_COPY (1, len, c_len);
367 if (fill != SCM_UNDEFINED)
368 {
369 int value;
370
371 value = scm_to_int (fill);
372 if (SCM_UNLIKELY ((value < -128) || (value > 255)))
373 scm_out_of_range (FUNC_NAME, fill);
374 c_fill = (signed char) value;
375 }
376
377 bv = make_bytevector (c_len);
378 if (fill != SCM_UNDEFINED)
379 {
380 unsigned i;
381 signed char *contents;
382
383 contents = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
384 for (i = 0; i < c_len; i++)
385 contents[i] = c_fill;
386 }
387
388 return bv;
389 }
390 #undef FUNC_NAME
391
392 SCM_DEFINE (scm_r6rs_bytevector_length, "bytevector-length", 1, 0, 0,
393 (SCM bv),
394 "Return the length (in bytes) of @var{bv}.")
395 #define FUNC_NAME s_scm_r6rs_bytevector_length
396 {
397 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
398
399 return (scm_from_uint (SCM_R6RS_BYTEVECTOR_LENGTH (bv)));
400 }
401 #undef FUNC_NAME
402
403 SCM_DEFINE (scm_r6rs_bytevector_eq_p, "bytevector=?", 2, 0, 0,
404 (SCM bv1, SCM bv2),
405 "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
406 "have the same length and contents.")
407 #define FUNC_NAME s_scm_r6rs_bytevector_eq_p
408 {
409 SCM result = SCM_BOOL_F;
410 unsigned c_len1, c_len2;
411
412 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv1);
413 SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv2);
414
415 c_len1 = SCM_R6RS_BYTEVECTOR_LENGTH (bv1);
416 c_len2 = SCM_R6RS_BYTEVECTOR_LENGTH (bv2);
417
418 if (c_len1 == c_len2)
419 {
420 signed char *c_bv1, *c_bv2;
421
422 c_bv1 = SCM_R6RS_BYTEVECTOR_CONTENTS (bv1);
423 c_bv2 = SCM_R6RS_BYTEVECTOR_CONTENTS (bv2);
424
425 result = scm_from_bool (!memcmp (c_bv1, c_bv2, c_len1));
426 }
427
428 return result;
429 }
430 #undef FUNC_NAME
431
432 SCM_DEFINE (scm_r6rs_bytevector_fill_x, "bytevector-fill!", 2, 0, 0,
433 (SCM bv, SCM fill),
434 "Fill bytevector @var{bv} with @var{fill}, a byte.")
435 #define FUNC_NAME s_scm_r6rs_bytevector_fill_x
436 {
437 unsigned c_len, i;
438 signed char *c_bv, c_fill;
439
440 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
441 c_fill = scm_to_int8 (fill);
442
443 c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
444 c_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
445
446 for (i = 0; i < c_len; i++)
447 c_bv[i] = c_fill;
448
449 return SCM_UNSPECIFIED;
450 }
451 #undef FUNC_NAME
452
453 SCM_DEFINE (scm_r6rs_bytevector_copy_x, "bytevector-copy!", 5, 0, 0,
454 (SCM source, SCM source_start, SCM target, SCM target_start,
455 SCM len),
456 "Copy @var{len} bytes from @var{source} into @var{target}, "
457 "starting reading from @var{source_start} (a positive index "
458 "within @var{source}) and start writing at "
459 "@var{target_start}.")
460 #define FUNC_NAME s_scm_r6rs_bytevector_copy_x
461 {
462 unsigned c_len, c_source_len, c_target_len;
463 unsigned c_source_start, c_target_start;
464 signed char *c_source, *c_target;
465
466 SCM_VALIDATE_R6RS_BYTEVECTOR (1, source);
467 SCM_VALIDATE_R6RS_BYTEVECTOR (3, target);
468
469 c_len = scm_to_uint (len);
470 c_source_start = scm_to_uint (source_start);
471 c_target_start = scm_to_uint (target_start);
472
473 c_source = SCM_R6RS_BYTEVECTOR_CONTENTS (source);
474 c_target = SCM_R6RS_BYTEVECTOR_CONTENTS (target);
475 c_source_len = SCM_R6RS_BYTEVECTOR_LENGTH (source);
476 c_target_len = SCM_R6RS_BYTEVECTOR_LENGTH (target);
477
478 if (SCM_UNLIKELY (c_source_start + c_len > c_source_len))
479 scm_out_of_range (FUNC_NAME, source_start);
480 if (SCM_UNLIKELY (c_target_start + c_len > c_target_len))
481 scm_out_of_range (FUNC_NAME, target_start);
482
483 memcpy (c_target + c_target_start,
484 c_source + c_source_start,
485 c_len);
486
487 return SCM_UNSPECIFIED;
488 }
489 #undef FUNC_NAME
490
491 SCM_DEFINE (scm_r6rs_bytevector_copy, "bytevector-copy", 1, 0, 0,
492 (SCM bv),
493 "Return a newly allocated copy of @var{bv}.")
494 #define FUNC_NAME s_scm_r6rs_bytevector_copy
495 {
496 SCM copy;
497 unsigned c_len;
498 signed char *c_bv, *c_copy;
499
500 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
501
502 c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
503 c_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
504
505 copy = make_bytevector (c_len);
506 c_copy = SCM_R6RS_BYTEVECTOR_CONTENTS (copy);
507 memcpy (c_copy, c_bv, c_len);
508
509 return copy;
510 }
511 #undef FUNC_NAME
512
513 \f
514 /* Operations on bytes and octets. */
515
516 SCM_DEFINE (scm_r6rs_bytevector_u8_ref, "bytevector-u8-ref", 2, 0, 0,
517 (SCM bv, SCM index),
518 "Return the octet located at @var{index} in @var{bv}.")
519 #define FUNC_NAME s_scm_r6rs_bytevector_u8_ref
520 {
521 INTEGER_NATIVE_REF (8, unsigned);
522 }
523 #undef FUNC_NAME
524
525 SCM_DEFINE (scm_r6rs_bytevector_s8_ref, "bytevector-s8-ref", 2, 0, 0,
526 (SCM bv, SCM index),
527 "Return the byte located at @var{index} in @var{bv}.")
528 #define FUNC_NAME s_scm_r6rs_bytevector_u8_ref
529 {
530 INTEGER_NATIVE_REF (8, signed);
531 }
532 #undef FUNC_NAME
533
534 SCM_DEFINE (scm_r6rs_bytevector_u8_set_x, "bytevector-u8-set!", 3, 0, 0,
535 (SCM bv, SCM index, SCM value),
536 "Return the octet located at @var{index} in @var{bv}.")
537 #define FUNC_NAME s_scm_r6rs_bytevector_u8_set_x
538 {
539 INTEGER_NATIVE_SET (8, unsigned);
540 }
541 #undef FUNC_NAME
542
543 SCM_DEFINE (scm_r6rs_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0,
544 (SCM bv, SCM index, SCM value),
545 "Return the octet located at @var{index} in @var{bv}.")
546 #define FUNC_NAME s_scm_r6rs_bytevector_u8_set_x
547 {
548 INTEGER_NATIVE_SET (8, signed);
549 }
550 #undef FUNC_NAME
551
552 #undef OCTET_ACCESSOR_PROLOGUE
553
554
555 SCM_DEFINE (scm_r6rs_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0,
556 (SCM bv),
557 "Return a newly allocated list of octets containing the "
558 "contents of @var{bv}.")
559 #define FUNC_NAME s_scm_r6rs_bytevector_to_u8_list
560 {
561 SCM lst, pair;
562 unsigned c_len, i;
563 unsigned char *c_bv;
564
565 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
566
567 c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
568 c_bv = (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
569
570 lst = scm_make_list (scm_from_uint (c_len), SCM_UNSPECIFIED);
571 for (i = 0, pair = lst;
572 i < c_len;
573 i++, pair = SCM_CDR (pair))
574 {
575 SCM_SETCAR (pair, SCM_I_MAKINUM (c_bv[i]));
576 }
577
578 return lst;
579 }
580 #undef FUNC_NAME
581
582 SCM_DEFINE (scm_r6rs_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0,
583 (SCM lst),
584 "Turn @var{lst}, a list of octets, into a bytevector.")
585 #define FUNC_NAME s_scm_r6rs_u8_list_to_bytevector
586 {
587 SCM bv, item;
588 long c_len, i;
589 unsigned char *c_bv;
590
591 SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);
592
593 bv = make_bytevector (c_len);
594 c_bv = (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
595
596 for (i = 0; i < c_len; lst = SCM_CDR (lst), i++)
597 {
598 item = SCM_CAR (lst);
599
600 if (SCM_LIKELY (SCM_I_INUMP (item)))
601 {
602 long c_item;
603
604 c_item = SCM_I_INUM (item);
605 if (SCM_LIKELY ((c_item >= 0) && (c_item < 256)))
606 c_bv[i] = (unsigned char) c_item;
607 else
608 goto type_error;
609 }
610 else
611 goto type_error;
612 }
613
614 return bv;
615
616 type_error:
617 scm_wrong_type_arg (FUNC_NAME, 1, item);
618
619 return SCM_BOOL_F;
620 }
621 #undef FUNC_NAME
622
623 /* Compute the two's complement of VALUE (a positive integer) on SIZE octets
624 using (2^(SIZE * 8) - VALUE). */
625 static inline void
626 twos_complement (mpz_t value, size_t size)
627 {
628 unsigned long bit_count;
629
630 /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
631 checking on SIZE performed earlier. */
632 bit_count = (unsigned long) size << 3UL;
633
634 if (SCM_LIKELY (bit_count < sizeof (unsigned long)))
635 mpz_ui_sub (value, 1UL << bit_count, value);
636 else
637 {
638 mpz_t max;
639
640 mpz_init (max);
641 mpz_ui_pow_ui (max, 2, bit_count);
642 mpz_sub (value, max, value);
643 mpz_clear (max);
644 }
645 }
646
647 static inline SCM
648 bytevector_large_ref (const char *c_bv, size_t c_size, int signed_p,
649 SCM endianness)
650 {
651 SCM result;
652 mpz_t c_mpz;
653 int c_endianness, negative_p = 0;
654
655 if (signed_p)
656 {
657 if (scm_is_eq (endianness, scm_sym_big))
658 negative_p = c_bv[0] & 0x80;
659 else
660 negative_p = c_bv[c_size - 1] & 0x80;
661 }
662
663 c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
664
665 mpz_init (c_mpz);
666 mpz_import (c_mpz, 1 /* 1 word */, 1 /* word order doesn't matter */,
667 c_size /* word is C_SIZE-byte long */,
668 c_endianness,
669 0 /* nails */, c_bv);
670
671 if (signed_p && negative_p)
672 {
673 twos_complement (c_mpz, c_size);
674 mpz_neg (c_mpz, c_mpz);
675 }
676
677 result = scm_from_mpz (c_mpz);
678 mpz_clear (c_mpz); /* FIXME: Needed? */
679
680 return result;
681 }
682
683 static inline int
684 bytevector_large_set (char *c_bv, size_t c_size, int signed_p,
685 SCM value, SCM endianness)
686 {
687 mpz_t c_mpz;
688 int c_endianness, c_sign, err = 0;
689
690 c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
691
692 mpz_init (c_mpz);
693 scm_to_mpz (value, c_mpz);
694
695 c_sign = mpz_sgn (c_mpz);
696 if (c_sign < 0)
697 {
698 if (SCM_LIKELY (signed_p))
699 {
700 mpz_neg (c_mpz, c_mpz);
701 twos_complement (c_mpz, c_size);
702 }
703 else
704 {
705 err = -1;
706 goto finish;
707 }
708 }
709
710 if (c_sign == 0)
711 /* Zero. */
712 memset (c_bv, 0, c_size);
713 else
714 {
715 size_t word_count, value_size;
716
717 value_size = (mpz_sizeinbase (c_mpz, 2) + (8 * c_size)) / (8 * c_size);
718 if (SCM_UNLIKELY (value_size > c_size))
719 {
720 err = -2;
721 goto finish;
722 }
723
724
725 mpz_export (c_bv, &word_count, 1 /* word order doesn't matter */,
726 c_size, c_endianness,
727 0 /* nails */, c_mpz);
728 if (SCM_UNLIKELY (word_count != 1))
729 /* Shouldn't happen since we already checked with VALUE_SIZE. */
730 abort ();
731 }
732
733 finish:
734 mpz_clear (c_mpz);
735
736 return err;
737 }
738
739 #define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \
740 unsigned long c_len, c_index, c_size; \
741 char *c_bv; \
742 \
743 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv); \
744 c_index = scm_to_ulong (index); \
745 c_size = scm_to_ulong (size); \
746 \
747 c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv); \
748 c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv); \
749 \
750 /* C_SIZE must have its 3 higher bits set to zero so that \
751 multiplying it by 8 yields a number that fits in an \
752 unsigned long. */ \
753 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
754 scm_out_of_range (FUNC_NAME, size); \
755 if (SCM_UNLIKELY (c_index + c_size > c_len)) \
756 scm_out_of_range (FUNC_NAME, index);
757
758
759 /* Template of an integer reference function. */
760 #define GENERIC_INTEGER_REF(_sign) \
761 SCM result; \
762 \
763 if (c_size < 3) \
764 { \
765 int swap; \
766 _sign int value; \
767 \
768 swap = !scm_is_eq (endianness, native_endianness); \
769 switch (c_size) \
770 { \
771 case 1: \
772 { \
773 _sign char c_value8; \
774 memcpy (&c_value8, c_bv, 1); \
775 value = c_value8; \
776 } \
777 break; \
778 case 2: \
779 { \
780 INT_TYPE (16, _sign) c_value16; \
781 memcpy (&c_value16, c_bv, 2); \
782 if (swap) \
783 value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \
784 else \
785 value = c_value16; \
786 } \
787 break; \
788 default: \
789 abort (); \
790 } \
791 \
792 result = SCM_I_MAKINUM ((_sign int) value); \
793 } \
794 else \
795 result = bytevector_large_ref ((char *) c_bv, \
796 c_size, SIGNEDNESS (_sign), \
797 endianness); \
798 \
799 return result;
800
801 static inline SCM
802 bytevector_signed_ref (const char *c_bv, size_t c_size, SCM endianness)
803 {
804 GENERIC_INTEGER_REF (signed);
805 }
806
807 static inline SCM
808 bytevector_unsigned_ref (const char *c_bv, size_t c_size, SCM endianness)
809 {
810 GENERIC_INTEGER_REF (unsigned);
811 }
812
813
814 /* Template of an integer assignment function. */
815 #define GENERIC_INTEGER_SET(_sign) \
816 if (c_size < 3) \
817 { \
818 _sign int c_value; \
819 \
820 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
821 goto range_error; \
822 \
823 c_value = SCM_I_INUM (value); \
824 switch (c_size) \
825 { \
826 case 1: \
827 if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \
828 { \
829 _sign char c_value8; \
830 c_value8 = (_sign char) c_value; \
831 memcpy (c_bv, &c_value8, 1); \
832 } \
833 else \
834 goto range_error; \
835 break; \
836 \
837 case 2: \
838 if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \
839 { \
840 int swap; \
841 INT_TYPE (16, _sign) c_value16; \
842 \
843 swap = !scm_is_eq (endianness, native_endianness); \
844 \
845 if (swap) \
846 c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \
847 else \
848 c_value16 = c_value; \
849 \
850 memcpy (c_bv, &c_value16, 2); \
851 } \
852 else \
853 goto range_error; \
854 break; \
855 \
856 default: \
857 abort (); \
858 } \
859 } \
860 else \
861 { \
862 int err; \
863 \
864 err = bytevector_large_set (c_bv, c_size, \
865 SIGNEDNESS (_sign), \
866 value, endianness); \
867 if (err) \
868 goto range_error; \
869 } \
870 \
871 return; \
872 \
873 range_error: \
874 scm_out_of_range (FUNC_NAME, value); \
875 return;
876
877 static inline void
878 bytevector_signed_set (char *c_bv, size_t c_size,
879 SCM value, SCM endianness,
880 const char *func_name)
881 #define FUNC_NAME func_name
882 {
883 GENERIC_INTEGER_SET (signed);
884 }
885 #undef FUNC_NAME
886
887 static inline void
888 bytevector_unsigned_set (char *c_bv, size_t c_size,
889 SCM value, SCM endianness,
890 const char *func_name)
891 #define FUNC_NAME func_name
892 {
893 GENERIC_INTEGER_SET (unsigned);
894 }
895 #undef FUNC_NAME
896
897 #undef GENERIC_INTEGER_SET
898 #undef GENERIC_INTEGER_REF
899
900
901 SCM_DEFINE (scm_r6rs_bytevector_uint_ref, "bytevector-uint-ref", 4, 0, 0,
902 (SCM bv, SCM index, SCM endianness, SCM size),
903 "Return the @var{size}-octet long unsigned integer at index "
904 "@var{index} in @var{bv}.")
905 #define FUNC_NAME s_scm_r6rs_bytevector_uint_ref
906 {
907 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
908
909 return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness));
910 }
911 #undef FUNC_NAME
912
913 SCM_DEFINE (scm_r6rs_bytevector_sint_ref, "bytevector-sint-ref", 4, 0, 0,
914 (SCM bv, SCM index, SCM endianness, SCM size),
915 "Return the @var{size}-octet long unsigned integer at index "
916 "@var{index} in @var{bv}.")
917 #define FUNC_NAME s_scm_r6rs_bytevector_sint_ref
918 {
919 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
920
921 return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness));
922 }
923 #undef FUNC_NAME
924
925 SCM_DEFINE (scm_r6rs_bytevector_uint_set_x, "bytevector-uint-set!", 5, 0, 0,
926 (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
927 "Set the @var{size}-octet long unsigned integer at @var{index} "
928 "to @var{value}.")
929 #define FUNC_NAME s_scm_r6rs_bytevector_uint_set_x
930 {
931 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
932
933 bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness,
934 FUNC_NAME);
935
936 return SCM_UNSPECIFIED;
937 }
938 #undef FUNC_NAME
939
940 SCM_DEFINE (scm_r6rs_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0,
941 (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
942 "Set the @var{size}-octet long signed integer at @var{index} "
943 "to @var{value}.")
944 #define FUNC_NAME s_scm_r6rs_bytevector_sint_set_x
945 {
946 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
947
948 bytevector_signed_set (&c_bv[c_index], c_size, value, endianness,
949 FUNC_NAME);
950
951 return SCM_UNSPECIFIED;
952 }
953 #undef FUNC_NAME
954
955
956 \f
957 /* Operations on integers of arbitrary size. */
958
959 #define INTEGERS_TO_LIST(_sign) \
960 SCM lst, pair; \
961 size_t i, c_len, c_size; \
962 \
963 SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv); \
964 SCM_VALIDATE_SYMBOL (2, endianness); \
965 c_size = scm_to_uint (size); \
966 \
967 c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv); \
968 if (SCM_UNLIKELY (c_len == 0)) \
969 lst = SCM_EOL; \
970 else if (SCM_UNLIKELY (c_len < c_size)) \
971 scm_out_of_range (FUNC_NAME, size); \
972 else \
973 { \
974 const char *c_bv; \
975 \
976 c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv); \
977 \
978 lst = scm_make_list (scm_from_uint (c_len / c_size), \
979 SCM_UNSPECIFIED); \
980 for (i = 0, pair = lst; \
981 i <= c_len - c_size; \
982 i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
983 { \
984 SCM_SETCAR (pair, \
985 bytevector_ ## _sign ## _ref (c_bv, c_size, \
986 endianness)); \
987 } \
988 } \
989 \
990 return lst;
991
992 SCM_DEFINE (scm_r6rs_bytevector_to_sint_list, "bytevector->sint-list",
993 3, 0, 0,
994 (SCM bv, SCM endianness, SCM size),
995 "Return a list of signed integers of @var{size} octets "
996 "representing the contents of @var{bv}.")
997 #define FUNC_NAME s_scm_r6rs_bytevector_to_sint_list
998 {
999 INTEGERS_TO_LIST (signed);
1000 }
1001 #undef FUNC_NAME
1002
1003 SCM_DEFINE (scm_r6rs_bytevector_to_uint_list, "bytevector->uint-list",
1004 3, 0, 0,
1005 (SCM bv, SCM endianness, SCM size),
1006 "Return a list of unsigned integers of @var{size} octets "
1007 "representing the contents of @var{bv}.")
1008 #define FUNC_NAME s_scm_r6rs_bytevector_to_uint_list
1009 {
1010 INTEGERS_TO_LIST (unsigned);
1011 }
1012 #undef FUNC_NAME
1013
1014 #undef INTEGER_TO_LIST
1015
1016
1017 #define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
1018 SCM bv; \
1019 long c_len; \
1020 size_t c_size; \
1021 char *c_bv, *c_bv_ptr; \
1022 \
1023 SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
1024 SCM_VALIDATE_SYMBOL (2, endianness); \
1025 c_size = scm_to_uint (size); \
1026 \
1027 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
1028 scm_out_of_range (FUNC_NAME, size); \
1029 \
1030 bv = make_bytevector (c_len * c_size); \
1031 c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv); \
1032 \
1033 for (c_bv_ptr = c_bv; \
1034 !scm_is_null (lst); \
1035 lst = SCM_CDR (lst), c_bv_ptr += c_size) \
1036 { \
1037 bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
1038 SCM_CAR (lst), endianness, \
1039 FUNC_NAME); \
1040 } \
1041 \
1042 return bv;
1043
1044
1045 SCM_DEFINE (scm_r6rs_uint_list_to_bytevector, "uint-list->bytevector",
1046 3, 0, 0,
1047 (SCM lst, SCM endianness, SCM size),
1048 "Return a bytevector containing the unsigned integers "
1049 "listed in @var{lst} and encoded on @var{size} octets "
1050 "according to @var{endianness}.")
1051 #define FUNC_NAME s_scm_r6rs_uint_list_to_bytevector
1052 {
1053 INTEGER_LIST_TO_BYTEVECTOR (unsigned);
1054 }
1055 #undef FUNC_NAME
1056
1057 SCM_DEFINE (scm_r6rs_sint_list_to_bytevector, "sint-list->bytevector",
1058 3, 0, 0,
1059 (SCM lst, SCM endianness, SCM size),
1060 "Return a bytevector containing the signed integers "
1061 "listed in @var{lst} and encoded on @var{size} octets "
1062 "according to @var{endianness}.")
1063 #define FUNC_NAME s_scm_r6rs_sint_list_to_bytevector
1064 {
1065 INTEGER_LIST_TO_BYTEVECTOR (signed);
1066 }
1067 #undef FUNC_NAME
1068
1069 #undef INTEGER_LIST_TO_BYTEVECTOR
1070
1071
1072 \f
1073 /* Operations on 16-bit integers. */
1074
1075 SCM_DEFINE (scm_r6rs_bytevector_u16_ref, "bytevector-u16-ref",
1076 3, 0, 0,
1077 (SCM bv, SCM index, SCM endianness),
1078 "Return the unsigned 16-bit integer from @var{bv} at "
1079 "@var{index}.")
1080 #define FUNC_NAME s_scm_r6rs_bytevector_u16_ref
1081 {
1082 INTEGER_REF (16, unsigned);
1083 }
1084 #undef FUNC_NAME
1085
1086 SCM_DEFINE (scm_r6rs_bytevector_s16_ref, "bytevector-s16-ref",
1087 3, 0, 0,
1088 (SCM bv, SCM index, SCM endianness),
1089 "Return the signed 16-bit integer from @var{bv} at "
1090 "@var{index}.")
1091 #define FUNC_NAME s_scm_r6rs_bytevector_s16_ref
1092 {
1093 INTEGER_REF (16, signed);
1094 }
1095 #undef FUNC_NAME
1096
1097 SCM_DEFINE (scm_r6rs_bytevector_u16_native_ref, "bytevector-u16-native-ref",
1098 2, 0, 0,
1099 (SCM bv, SCM index),
1100 "Return the unsigned 16-bit integer from @var{bv} at "
1101 "@var{index} using the native endianness.")
1102 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_ref
1103 {
1104 INTEGER_NATIVE_REF (16, unsigned);
1105 }
1106 #undef FUNC_NAME
1107
1108 SCM_DEFINE (scm_r6rs_bytevector_s16_native_ref, "bytevector-s16-native-ref",
1109 2, 0, 0,
1110 (SCM bv, SCM index),
1111 "Return the unsigned 16-bit integer from @var{bv} at "
1112 "@var{index} using the native endianness.")
1113 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_ref
1114 {
1115 INTEGER_NATIVE_REF (16, signed);
1116 }
1117 #undef FUNC_NAME
1118
1119 SCM_DEFINE (scm_r6rs_bytevector_u16_set_x, "bytevector-u16-set!",
1120 4, 0, 0,
1121 (SCM bv, SCM index, SCM value, SCM endianness),
1122 "Store @var{value} in @var{bv} at @var{index} according to "
1123 "@var{endianness}.")
1124 #define FUNC_NAME s_scm_r6rs_bytevector_u16_set_x
1125 {
1126 INTEGER_SET (16, unsigned);
1127 }
1128 #undef FUNC_NAME
1129
1130 SCM_DEFINE (scm_r6rs_bytevector_s16_set_x, "bytevector-s16-set!",
1131 4, 0, 0,
1132 (SCM bv, SCM index, SCM value, SCM endianness),
1133 "Store @var{value} in @var{bv} at @var{index} according to "
1134 "@var{endianness}.")
1135 #define FUNC_NAME s_scm_r6rs_bytevector_s16_set_x
1136 {
1137 INTEGER_SET (16, signed);
1138 }
1139 #undef FUNC_NAME
1140
1141 SCM_DEFINE (scm_r6rs_bytevector_u16_native_set_x, "bytevector-u16-native-set!",
1142 3, 0, 0,
1143 (SCM bv, SCM index, SCM value),
1144 "Store the unsigned integer @var{value} at index @var{index} "
1145 "of @var{bv} using the native endianness.")
1146 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_set_x
1147 {
1148 INTEGER_NATIVE_SET (16, unsigned);
1149 }
1150 #undef FUNC_NAME
1151
1152 SCM_DEFINE (scm_r6rs_bytevector_s16_native_set_x, "bytevector-s16-native-set!",
1153 3, 0, 0,
1154 (SCM bv, SCM index, SCM value),
1155 "Store the signed integer @var{value} at index @var{index} "
1156 "of @var{bv} using the native endianness.")
1157 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_set_x
1158 {
1159 INTEGER_NATIVE_SET (16, signed);
1160 }
1161 #undef FUNC_NAME
1162
1163
1164 \f
1165 /* Operations on 32-bit integers. */
1166
1167 /* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
1168 arbitrary 32-bit integers. Thus we fall back to using the
1169 `large_{ref,set}' variants on 32-bit machines. */
1170
1171 #define LARGE_INTEGER_REF(_len, _sign) \
1172 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1173 SCM_VALIDATE_SYMBOL (3, endianness); \
1174 \
1175 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1176 SIGNEDNESS (_sign), endianness));
1177
1178 #define LARGE_INTEGER_SET(_len, _sign) \
1179 int err; \
1180 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1181 SCM_VALIDATE_SYMBOL (4, endianness); \
1182 \
1183 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1184 SIGNEDNESS (_sign), value, endianness); \
1185 if (SCM_UNLIKELY (err)) \
1186 scm_out_of_range (FUNC_NAME, value); \
1187 \
1188 return SCM_UNSPECIFIED;
1189
1190 #define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
1191 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1192 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1193 SIGNEDNESS (_sign), native_endianness));
1194
1195 #define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
1196 int err; \
1197 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1198 \
1199 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1200 SIGNEDNESS (_sign), value, \
1201 native_endianness); \
1202 if (SCM_UNLIKELY (err)) \
1203 scm_out_of_range (FUNC_NAME, value); \
1204 \
1205 return SCM_UNSPECIFIED;
1206
1207
1208 SCM_DEFINE (scm_r6rs_bytevector_u32_ref, "bytevector-u32-ref",
1209 3, 0, 0,
1210 (SCM bv, SCM index, SCM endianness),
1211 "Return the unsigned 32-bit integer from @var{bv} at "
1212 "@var{index}.")
1213 #define FUNC_NAME s_scm_r6rs_bytevector_u32_ref
1214 {
1215 #if SIZEOF_VOID_P > 4
1216 INTEGER_REF (32, unsigned);
1217 #else
1218 LARGE_INTEGER_REF (32, unsigned);
1219 #endif
1220 }
1221 #undef FUNC_NAME
1222
1223 SCM_DEFINE (scm_r6rs_bytevector_s32_ref, "bytevector-s32-ref",
1224 3, 0, 0,
1225 (SCM bv, SCM index, SCM endianness),
1226 "Return the signed 32-bit integer from @var{bv} at "
1227 "@var{index}.")
1228 #define FUNC_NAME s_scm_r6rs_bytevector_s32_ref
1229 {
1230 #if SIZEOF_VOID_P > 4
1231 INTEGER_REF (32, signed);
1232 #else
1233 LARGE_INTEGER_REF (32, signed);
1234 #endif
1235 }
1236 #undef FUNC_NAME
1237
1238 SCM_DEFINE (scm_r6rs_bytevector_u32_native_ref, "bytevector-u32-native-ref",
1239 2, 0, 0,
1240 (SCM bv, SCM index),
1241 "Return the unsigned 32-bit integer from @var{bv} at "
1242 "@var{index} using the native endianness.")
1243 #define FUNC_NAME s_scm_r6rs_bytevector_u32_native_ref
1244 {
1245 #if SIZEOF_VOID_P > 4
1246 INTEGER_NATIVE_REF (32, unsigned);
1247 #else
1248 LARGE_INTEGER_NATIVE_REF (32, unsigned);
1249 #endif
1250 }
1251 #undef FUNC_NAME
1252
1253 SCM_DEFINE (scm_r6rs_bytevector_s32_native_ref, "bytevector-s32-native-ref",
1254 2, 0, 0,
1255 (SCM bv, SCM index),
1256 "Return the unsigned 32-bit integer from @var{bv} at "
1257 "@var{index} using the native endianness.")
1258 #define FUNC_NAME s_scm_r6rs_bytevector_u32_native_ref
1259 {
1260 #if SIZEOF_VOID_P > 4
1261 INTEGER_NATIVE_REF (32, signed);
1262 #else
1263 LARGE_INTEGER_NATIVE_REF (32, signed);
1264 #endif
1265 }
1266 #undef FUNC_NAME
1267
1268 SCM_DEFINE (scm_r6rs_bytevector_u32_set_x, "bytevector-u32-set!",
1269 4, 0, 0,
1270 (SCM bv, SCM index, SCM value, SCM endianness),
1271 "Store @var{value} in @var{bv} at @var{index} according to "
1272 "@var{endianness}.")
1273 #define FUNC_NAME s_scm_r6rs_bytevector_u32_set_x
1274 {
1275 #if SIZEOF_VOID_P > 4
1276 INTEGER_SET (32, unsigned);
1277 #else
1278 LARGE_INTEGER_SET (32, unsigned);
1279 #endif
1280 }
1281 #undef FUNC_NAME
1282
1283 SCM_DEFINE (scm_r6rs_bytevector_s32_set_x, "bytevector-s32-set!",
1284 4, 0, 0,
1285 (SCM bv, SCM index, SCM value, SCM endianness),
1286 "Store @var{value} in @var{bv} at @var{index} according to "
1287 "@var{endianness}.")
1288 #define FUNC_NAME s_scm_r6rs_bytevector_s32_set_x
1289 {
1290 #if SIZEOF_VOID_P > 4
1291 INTEGER_SET (32, signed);
1292 #else
1293 LARGE_INTEGER_SET (32, signed);
1294 #endif
1295 }
1296 #undef FUNC_NAME
1297
1298 SCM_DEFINE (scm_r6rs_bytevector_u32_native_set_x, "bytevector-u32-native-set!",
1299 3, 0, 0,
1300 (SCM bv, SCM index, SCM value),
1301 "Store the unsigned integer @var{value} at index @var{index} "
1302 "of @var{bv} using the native endianness.")
1303 #define FUNC_NAME s_scm_r6rs_bytevector_u32_native_set_x
1304 {
1305 #if SIZEOF_VOID_P > 4
1306 INTEGER_NATIVE_SET (32, unsigned);
1307 #else
1308 LARGE_INTEGER_NATIVE_SET (32, unsigned);
1309 #endif
1310 }
1311 #undef FUNC_NAME
1312
1313 SCM_DEFINE (scm_r6rs_bytevector_s32_native_set_x, "bytevector-s32-native-set!",
1314 3, 0, 0,
1315 (SCM bv, SCM index, SCM value),
1316 "Store the signed integer @var{value} at index @var{index} "
1317 "of @var{bv} using the native endianness.")
1318 #define FUNC_NAME s_scm_r6rs_bytevector_u32_native_set_x
1319 {
1320 #if SIZEOF_VOID_P > 4
1321 INTEGER_NATIVE_SET (32, signed);
1322 #else
1323 LARGE_INTEGER_NATIVE_SET (32, signed);
1324 #endif
1325 }
1326 #undef FUNC_NAME
1327
1328
1329 \f
1330 /* Operations on 64-bit integers. */
1331
1332 /* For 64-bit integers, we use only the `large_{ref,set}' variant. */
1333
1334 SCM_DEFINE (scm_r6rs_bytevector_u64_ref, "bytevector-u64-ref",
1335 3, 0, 0,
1336 (SCM bv, SCM index, SCM endianness),
1337 "Return the unsigned 64-bit integer from @var{bv} at "
1338 "@var{index}.")
1339 #define FUNC_NAME s_scm_r6rs_bytevector_u64_ref
1340 {
1341 LARGE_INTEGER_REF (64, unsigned);
1342 }
1343 #undef FUNC_NAME
1344
1345 SCM_DEFINE (scm_r6rs_bytevector_s64_ref, "bytevector-s64-ref",
1346 3, 0, 0,
1347 (SCM bv, SCM index, SCM endianness),
1348 "Return the signed 64-bit integer from @var{bv} at "
1349 "@var{index}.")
1350 #define FUNC_NAME s_scm_r6rs_bytevector_s64_ref
1351 {
1352 LARGE_INTEGER_REF (64, signed);
1353 }
1354 #undef FUNC_NAME
1355
1356 SCM_DEFINE (scm_r6rs_bytevector_u64_native_ref, "bytevector-u64-native-ref",
1357 2, 0, 0,
1358 (SCM bv, SCM index),
1359 "Return the unsigned 64-bit integer from @var{bv} at "
1360 "@var{index} using the native endianness.")
1361 #define FUNC_NAME s_scm_r6rs_bytevector_u64_native_ref
1362 {
1363 LARGE_INTEGER_NATIVE_REF (64, unsigned);
1364 }
1365 #undef FUNC_NAME
1366
1367 SCM_DEFINE (scm_r6rs_bytevector_s64_native_ref, "bytevector-s64-native-ref",
1368 2, 0, 0,
1369 (SCM bv, SCM index),
1370 "Return the unsigned 64-bit integer from @var{bv} at "
1371 "@var{index} using the native endianness.")
1372 #define FUNC_NAME s_scm_r6rs_bytevector_u64_native_ref
1373 {
1374 LARGE_INTEGER_NATIVE_REF (64, signed);
1375 }
1376 #undef FUNC_NAME
1377
1378 SCM_DEFINE (scm_r6rs_bytevector_u64_set_x, "bytevector-u64-set!",
1379 4, 0, 0,
1380 (SCM bv, SCM index, SCM value, SCM endianness),
1381 "Store @var{value} in @var{bv} at @var{index} according to "
1382 "@var{endianness}.")
1383 #define FUNC_NAME s_scm_r6rs_bytevector_u64_set_x
1384 {
1385 LARGE_INTEGER_SET (64, unsigned);
1386 }
1387 #undef FUNC_NAME
1388
1389 SCM_DEFINE (scm_r6rs_bytevector_s64_set_x, "bytevector-s64-set!",
1390 4, 0, 0,
1391 (SCM bv, SCM index, SCM value, SCM endianness),
1392 "Store @var{value} in @var{bv} at @var{index} according to "
1393 "@var{endianness}.")
1394 #define FUNC_NAME s_scm_r6rs_bytevector_s64_set_x
1395 {
1396 LARGE_INTEGER_SET (64, signed);
1397 }
1398 #undef FUNC_NAME
1399
1400 SCM_DEFINE (scm_r6rs_bytevector_u64_native_set_x, "bytevector-u64-native-set!",
1401 3, 0, 0,
1402 (SCM bv, SCM index, SCM value),
1403 "Store the unsigned integer @var{value} at index @var{index} "
1404 "of @var{bv} using the native endianness.")
1405 #define FUNC_NAME s_scm_r6rs_bytevector_u64_native_set_x
1406 {
1407 LARGE_INTEGER_NATIVE_SET (64, unsigned);
1408 }
1409 #undef FUNC_NAME
1410
1411 SCM_DEFINE (scm_r6rs_bytevector_s64_native_set_x, "bytevector-s64-native-set!",
1412 3, 0, 0,
1413 (SCM bv, SCM index, SCM value),
1414 "Store the signed integer @var{value} at index @var{index} "
1415 "of @var{bv} using the native endianness.")
1416 #define FUNC_NAME s_scm_r6rs_bytevector_u64_native_set_x
1417 {
1418 LARGE_INTEGER_NATIVE_SET (64, signed);
1419 }
1420 #undef FUNC_NAME
1421
1422
1423 \f
1424 /* Operations on IEEE-754 numbers. */
1425
1426 /* There are two possible word endians, visible in glibc's <ieee754.h>.
1427 However, in R6RS, when the endianness is `little', little endian is
1428 assumed for both the byte order and the word order. This is clear from
1429 Section 2.1 of R6RS-lib (in response to
1430 http://www.r6rs.org/formal-comments/comment-187.txt). */
1431
1432
1433 /* Convert to/from a floating-point number with different endianness. This
1434 method is probably not the most efficient but it should be portable. */
1435
1436 static inline void
1437 float_to_foreign_endianness (union scm_r6rs_ieee754_float *target,
1438 float source)
1439 {
1440 union scm_r6rs_ieee754_float src;
1441
1442 src.f = source;
1443
1444 #ifdef WORDS_BIGENDIAN
1445 /* Assuming little endian for both byte and word order. */
1446 target->little_endian.negative = src.big_endian.negative;
1447 target->little_endian.exponent = src.big_endian.exponent;
1448 target->little_endian.mantissa = src.big_endian.mantissa;
1449 #else
1450 target->big_endian.negative = src.little_endian.negative;
1451 target->big_endian.exponent = src.little_endian.exponent;
1452 target->big_endian.mantissa = src.little_endian.mantissa;
1453 #endif
1454 }
1455
1456 static inline float
1457 float_from_foreign_endianness (const union scm_r6rs_ieee754_float *source)
1458 {
1459 union scm_r6rs_ieee754_float result;
1460
1461 #ifdef WORDS_BIGENDIAN
1462 /* Assuming little endian for both byte and word order. */
1463 result.big_endian.negative = source->little_endian.negative;
1464 result.big_endian.exponent = source->little_endian.exponent;
1465 result.big_endian.mantissa = source->little_endian.mantissa;
1466 #else
1467 result.little_endian.negative = source->big_endian.negative;
1468 result.little_endian.exponent = source->big_endian.exponent;
1469 result.little_endian.mantissa = source->big_endian.mantissa;
1470 #endif
1471
1472 return (result.f);
1473 }
1474
1475 static inline void
1476 double_to_foreign_endianness (union scm_r6rs_ieee754_double *target,
1477 double source)
1478 {
1479 union scm_r6rs_ieee754_double src;
1480
1481 src.d = source;
1482
1483 #ifdef WORDS_BIGENDIAN
1484 /* Assuming little endian for both byte and word order. */
1485 target->little_little_endian.negative = src.big_endian.negative;
1486 target->little_little_endian.exponent = src.big_endian.exponent;
1487 target->little_little_endian.mantissa0 = src.big_endian.mantissa0;
1488 target->little_little_endian.mantissa1 = src.big_endian.mantissa1;
1489 #else
1490 target->big_endian.negative = src.little_little_endian.negative;
1491 target->big_endian.exponent = src.little_little_endian.exponent;
1492 target->big_endian.mantissa0 = src.little_little_endian.mantissa0;
1493 target->big_endian.mantissa1 = src.little_little_endian.mantissa1;
1494 #endif
1495 }
1496
1497 static inline double
1498 double_from_foreign_endianness (const union scm_r6rs_ieee754_double *source)
1499 {
1500 union scm_r6rs_ieee754_double result;
1501
1502 #ifdef WORDS_BIGENDIAN
1503 /* Assuming little endian for both byte and word order. */
1504 result.big_endian.negative = source->little_little_endian.negative;
1505 result.big_endian.exponent = source->little_little_endian.exponent;
1506 result.big_endian.mantissa0 = source->little_little_endian.mantissa0;
1507 result.big_endian.mantissa1 = source->little_little_endian.mantissa1;
1508 #else
1509 result.little_little_endian.negative = source->big_endian.negative;
1510 result.little_little_endian.exponent = source->big_endian.exponent;
1511 result.little_little_endian.mantissa0 = source->big_endian.mantissa0;
1512 result.little_little_endian.mantissa1 = source->big_endian.mantissa1;
1513 #endif
1514
1515 return (result.d);
1516 }
1517
1518 /* Template macros to abstract over doubles and floats.
1519 XXX: Guile can only convert to/from doubles. */
1520 #define IEEE754_UNION(_c_type) union scm_r6rs_ieee754_ ## _c_type
1521 #define IEEE754_TO_SCM(_c_type) scm_from_double
1522 #define IEEE754_FROM_SCM(_c_type) scm_to_double
1523 #define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
1524 _c_type ## _from_foreign_endianness
1525 #define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
1526 _c_type ## _to_foreign_endianness
1527
1528
1529 /* Templace getters and setters. */
1530
1531 #define IEEE754_ACCESSOR_PROLOGUE(_type) \
1532 INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
1533
1534 #define IEEE754_REF(_type) \
1535 _type c_result; \
1536 \
1537 IEEE754_ACCESSOR_PROLOGUE (_type); \
1538 SCM_VALIDATE_SYMBOL (3, endianness); \
1539 \
1540 if (scm_is_eq (endianness, native_endianness)) \
1541 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1542 else \
1543 { \
1544 IEEE754_UNION (_type) c_raw; \
1545 \
1546 memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
1547 c_result = \
1548 IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
1549 } \
1550 \
1551 return (IEEE754_TO_SCM (_type) (c_result));
1552
1553 #define IEEE754_NATIVE_REF(_type) \
1554 _type c_result; \
1555 \
1556 IEEE754_ACCESSOR_PROLOGUE (_type); \
1557 \
1558 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1559 return (IEEE754_TO_SCM (_type) (c_result));
1560
1561 #define IEEE754_SET(_type) \
1562 _type c_value; \
1563 \
1564 IEEE754_ACCESSOR_PROLOGUE (_type); \
1565 SCM_VALIDATE_REAL (3, value); \
1566 SCM_VALIDATE_SYMBOL (4, endianness); \
1567 c_value = IEEE754_FROM_SCM (_type) (value); \
1568 \
1569 if (scm_is_eq (endianness, native_endianness)) \
1570 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1571 else \
1572 { \
1573 IEEE754_UNION (_type) c_raw; \
1574 \
1575 IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
1576 memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
1577 } \
1578 \
1579 return SCM_UNSPECIFIED;
1580
1581 #define IEEE754_NATIVE_SET(_type) \
1582 _type c_value; \
1583 \
1584 IEEE754_ACCESSOR_PROLOGUE (_type); \
1585 SCM_VALIDATE_REAL (3, value); \
1586 c_value = IEEE754_FROM_SCM (_type) (value); \
1587 \
1588 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1589 return SCM_UNSPECIFIED;
1590
1591
1592 /* Single precision. */
1593
1594 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_ref,
1595 "bytevector-ieee-single-ref",
1596 3, 0, 0,
1597 (SCM bv, SCM index, SCM endianness),
1598 "Return the IEEE-754 single from @var{bv} at "
1599 "@var{index}.")
1600 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_ref
1601 {
1602 IEEE754_REF (float);
1603 }
1604 #undef FUNC_NAME
1605
1606 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_native_ref,
1607 "bytevector-ieee-single-native-ref",
1608 2, 0, 0,
1609 (SCM bv, SCM index),
1610 "Return the IEEE-754 single from @var{bv} at "
1611 "@var{index} using the native endianness.")
1612 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_native_ref
1613 {
1614 IEEE754_NATIVE_REF (float);
1615 }
1616 #undef FUNC_NAME
1617
1618 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_set_x,
1619 "bytevector-ieee-single-set!",
1620 4, 0, 0,
1621 (SCM bv, SCM index, SCM value, SCM endianness),
1622 "Store real @var{value} in @var{bv} at @var{index} according to "
1623 "@var{endianness}.")
1624 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_set_x
1625 {
1626 IEEE754_SET (float);
1627 }
1628 #undef FUNC_NAME
1629
1630 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_native_set_x,
1631 "bytevector-ieee-single-native-set!",
1632 3, 0, 0,
1633 (SCM bv, SCM index, SCM value),
1634 "Store the real @var{value} at index @var{index} "
1635 "of @var{bv} using the native endianness.")
1636 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_native_set_x
1637 {
1638 IEEE754_NATIVE_SET (float);
1639 }
1640 #undef FUNC_NAME
1641
1642
1643 /* Double precision. */
1644
1645 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_ref,
1646 "bytevector-ieee-double-ref",
1647 3, 0, 0,
1648 (SCM bv, SCM index, SCM endianness),
1649 "Return the IEEE-754 double from @var{bv} at "
1650 "@var{index}.")
1651 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_ref
1652 {
1653 IEEE754_REF (double);
1654 }
1655 #undef FUNC_NAME
1656
1657 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_native_ref,
1658 "bytevector-ieee-double-native-ref",
1659 2, 0, 0,
1660 (SCM bv, SCM index),
1661 "Return the IEEE-754 double from @var{bv} at "
1662 "@var{index} using the native endianness.")
1663 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_native_ref
1664 {
1665 IEEE754_NATIVE_REF (double);
1666 }
1667 #undef FUNC_NAME
1668
1669 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_set_x,
1670 "bytevector-ieee-double-set!",
1671 4, 0, 0,
1672 (SCM bv, SCM index, SCM value, SCM endianness),
1673 "Store real @var{value} in @var{bv} at @var{index} according to "
1674 "@var{endianness}.")
1675 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_set_x
1676 {
1677 IEEE754_SET (double);
1678 }
1679 #undef FUNC_NAME
1680
1681 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_native_set_x,
1682 "bytevector-ieee-double-native-set!",
1683 3, 0, 0,
1684 (SCM bv, SCM index, SCM value),
1685 "Store the real @var{value} at index @var{index} "
1686 "of @var{bv} using the native endianness.")
1687 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_native_set_x
1688 {
1689 IEEE754_NATIVE_SET (double);
1690 }
1691 #undef FUNC_NAME
1692
1693
1694 #undef IEEE754_UNION
1695 #undef IEEE754_TO_SCM
1696 #undef IEEE754_FROM_SCM
1697 #undef IEEE754_FROM_FOREIGN_ENDIANNESS
1698 #undef IEEE754_TO_FOREIGN_ENDIANNESS
1699 #undef IEEE754_REF
1700 #undef IEEE754_NATIVE_REF
1701 #undef IEEE754_SET
1702 #undef IEEE754_NATIVE_SET
1703
1704 \f
1705 /* Operations on strings. */
1706
1707
1708 /* Produce a function that returns the length of a UTF-encoded string. */
1709 #define UTF_STRLEN_FUNCTION(_utf_width) \
1710 static inline size_t \
1711 utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
1712 { \
1713 size_t len = 0; \
1714 const uint ## _utf_width ## _t *ptr; \
1715 for (ptr = str; \
1716 *ptr != 0; \
1717 ptr++) \
1718 { \
1719 len++; \
1720 } \
1721 \
1722 return (len * ((_utf_width) / 8)); \
1723 }
1724
1725 UTF_STRLEN_FUNCTION (8)
1726
1727
1728 /* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
1729 #define UTF_STRLEN(_utf_width, _str) \
1730 utf ## _utf_width ## _strlen (_str)
1731
1732 /* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
1733 ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
1734 encoding name). */
1735 static inline void
1736 utf_encoding_name (char *name, size_t utf_width, SCM endianness)
1737 {
1738 strcpy (name, "UTF-");
1739 strcat (name, ((utf_width == 8)
1740 ? "8"
1741 : ((utf_width == 16)
1742 ? "16"
1743 : ((utf_width == 32)
1744 ? "32"
1745 : "??"))));
1746 strcat (name,
1747 ((scm_is_eq (endianness, scm_sym_big))
1748 ? "BE"
1749 : ((scm_is_eq (endianness, scm_sym_little))
1750 ? "LE"
1751 : "unknown")));
1752 }
1753
1754 /* Maximum length of a UTF encoding name. */
1755 #define MAX_UTF_ENCODING_NAME_LEN 16
1756
1757 /* Produce the body of a `string->utf' function. */
1758 #define STRING_TO_UTF(_utf_width) \
1759 SCM utf; \
1760 int err; \
1761 char *c_str; \
1762 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1763 char *c_utf = NULL, *c_locale; \
1764 size_t c_strlen, c_raw_strlen, c_utf_len = 0; \
1765 \
1766 SCM_VALIDATE_STRING (1, str); \
1767 if (endianness == SCM_UNDEFINED) \
1768 endianness = scm_sym_big; \
1769 else \
1770 SCM_VALIDATE_SYMBOL (2, endianness); \
1771 \
1772 c_strlen = scm_c_string_length (str); \
1773 c_raw_strlen = c_strlen * ((_utf_width) / 8); \
1774 do \
1775 { \
1776 c_str = (char *) alloca (c_raw_strlen + 1); \
1777 c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \
1778 } \
1779 while (c_raw_strlen > c_strlen); \
1780 c_str[c_raw_strlen] = '\0'; \
1781 \
1782 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1783 \
1784 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1785 strcpy (c_locale, locale_charset ()); \
1786 \
1787 err = mem_iconveh (c_str, c_raw_strlen, \
1788 c_locale, c_utf_name, \
1789 iconveh_question_mark, NULL, \
1790 &c_utf, &c_utf_len); \
1791 if (SCM_UNLIKELY (err)) \
1792 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1793 scm_list_1 (str), err); \
1794 else \
1795 /* C_UTF is null-terminated. */ \
1796 utf = scm_r6rs_c_take_bytevector ((signed char *) c_utf, \
1797 c_utf_len); \
1798 \
1799 return (utf);
1800
1801
1802
1803 SCM_DEFINE (scm_r6rs_string_to_utf8, "string->utf8",
1804 1, 0, 0,
1805 (SCM str),
1806 "Return a newly allocated bytevector that contains the UTF-8 "
1807 "encoding of @var{str}.")
1808 #define FUNC_NAME s_scm_r6rs_string_to_utf8
1809 {
1810 SCM utf;
1811 char *c_str;
1812 uint8_t *c_utf;
1813 size_t c_strlen, c_raw_strlen;
1814
1815 SCM_VALIDATE_STRING (1, str);
1816
1817 c_strlen = scm_c_string_length (str);
1818 c_raw_strlen = c_strlen;
1819 do
1820 {
1821 c_str = (char *) alloca (c_raw_strlen + 1);
1822 c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen);
1823 }
1824 while (c_raw_strlen > c_strlen);
1825 c_str[c_raw_strlen] = '\0';
1826
1827 c_utf = u8_strconv_from_locale (c_str);
1828 if (SCM_UNLIKELY (c_utf == NULL))
1829 scm_syserror (FUNC_NAME);
1830 else
1831 /* C_UTF is null-terminated. */
1832 utf = scm_r6rs_c_take_bytevector ((signed char *) c_utf,
1833 UTF_STRLEN (8, c_utf));
1834
1835 return (utf);
1836 }
1837 #undef FUNC_NAME
1838
1839 SCM_DEFINE (scm_r6rs_string_to_utf16, "string->utf16",
1840 1, 1, 0,
1841 (SCM str, SCM endianness),
1842 "Return a newly allocated bytevector that contains the UTF-16 "
1843 "encoding of @var{str}.")
1844 #define FUNC_NAME s_scm_r6rs_string_to_utf16
1845 {
1846 STRING_TO_UTF (16);
1847 }
1848 #undef FUNC_NAME
1849
1850 SCM_DEFINE (scm_r6rs_string_to_utf32, "string->utf32",
1851 1, 1, 0,
1852 (SCM str, SCM endianness),
1853 "Return a newly allocated bytevector that contains the UTF-32 "
1854 "encoding of @var{str}.")
1855 #define FUNC_NAME s_scm_r6rs_string_to_utf32
1856 {
1857 STRING_TO_UTF (32);
1858 }
1859 #undef FUNC_NAME
1860
1861
1862 /* Produce the body of a function that converts a UTF-encoded bytevector to a
1863 string. */
1864 #define UTF_TO_STRING(_utf_width) \
1865 SCM str = SCM_BOOL_F; \
1866 int err; \
1867 char *c_str = NULL, *c_locale; \
1868 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1869 const char *c_utf; \
1870 size_t c_strlen = 0, c_utf_len; \
1871 \
1872 SCM_VALIDATE_R6RS_BYTEVECTOR (1, utf); \
1873 if (endianness == SCM_UNDEFINED) \
1874 endianness = scm_sym_big; \
1875 else \
1876 SCM_VALIDATE_SYMBOL (2, endianness); \
1877 \
1878 c_utf_len = SCM_R6RS_BYTEVECTOR_LENGTH (utf); \
1879 c_utf = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (utf); \
1880 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1881 \
1882 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1883 strcpy (c_locale, locale_charset ()); \
1884 \
1885 err = mem_iconveh (c_utf, c_utf_len, \
1886 c_utf_name, c_locale, \
1887 iconveh_question_mark, NULL, \
1888 &c_str, &c_strlen); \
1889 if (SCM_UNLIKELY (err)) \
1890 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
1891 scm_list_1 (utf), err); \
1892 else \
1893 /* C_STR is null-terminated. */ \
1894 str = scm_take_locale_stringn (c_str, c_strlen); \
1895 \
1896 return (str);
1897
1898
1899 SCM_DEFINE (scm_r6rs_utf8_to_string, "utf8->string",
1900 1, 0, 0,
1901 (SCM utf),
1902 "Return a newly allocate string that contains from the UTF-8-"
1903 "encoded contents of bytevector @var{utf}.")
1904 #define FUNC_NAME s_scm_r6rs_utf8_to_string
1905 {
1906 SCM str;
1907 int err;
1908 char *c_str = NULL, *c_locale;
1909 const char *c_utf;
1910 size_t c_utf_len, c_strlen = 0;
1911
1912 SCM_VALIDATE_R6RS_BYTEVECTOR (1, utf);
1913
1914 c_utf_len = SCM_R6RS_BYTEVECTOR_LENGTH (utf);
1915
1916 c_locale = (char *) alloca (strlen (locale_charset ()) + 1);
1917 strcpy (c_locale, locale_charset ());
1918
1919 c_utf = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (utf);
1920 err = mem_iconveh (c_utf, c_utf_len,
1921 "UTF-8", c_locale,
1922 iconveh_question_mark, NULL,
1923 &c_str, &c_strlen);
1924 if (SCM_UNLIKELY (err))
1925 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A",
1926 scm_list_1 (utf), err);
1927 else
1928 /* C_STR is null-terminated. */
1929 str = scm_take_locale_stringn (c_str, c_strlen);
1930
1931 return (str);
1932 }
1933 #undef FUNC_NAME
1934
1935 SCM_DEFINE (scm_r6rs_utf16_to_string, "utf16->string",
1936 1, 1, 0,
1937 (SCM utf, SCM endianness),
1938 "Return a newly allocate string that contains from the UTF-17-"
1939 "encoded contents of bytevector @var{utf}.")
1940 #define FUNC_NAME s_scm_r6rs_utf16_to_string
1941 {
1942 UTF_TO_STRING (16);
1943 }
1944 #undef FUNC_NAME
1945
1946 SCM_DEFINE (scm_r6rs_utf32_to_string, "utf32->string",
1947 1, 1, 0,
1948 (SCM utf, SCM endianness),
1949 "Return a newly allocate string that contains from the UTF-17-"
1950 "encoded contents of bytevector @var{utf}.")
1951 #define FUNC_NAME s_scm_r6rs_utf32_to_string
1952 {
1953 UTF_TO_STRING (32);
1954 }
1955 #undef FUNC_NAME
1956
1957
1958 \f
1959 /* Initialization. */
1960
1961 void
1962 scm_init_r6rs_bytevector (void)
1963 {
1964 #include "bytevector.x"
1965
1966 #ifdef WORDS_BIGENDIAN
1967 native_endianness = scm_sym_big;
1968 #else
1969 native_endianness = scm_sym_little;
1970 #endif
1971
1972 scm_r6rs_endianness_big = scm_sym_big;
1973 scm_r6rs_endianness_little = scm_sym_little;
1974
1975 scm_r6rs_null_bytevector =
1976 scm_gc_protect_object (make_bytevector_from_buffer (0, NULL));
1977 }
R6RS libraries for GNU Guile