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