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