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