?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Correctly include <config.h>.
[guile-r6rs-libs.git] / src / bytevector.c
blob7a00b0770638e9597ea5a8dee931c54445079bd2
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 /* XXX: There are not only two encodings (big and little endian), as implied
1408 by the API, but rather three (in the case of little endian, there are two
1409 possible word endians, as visible in glibc's <ieee754.h>). When the
1410 endianness is `little', we assume little endian for both the byte order
1411 and the word order. */
1412
1413 /* Convert to/from a floating-point number with different endianness. This
1414 method is probably not the most efficient but it should be portable. */
1415
1416 static inline void
1417 float_to_foreign_endianness (union scm_r6rs_ieee754_float *target,
1418 float source)
1419 {
1420 union scm_r6rs_ieee754_float src;
1421
1422 src.f = source;
1423
1424 #ifdef WORDS_BIGENDIAN
1425 /* Assuming little endian for both byte and word order. */
1426 target->little_endian.negative = src.big_endian.negative;
1427 target->little_endian.exponent = src.big_endian.exponent;
1428 target->little_endian.mantissa = src.big_endian.mantissa;
1429 #else
1430 target->big_endian.negative = src.little_endian.negative;
1431 target->big_endian.exponent = src.little_endian.exponent;
1432 target->big_endian.mantissa = src.little_endian.mantissa;
1433 #endif
1434 }
1435
1436 static inline float
1437 float_from_foreign_endianness (const union scm_r6rs_ieee754_float *source)
1438 {
1439 union scm_r6rs_ieee754_float result;
1440
1441 #ifdef WORDS_BIGENDIAN
1442 /* Assuming little endian for both byte and word order. */
1443 result.big_endian.negative = source->little_endian.negative;
1444 result.big_endian.exponent = source->little_endian.exponent;
1445 result.big_endian.mantissa = source->little_endian.mantissa;
1446 #else
1447 result.little_endian.negative = source->big_endian.negative;
1448 result.little_endian.exponent = source->big_endian.exponent;
1449 result.little_endian.mantissa = source->big_endian.mantissa;
1450 #endif
1451
1452 return (result.f);
1453 }
1454
1455 static inline void
1456 double_to_foreign_endianness (union scm_r6rs_ieee754_double *target,
1457 double source)
1458 {
1459 union scm_r6rs_ieee754_double src;
1460
1461 src.d = source;
1462
1463 #ifdef WORDS_BIGENDIAN
1464 /* Assuming little endian for both byte and word order. */
1465 target->little_little_endian.negative = src.big_endian.negative;
1466 target->little_little_endian.exponent = src.big_endian.exponent;
1467 target->little_little_endian.mantissa0 = src.big_endian.mantissa0;
1468 target->little_little_endian.mantissa1 = src.big_endian.mantissa1;
1469 #else
1470 target->big_endian.negative = src.little_little_endian.negative;
1471 target->big_endian.exponent = src.little_little_endian.exponent;
1472 target->big_endian.mantissa0 = src.little_little_endian.mantissa0;
1473 target->big_endian.mantissa1 = src.little_little_endian.mantissa1;
1474 #endif
1475 }
1476
1477 static inline double
1478 double_from_foreign_endianness (const union scm_r6rs_ieee754_double *source)
1479 {
1480 union scm_r6rs_ieee754_double result;
1481
1482 #ifdef WORDS_BIGENDIAN
1483 /* Assuming little endian for both byte and word order. */
1484 result.big_endian.negative = source->little_little_endian.negative;
1485 result.big_endian.exponent = source->little_little_endian.exponent;
1486 result.big_endian.mantissa0 = source->little_little_endian.mantissa0;
1487 result.big_endian.mantissa1 = source->little_little_endian.mantissa1;
1488 #else
1489 result.little_little_endian.negative = source->big_endian.negative;
1490 result.little_little_endian.exponent = source->big_endian.exponent;
1491 result.little_little_endian.mantissa0 = source->big_endian.mantissa0;
1492 result.little_little_endian.mantissa1 = source->big_endian.mantissa1;
1493 #endif
1494
1495 return (result.d);
1496 }
1497
1498 /* Template macros to abstract over doubles and floats.
1499 XXX: Guile can only convert to/from doubles. */
1500 #define IEEE754_UNION(_c_type) union scm_r6rs_ieee754_ ## _c_type
1501 #define IEEE754_TO_SCM(_c_type) scm_from_double
1502 #define IEEE754_FROM_SCM(_c_type) scm_to_double
1503 #define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
1504 _c_type ## _from_foreign_endianness
1505 #define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
1506 _c_type ## _to_foreign_endianness
1507
1508
1509 /* Templace getters and setters. */
1510
1511 #define IEEE754_ACCESSOR_PROLOGUE(_type) \
1512 INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
1513
1514 #define IEEE754_REF(_type) \
1515 _type c_result; \
1516 \
1517 IEEE754_ACCESSOR_PROLOGUE (_type); \
1518 SCM_VALIDATE_SYMBOL (3, endianness); \
1519 \
1520 if (scm_is_eq (endianness, native_endianness)) \
1521 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1522 else \
1523 { \
1524 IEEE754_UNION (_type) c_raw; \
1525 \
1526 memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
1527 c_result = \
1528 IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
1529 } \
1530 \
1531 return (IEEE754_TO_SCM (_type) (c_result));
1532
1533 #define IEEE754_NATIVE_REF(_type) \
1534 _type c_result; \
1535 \
1536 IEEE754_ACCESSOR_PROLOGUE (_type); \
1537 \
1538 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1539 return (IEEE754_TO_SCM (_type) (c_result));
1540
1541 #define IEEE754_SET(_type) \
1542 _type c_value; \
1543 \
1544 IEEE754_ACCESSOR_PROLOGUE (_type); \
1545 SCM_VALIDATE_REAL (3, value); \
1546 SCM_VALIDATE_SYMBOL (4, endianness); \
1547 c_value = IEEE754_FROM_SCM (_type) (value); \
1548 \
1549 if (scm_is_eq (endianness, native_endianness)) \
1550 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1551 else \
1552 { \
1553 IEEE754_UNION (_type) c_raw; \
1554 \
1555 IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
1556 memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
1557 } \
1558 \
1559 return SCM_UNSPECIFIED;
1560
1561 #define IEEE754_NATIVE_SET(_type) \
1562 _type c_value; \
1563 \
1564 IEEE754_ACCESSOR_PROLOGUE (_type); \
1565 SCM_VALIDATE_REAL (3, value); \
1566 c_value = IEEE754_FROM_SCM (_type) (value); \
1567 \
1568 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1569 return SCM_UNSPECIFIED;
1570
1571
1572 /* Single precision. */
1573
1574 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_ref,
1575 "bytevector-ieee-single-ref",
1576 3, 0, 0,
1577 (SCM bv, SCM index, SCM endianness),
1578 "Return the IEEE-754 single from @var{bv} at "
1579 "@var{index}.")
1580 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_ref
1581 {
1582 IEEE754_REF (float);
1583 }
1584 #undef FUNC_NAME
1585
1586 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_native_ref,
1587 "bytevector-ieee-single-native-ref",
1588 2, 0, 0,
1589 (SCM bv, SCM index),
1590 "Return the IEEE-754 single from @var{bv} at "
1591 "@var{index} using the native endianness.")
1592 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_native_ref
1593 {
1594 IEEE754_NATIVE_REF (float);
1595 }
1596 #undef FUNC_NAME
1597
1598 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_set_x,
1599 "bytevector-ieee-single-set!",
1600 4, 0, 0,
1601 (SCM bv, SCM index, SCM value, SCM endianness),
1602 "Store real @var{value} in @var{bv} at @var{index} according to "
1603 "@var{endianness}.")
1604 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_set_x
1605 {
1606 IEEE754_SET (float);
1607 }
1608 #undef FUNC_NAME
1609
1610 SCM_DEFINE (scm_r6rs_bytevector_ieee_single_native_set_x,
1611 "bytevector-ieee-single-native-set!",
1612 3, 0, 0,
1613 (SCM bv, SCM index, SCM value),
1614 "Store the real @var{value} at index @var{index} "
1615 "of @var{bv} using the native endianness.")
1616 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_single_native_set_x
1617 {
1618 IEEE754_NATIVE_SET (float);
1619 }
1620 #undef FUNC_NAME
1621
1622
1623 /* Double precision. */
1624
1625 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_ref,
1626 "bytevector-ieee-double-ref",
1627 3, 0, 0,
1628 (SCM bv, SCM index, SCM endianness),
1629 "Return the IEEE-754 double from @var{bv} at "
1630 "@var{index}.")
1631 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_ref
1632 {
1633 IEEE754_REF (double);
1634 }
1635 #undef FUNC_NAME
1636
1637 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_native_ref,
1638 "bytevector-ieee-double-native-ref",
1639 2, 0, 0,
1640 (SCM bv, SCM index),
1641 "Return the IEEE-754 double from @var{bv} at "
1642 "@var{index} using the native endianness.")
1643 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_native_ref
1644 {
1645 IEEE754_NATIVE_REF (double);
1646 }
1647 #undef FUNC_NAME
1648
1649 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_set_x,
1650 "bytevector-ieee-double-set!",
1651 4, 0, 0,
1652 (SCM bv, SCM index, SCM value, SCM endianness),
1653 "Store real @var{value} in @var{bv} at @var{index} according to "
1654 "@var{endianness}.")
1655 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_set_x
1656 {
1657 IEEE754_SET (double);
1658 }
1659 #undef FUNC_NAME
1660
1661 SCM_DEFINE (scm_r6rs_bytevector_ieee_double_native_set_x,
1662 "bytevector-ieee-double-native-set!",
1663 3, 0, 0,
1664 (SCM bv, SCM index, SCM value),
1665 "Store the real @var{value} at index @var{index} "
1666 "of @var{bv} using the native endianness.")
1667 #define FUNC_NAME s_scm_r6rs_bytevector_ieee_double_native_set_x
1668 {
1669 IEEE754_NATIVE_SET (double);
1670 }
1671 #undef FUNC_NAME
1672
1673
1674 #undef IEEE754_UNION
1675 #undef IEEE754_TO_SCM
1676 #undef IEEE754_FROM_SCM
1677 #undef IEEE754_FROM_FOREIGN_ENDIANNESS
1678 #undef IEEE754_TO_FOREIGN_ENDIANNESS
1679 #undef IEEE754_REF
1680 #undef IEEE754_NATIVE_REF
1681 #undef IEEE754_SET
1682 #undef IEEE754_NATIVE_SET
1683
1684 \f
1685 /* Operations on strings. */
1686
1687
1688 /* Produce a function that returns the length of a UTF-encoded string. */
1689 #define UTF_STRLEN_FUNCTION(_utf_width) \
1690 static inline size_t \
1691 utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
1692 { \
1693 size_t len = 0; \
1694 const uint ## _utf_width ## _t *ptr; \
1695 for (ptr = str; \
1696 *ptr != 0; \
1697 ptr++) \
1698 { \
1699 len++; \
1700 } \
1701 \
1702 return (len * ((_utf_width) / 8)); \
1703 }
1704
1705 UTF_STRLEN_FUNCTION (8)
1706
1707
1708 /* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
1709 #define UTF_STRLEN(_utf_width, _str) \
1710 utf ## _utf_width ## _strlen (_str)
1711
1712 /* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
1713 ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
1714 encoding name). */
1715 static inline void
1716 utf_encoding_name (char *name, size_t utf_width, SCM endianness)
1717 {
1718 strcpy (name, "UTF-");
1719 strcat (name, ((utf_width == 8)
1720 ? "8"
1721 : ((utf_width == 16)
1722 ? "16"
1723 : ((utf_width == 32)
1724 ? "32"
1725 : "??"))));
1726 strcat (name,
1727 ((scm_is_eq (endianness, scm_sym_big))
1728 ? "BE"
1729 : ((scm_is_eq (endianness, scm_sym_little))
1730 ? "LE"
1731 : "unknown")));
1732 }
1733
1734 /* Maximum length of a UTF encoding name. */
1735 #define MAX_UTF_ENCODING_NAME_LEN 16
1736
1737 /* Produce the body of a `string->utf' function. */
1738 #define STRING_TO_UTF(_utf_width) \
1739 SCM utf; \
1740 int err; \
1741 char *c_str; \
1742 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1743 char *c_utf = NULL, *c_locale; \
1744 size_t c_strlen, c_raw_strlen, c_utf_len = 0; \
1745 \
1746 SCM_VALIDATE_STRING (1, str); \
1747 if (endianness == SCM_UNDEFINED) \
1748 endianness = scm_sym_big; \
1749 else \
1750 SCM_VALIDATE_SYMBOL (2, endianness); \
1751 \
1752 c_strlen = scm_c_string_length (str); \
1753 c_raw_strlen = c_strlen * ((_utf_width) / 8); \
1754 do \
1755 { \
1756 c_str = (char *) alloca (c_raw_strlen + 1); \
1757 c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \
1758 } \
1759 while (c_raw_strlen > c_strlen); \
1760 c_str[c_raw_strlen] = '\0'; \
1761 \
1762 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1763 \
1764 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1765 strcpy (c_locale, locale_charset ()); \
1766 \
1767 err = mem_iconveh (c_str, c_raw_strlen, \
1768 c_locale, c_utf_name, \
1769 iconveh_question_mark, NULL, \
1770 &c_utf, &c_utf_len); \
1771 if (EXPECT_FALSE (err)) \
1772 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1773 scm_list_1 (str), err); \
1774 else \
1775 /* C_UTF is null-terminated. */ \
1776 utf = scm_r6rs_c_take_bytevector ((signed char *) c_utf, \
1777 c_utf_len); \
1778 \
1779 return (utf);
1780
1781
1782
1783 SCM_DEFINE (scm_r6rs_string_to_utf8, "string->utf8",
1784 1, 0, 0,
1785 (SCM str),
1786 "Return a newly allocated bytevector that contains the UTF-8 "
1787 "encoding of @var{str}.")
1788 #define FUNC_NAME s_scm_r6rs_string_to_utf8
1789 {
1790 SCM utf;
1791 char *c_str;
1792 uint8_t *c_utf;
1793 size_t c_strlen, c_raw_strlen;
1794
1795 SCM_VALIDATE_STRING (1, str);
1796
1797 c_strlen = scm_c_string_length (str);
1798 c_raw_strlen = c_strlen;
1799 do
1800 {
1801 c_str = (char *) alloca (c_raw_strlen + 1);
1802 c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen);
1803 }
1804 while (c_raw_strlen > c_strlen);
1805 c_str[c_raw_strlen] = '\0';
1806
1807 c_utf = u8_strconv_from_locale (c_str);
1808 if (EXPECT_FALSE (c_utf == NULL))
1809 scm_syserror (FUNC_NAME);
1810 else
1811 /* C_UTF is null-terminated. */
1812 utf = scm_r6rs_c_take_bytevector ((signed char *) c_utf,
1813 UTF_STRLEN (8, c_utf));
1814
1815 return (utf);
1816 }
1817 #undef FUNC_NAME
1818
1819 SCM_DEFINE (scm_r6rs_string_to_utf16, "string->utf16",
1820 1, 1, 0,
1821 (SCM str, SCM endianness),
1822 "Return a newly allocated bytevector that contains the UTF-16 "
1823 "encoding of @var{str}.")
1824 #define FUNC_NAME s_scm_r6rs_string_to_utf16
1825 {
1826 STRING_TO_UTF (16);
1827 }
1828 #undef FUNC_NAME
1829
1830 SCM_DEFINE (scm_r6rs_string_to_utf32, "string->utf32",
1831 1, 1, 0,
1832 (SCM str, SCM endianness),
1833 "Return a newly allocated bytevector that contains the UTF-32 "
1834 "encoding of @var{str}.")
1835 #define FUNC_NAME s_scm_r6rs_string_to_utf32
1836 {
1837 STRING_TO_UTF (32);
1838 }
1839 #undef FUNC_NAME
1840
1841
1842 /* Produce the body of a function that converts a UTF-encoded bytevector to a
1843 string. */
1844 #define UTF_TO_STRING(_utf_width) \
1845 SCM str = SCM_BOOL_F; \
1846 int err; \
1847 char *c_str = NULL, *c_locale; \
1848 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1849 const char *c_utf; \
1850 size_t c_strlen = 0, c_utf_len; \
1851 \
1852 SCM_VALIDATE_R6RS_BYTEVECTOR (1, utf); \
1853 if (endianness == SCM_UNDEFINED) \
1854 endianness = scm_sym_big; \
1855 else \
1856 SCM_VALIDATE_SYMBOL (2, endianness); \
1857 \
1858 c_utf_len = SCM_R6RS_BYTEVECTOR_LENGTH (utf); \
1859 c_utf = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (utf); \
1860 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1861 \
1862 c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
1863 strcpy (c_locale, locale_charset ()); \
1864 \
1865 err = mem_iconveh (c_utf, c_utf_len, \
1866 c_utf_name, c_locale, \
1867 iconveh_question_mark, NULL, \
1868 &c_str, &c_strlen); \
1869 if (EXPECT_FALSE (err)) \
1870 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
1871 scm_list_1 (utf), err); \
1872 else \
1873 /* C_STR is null-terminated. */ \
1874 str = scm_take_locale_stringn (c_str, c_strlen); \
1875 \
1876 return (str);
1877
1878
1879 SCM_DEFINE (scm_r6rs_utf8_to_string, "utf8->string",
1880 1, 0, 0,
1881 (SCM utf),
1882 "Return a newly allocate string that contains from the UTF-8-"
1883 "encoded contents of bytevector @var{utf}.")
1884 #define FUNC_NAME s_scm_r6rs_utf8_to_string
1885 {
1886 SCM str;
1887 int err;
1888 char *c_str = NULL, *c_locale;
1889 const char *c_utf;
1890 size_t c_utf_len, c_strlen = 0;
1891
1892 SCM_VALIDATE_R6RS_BYTEVECTOR (1, utf);
1893
1894 c_utf_len = SCM_R6RS_BYTEVECTOR_LENGTH (utf);
1895
1896 c_locale = (char *) alloca (strlen (locale_charset ()) + 1);
1897 strcpy (c_locale, locale_charset ());
1898
1899 c_utf = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (utf);
1900 err = mem_iconveh (c_utf, c_utf_len,
1901 "UTF-8", c_locale,
1902 iconveh_question_mark, NULL,
1903 &c_str, &c_strlen);
1904 if (EXPECT_FALSE (err))
1905 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A",
1906 scm_list_1 (utf), err);
1907 else
1908 /* C_STR is null-terminated. */
1909 str = scm_take_locale_stringn (c_str, c_strlen);
1910
1911 return (str);
1912 }
1913 #undef FUNC_NAME
1914
1915 SCM_DEFINE (scm_r6rs_utf16_to_string, "utf16->string",
1916 1, 1, 0,
1917 (SCM utf, SCM endianness),
1918 "Return a newly allocate string that contains from the UTF-17-"
1919 "encoded contents of bytevector @var{utf}.")
1920 #define FUNC_NAME s_scm_r6rs_utf16_to_string
1921 {
1922 UTF_TO_STRING (16);
1923 }
1924 #undef FUNC_NAME
1925
1926 SCM_DEFINE (scm_r6rs_utf32_to_string, "utf32->string",
1927 1, 1, 0,
1928 (SCM utf, SCM endianness),
1929 "Return a newly allocate string that contains from the UTF-17-"
1930 "encoded contents of bytevector @var{utf}.")
1931 #define FUNC_NAME s_scm_r6rs_utf32_to_string
1932 {
1933 UTF_TO_STRING (32);
1934 }
1935 #undef FUNC_NAME
1936
1937
1938 \f
1939 /* Initialization. */
1940
1941 void
1942 scm_init_r6rs_bytevector (void)
1943 {
1944 #include "bytevector.x"
1945
1946 #ifdef WORDS_BIGENDIAN
1947 native_endianness = scm_sym_big;
1948 #else
1949 native_endianness = scm_sym_little;
1950 #endif
1951
1952 scm_r6rs_null_bytevector =
1953 scm_gc_protect_object (make_bytevector_from_buffer (0, NULL));
1954 }
1955
1956 /* arch-tag: e5a30664-90fc-40d7-8036-ee767aea5fb6
1957 */
R6RS libraries for GNU Guile