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