HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Merge commit 'fdd319e9bd4121d844662d3d8ccc69b462b60840'
[bpt/guile.git] / libguile / bytevectors.c
CommitLineData
856d318a 1/* Copyright (C) 2009-2014 Free Software Foundation, Inc.
1ee2c72e
LC		 2 *
3 * This library is free software; you can redistribute it and/or
53befeb7
NJ		 4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
1ee2c72e 7 *
53befeb7
NJ		 8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
1ee2c72e
LC		 10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
12 *
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
53befeb7
NJ		 15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
16 * 02110-1301 USA
1ee2c72e
LC		 17 */
18
19
20#ifdef HAVE_CONFIG_H
21# include <config.h>
22#endif
23
24#include <alloca.h>
f5a51cae 25#include <assert.h>
1ee2c72e
LC		 26
27#include <gmp.h>
28
29#include "libguile/_scm.h"
cfb4702f 30#include "libguile/extensions.h"
1ee2c72e
LC		 31#include "libguile/bytevectors.h"
32#include "libguile/strings.h"
33#include "libguile/validate.h"
2fa901a5 34#include "libguile/arrays.h"
2a610be5 35#include "libguile/array-handle.h"
476b894c 36#include "libguile/uniform.h"
782a82ee 37#include "libguile/srfi-4.h"
1ee2c72e
LC		 38
39#include <byteswap.h>
40#include <striconveh.h>
41#include <uniconv.h>
3a5bc4fa 42#include <unistr.h>
1ee2c72e
LC		 43
44#ifdef HAVE_LIMITS_H
45# include <limits.h>
46#else
47/* Assuming 32-bit longs. */
48# define ULONG_MAX 4294967295UL
49#endif
50
51#include <string.h>
52
53
54\f
55/* Utilities. */
56
57/* Convenience macros. These are used by the various templates (macros) that
58 are parameterized by integer signedness. */
59#define INT8_T_signed scm_t_int8
60#define INT8_T_unsigned scm_t_uint8
61#define INT16_T_signed scm_t_int16
62#define INT16_T_unsigned scm_t_uint16
63#define INT32_T_signed scm_t_int32
64#define INT32_T_unsigned scm_t_uint32
65#define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L))
66#define is_unsigned_int8(_x) ((_x) <= 255UL)
67#define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
68#define is_unsigned_int16(_x) ((_x) <= 65535UL)
69#define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L))
70#define is_unsigned_int32(_x) ((_x) <= 4294967295UL)
71#define SIGNEDNESS_signed 1
72#define SIGNEDNESS_unsigned 0
73
74#define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign
75#define INT_SWAP(_size) bswap_ ## _size
76#define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
77#define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
78
79
80#define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \
2d34e924 81 size_t c_len, c_index; \
1ee2c72e
LC		 82 _sign char *c_bv; \
83 \
84 SCM_VALIDATE_BYTEVECTOR (1, bv); \
85 c_index = scm_to_uint (index); \
86 \
87 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
88 c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \
89 \
90 if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
91 scm_out_of_range (FUNC_NAME, index);
92
93/* Template for fixed-size integer access (only 8, 16 or 32-bit). */
caa92f5e
AW		 94#define INTEGER_REF(_len, _sign) \
95 SCM result; \
96 \
97 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
98 SCM_VALIDATE_SYMBOL (3, endianness); \
99 \
100 { \
101 INT_TYPE (_len, _sign) c_result; \
102 \
103 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
104 if (!scm_is_eq (endianness, scm_i_native_endianness)) \
105 c_result = INT_SWAP (_len) (c_result); \
106 \
107 result = SCM_I_MAKINUM (c_result); \
108 } \
109 \
1ee2c72e
LC		 110 return result;
111
112/* Template for fixed-size integer access using the native endianness. */
113#define INTEGER_NATIVE_REF(_len, _sign) \
114 SCM result; \
115 \
116 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
117 \
118 { \
119 INT_TYPE (_len, _sign) c_result; \
120 \
121 memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
122 result = SCM_I_MAKINUM (c_result); \
123 } \
124 \
125 return result;
126
127/* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
128#define INTEGER_SET(_len, _sign) \
129 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
130 SCM_VALIDATE_SYMBOL (3, endianness); \
131 \
132 { \
e25f3727 133 scm_t_signed_bits c_value; \
1ee2c72e
LC		 134 INT_TYPE (_len, _sign) c_value_short; \
135 \
136 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
137 scm_wrong_type_arg (FUNC_NAME, 3, value); \
138 \
139 c_value = SCM_I_INUM (value); \
140 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
141 scm_out_of_range (FUNC_NAME, value); \
142 \
143 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
caa92f5e 144 if (!scm_is_eq (endianness, scm_i_native_endianness)) \
1ee2c72e
LC		 145 c_value_short = INT_SWAP (_len) (c_value_short); \
146 \
147 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
148 } \
149 \
150 return SCM_UNSPECIFIED;
151
152/* Template for fixed-size integer modification using the native
153 endianness. */
154#define INTEGER_NATIVE_SET(_len, _sign) \
155 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
156 \
157 { \
e25f3727 158 scm_t_signed_bits c_value; \
1ee2c72e
LC		 159 INT_TYPE (_len, _sign) c_value_short; \
160 \
161 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
162 scm_wrong_type_arg (FUNC_NAME, 3, value); \
163 \
164 c_value = SCM_I_INUM (value); \
165 if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
166 scm_out_of_range (FUNC_NAME, value); \
167 \
168 c_value_short = (INT_TYPE (_len, _sign)) c_value; \
169 \
170 memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
171 } \
172 \
173 return SCM_UNSPECIFIED;
174
175
176\f
177/* Bytevector type. */
178
0665b3ff 179#define SCM_BYTEVECTOR_HEADER_BYTES \
3b08b1c2 180 (SCM_BYTEVECTOR_HEADER_SIZE * sizeof (scm_t_bits))
0665b3ff 181
f332089e 182#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
807e5a66 183 SCM_SET_CELL_WORD_1 ((_bv), (scm_t_bits) (_len))
3fe87cf7
LC		 184#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _contents) \
185 SCM_SET_CELL_WORD_2 ((_bv), (scm_t_bits) (_contents))
186#define SCM_BYTEVECTOR_SET_CONTIGUOUS_P(bv, contiguous_p) \
187 SCM_SET_BYTEVECTOR_FLAGS ((bv), \
188 SCM_BYTEVECTOR_ELEMENT_TYPE (bv) \
189 | ((contiguous_p) << 8UL))
190
191#define SCM_BYTEVECTOR_SET_ELEMENT_TYPE(bv, hint) \
192 SCM_SET_BYTEVECTOR_FLAGS ((bv), \
193 (hint) \
194 | (SCM_BYTEVECTOR_CONTIGUOUS_P (bv) << 8UL))
059a588f
AW		 195#define SCM_BYTEVECTOR_SET_PARENT(_bv, _parent) \
196 SCM_SET_CELL_OBJECT_3 ((_bv), (_parent))
197
e286c973
AW		 198#define SCM_BYTEVECTOR_TYPE_SIZE(var) \
199 (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
200#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
3fe87cf7 201 (SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var))
1ee2c72e
LC		 202
203/* The empty bytevector. */
204SCM scm_null_bytevector = SCM_UNSPECIFIED;
205
206
207static inline SCM
0665b3ff 208make_bytevector (size_t len, scm_t_array_element_type element_type)
1ee2c72e 209{
f332089e 210 SCM ret;
e286c973 211 size_t c_len;
0665b3ff 212
e286c973
AW		 213 if (SCM_UNLIKELY (element_type > SCM_ARRAY_ELEMENT_TYPE_LAST
214 || scm_i_array_element_type_sizes[element_type] < 8
871054f0 215 || len >= (((size_t) -1)
e286c973
AW		 216 / (scm_i_array_element_type_sizes[element_type]/8))))
217 /* This would be an internal Guile programming error */
218 abort ();
0665b3ff
LC		 219
220 if (SCM_UNLIKELY (len == 0 && element_type == SCM_ARRAY_ELEMENT_TYPE_VU8
221 && SCM_BYTEVECTOR_P (scm_null_bytevector)))
222 ret = scm_null_bytevector;
f332089e
AW		 223 else
224 {
3fe87cf7
LC		 225 signed char *contents;
226
0665b3ff
LC		 227 c_len = len * (scm_i_array_element_type_sizes[element_type] / 8);
228
3fe87cf7
LC		 229 contents = scm_gc_malloc_pointerless (SCM_BYTEVECTOR_HEADER_BYTES + c_len,
230 SCM_GC_BYTEVECTOR);
21041372 231 ret = SCM_PACK_POINTER (contents);
3fe87cf7 232 contents += SCM_BYTEVECTOR_HEADER_BYTES;
0665b3ff 233
0665b3ff 234 SCM_BYTEVECTOR_SET_LENGTH (ret, c_len);
3fe87cf7
LC		 235 SCM_BYTEVECTOR_SET_CONTENTS (ret, contents);
236 SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret, 1);
0665b3ff 237 SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
059a588f 238 SCM_BYTEVECTOR_SET_PARENT (ret, SCM_BOOL_F);
f332089e 239 }
0665b3ff 240
f332089e 241 return ret;
1ee2c72e
LC		 242}
243
0665b3ff 244/* Return a bytevector of LEN elements of type ELEMENT_TYPE, with element
3fe87cf7
LC		 245 values taken from CONTENTS. Assume that the storage for CONTENTS will be
246 automatically reclaimed when it becomes unreachable. */
1ee2c72e 247static inline SCM
0665b3ff
LC		 248make_bytevector_from_buffer (size_t len, void *contents,
249 scm_t_array_element_type element_type)
1ee2c72e 250{
0665b3ff 251 SCM ret;
1ee2c72e 252
3fe87cf7
LC		 253 if (SCM_UNLIKELY (len == 0))
254 ret = make_bytevector (len, element_type);
255 else
1ee2c72e 256 {
0665b3ff
LC		 257 size_t c_len;
258
21041372 259 ret = SCM_PACK_POINTER (scm_gc_malloc (SCM_BYTEVECTOR_HEADER_BYTES,
3fe87cf7
LC		 260 SCM_GC_BYTEVECTOR));
261
0665b3ff 262 c_len = len * (scm_i_array_element_type_sizes[element_type] / 8);
0665b3ff 263
3fe87cf7
LC		 264 SCM_BYTEVECTOR_SET_LENGTH (ret, c_len);
265 SCM_BYTEVECTOR_SET_CONTENTS (ret, contents);
266 SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret, 0);
267 SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
059a588f 268 SCM_BYTEVECTOR_SET_PARENT (ret, SCM_BOOL_F);
1ee2c72e 269 }
0665b3ff
LC		 270
271 return ret;
1ee2c72e
LC		 272}
273
0665b3ff 274
1ee2c72e
LC		 275/* Return a new bytevector of size LEN octets. */
276SCM
2d34e924 277scm_c_make_bytevector (size_t len)
1ee2c72e 278{
e286c973
AW		 279 return make_bytevector (len, SCM_ARRAY_ELEMENT_TYPE_VU8);
280}
281
3dc2afe2
AW		 282/* Return a new bytevector of size LEN elements. */
283SCM
284scm_i_make_typed_bytevector (size_t len, scm_t_array_element_type element_type)
285{
286 return make_bytevector (len, element_type);
287}
288
059a588f
AW		 289/* Return a bytevector of size LEN made up of CONTENTS. The area
290 pointed to by CONTENTS must be protected from GC somehow: either
291 because it was allocated using `scm_gc_malloc ()', or because it is
292 part of PARENT. */
1ee2c72e 293SCM
8b66aa8f 294scm_c_take_gc_bytevector (signed char *contents, size_t len, SCM parent)
1ee2c72e 295{
059a588f
AW		 296 SCM ret;
297
298 ret = make_bytevector_from_buffer (len, contents, SCM_ARRAY_ELEMENT_TYPE_VU8);
299 SCM_BYTEVECTOR_SET_PARENT (ret, parent);
300
301 return ret;
e286c973 302}
1ee2c72e 303
3dc2afe2
AW		 304SCM
305scm_c_take_typed_bytevector (signed char *contents, size_t len,
059a588f 306 scm_t_array_element_type element_type, SCM parent)
3dc2afe2 307{
059a588f
AW		 308 SCM ret;
309
310 ret = make_bytevector_from_buffer (len, contents, element_type);
311 SCM_BYTEVECTOR_SET_PARENT (ret, parent);
312
313 return ret;
3dc2afe2
AW		 314}
315
1ee2c72e 316/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
0665b3ff 317 size) and return the new bytevector (possibly different from BV). */
1ee2c72e 318SCM
0665b3ff 319scm_c_shrink_bytevector (SCM bv, size_t c_new_len)
1ee2c72e 320{
0665b3ff
LC		 321 SCM new_bv;
322 size_t c_len;
323
e286c973
AW		 324 if (SCM_UNLIKELY (c_new_len % SCM_BYTEVECTOR_TYPE_SIZE (bv)))
325 /* This would be an internal Guile programming error */
326 abort ();
327
0665b3ff
LC		 328 c_len = SCM_BYTEVECTOR_LENGTH (bv);
329 if (SCM_UNLIKELY (c_new_len > c_len))
330 abort ();
1ee2c72e 331
0665b3ff 332 SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
1ee2c72e 333
3fe87cf7 334 if (SCM_BYTEVECTOR_CONTIGUOUS_P (bv))
1baa2159
LC		 335 {
336 signed char *c_bv;
337
338 c_bv = scm_gc_realloc (SCM2PTR (bv),
339 c_len + SCM_BYTEVECTOR_HEADER_BYTES,
340 c_new_len + SCM_BYTEVECTOR_HEADER_BYTES,
341 SCM_GC_BYTEVECTOR);
342 new_bv = PTR2SCM (c_bv);
343 SCM_BYTEVECTOR_SET_CONTENTS (new_bv, c_bv + SCM_BYTEVECTOR_HEADER_BYTES);
344 }
3fe87cf7
LC		 345 else
346 {
347 signed char *c_bv;
348
349 c_bv = scm_gc_realloc (SCM_BYTEVECTOR_CONTENTS (bv),
350 c_len, c_new_len, SCM_GC_BYTEVECTOR);
351 SCM_BYTEVECTOR_SET_CONTENTS (bv, c_bv);
352
353 new_bv = bv;
354 }
1ee2c72e 355
0665b3ff 356 return new_bv;
1ee2c72e
LC		 357}
358
404bb5f8
LC		 359int
360scm_is_bytevector (SCM obj)
361{
807e5a66 362 return SCM_BYTEVECTOR_P (obj);
404bb5f8
LC		 363}
364
365size_t
366scm_c_bytevector_length (SCM bv)
367#define FUNC_NAME "scm_c_bytevector_length"
368{
369 SCM_VALIDATE_BYTEVECTOR (1, bv);
370
371 return SCM_BYTEVECTOR_LENGTH (bv);
372}
373#undef FUNC_NAME
374
375scm_t_uint8
376scm_c_bytevector_ref (SCM bv, size_t index)
377#define FUNC_NAME "scm_c_bytevector_ref"
378{
379 size_t c_len;
380 const scm_t_uint8 *c_bv;
381
382 SCM_VALIDATE_BYTEVECTOR (1, bv);
383
384 c_len = SCM_BYTEVECTOR_LENGTH (bv);
385 c_bv = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bv);
386
387 if (SCM_UNLIKELY (index >= c_len))
388 scm_out_of_range (FUNC_NAME, scm_from_size_t (index));
389
390 return c_bv[index];
391}
392#undef FUNC_NAME
393
394void
395scm_c_bytevector_set_x (SCM bv, size_t index, scm_t_uint8 value)
396#define FUNC_NAME "scm_c_bytevector_set_x"
397{
398 size_t c_len;
399 scm_t_uint8 *c_bv;
400
401 SCM_VALIDATE_BYTEVECTOR (1, bv);
402
403 c_len = SCM_BYTEVECTOR_LENGTH (bv);
404 c_bv = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bv);
405
406 if (SCM_UNLIKELY (index >= c_len))
407 scm_out_of_range (FUNC_NAME, scm_from_size_t (index));
408
409 c_bv[index] = value;
410}
411#undef FUNC_NAME
412
e286c973
AW		 413
414\f
807e5a66
LC		 415int
416scm_i_print_bytevector (SCM bv, SCM port, scm_print_state *pstate SCM_UNUSED)
1ee2c72e 417{
e286c973
AW		 418 ssize_t ubnd, inc, i;
419 scm_t_array_handle h;
420
421 scm_array_get_handle (bv, &h);
1ee2c72e 422
0607ebbf 423 scm_putc_unlocked ('#', port);
e286c973 424 scm_write (scm_array_handle_element_type (&h), port);
0607ebbf 425 scm_putc_unlocked ('(', port);
e286c973
AW		 426 for (i = h.dims[0].lbnd, ubnd = h.dims[0].ubnd, inc = h.dims[0].inc;
427 i <= ubnd; i += inc)
1ee2c72e
LC		 428 {
429 if (i > 0)
0607ebbf 430 scm_putc_unlocked (' ', port);
e286c973 431 scm_write (scm_array_handle_ref (&h, i), port);
1ee2c72e 432 }
0607ebbf 433 scm_putc_unlocked (')', port);
1ee2c72e 434
1ee2c72e
LC		 435 return 1;
436}
437
1ee2c72e
LC		 438\f
439/* General operations. */
440
441SCM_SYMBOL (scm_sym_big, "big");
442SCM_SYMBOL (scm_sym_little, "little");
443
444SCM scm_endianness_big, scm_endianness_little;
445
446/* Host endianness (a symbol). */
caa92f5e 447SCM scm_i_native_endianness = SCM_UNSPECIFIED;
1ee2c72e
LC		 448
449/* Byte-swapping. */
450#ifndef bswap_24
451# define bswap_24(_x) \
452 ((((_x) & 0xff0000) >> 16) | \
453 (((_x) & 0x00ff00)) | \
454 (((_x) & 0x0000ff) << 16))
455#endif
456
457
458SCM_DEFINE (scm_native_endianness, "native-endianness", 0, 0, 0,
459 (void),
460 "Return a symbol denoting the machine's native endianness.")
461#define FUNC_NAME s_scm_native_endianness
462{
caa92f5e 463 return scm_i_native_endianness;
1ee2c72e
LC		 464}
465#undef FUNC_NAME
466
467SCM_DEFINE (scm_bytevector_p, "bytevector?", 1, 0, 0,
468 (SCM obj),
469 "Return true if @var{obj} is a bytevector.")
470#define FUNC_NAME s_scm_bytevector_p
471{
404bb5f8 472 return scm_from_bool (scm_is_bytevector (obj));
1ee2c72e
LC		 473}
474#undef FUNC_NAME
475
476SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0,
477 (SCM len, SCM fill),
478 "Return a newly allocated bytevector of @var{len} bytes, "
479 "optionally filled with @var{fill}.")
480#define FUNC_NAME s_scm_make_bytevector
481{
482 SCM bv;
483 unsigned c_len;
484 signed char c_fill = '\0';
485
486 SCM_VALIDATE_UINT_COPY (1, len, c_len);
d223c3fc 487 if (!scm_is_eq (fill, SCM_UNDEFINED))
1ee2c72e
LC		 488 {
489 int value;
490
491 value = scm_to_int (fill);
492 if (SCM_UNLIKELY ((value < -128) || (value > 255)))
493 scm_out_of_range (FUNC_NAME, fill);
494 c_fill = (signed char) value;
495 }
496
e286c973 497 bv = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
d223c3fc 498 if (!scm_is_eq (fill, SCM_UNDEFINED))
1ee2c72e
LC		 499 {
500 unsigned i;
501 signed char *contents;
502
503 contents = SCM_BYTEVECTOR_CONTENTS (bv);
504 for (i = 0; i < c_len; i++)
505 contents[i] = c_fill;
506 }
3ef6650d
AW		 507 else
508 memset (SCM_BYTEVECTOR_CONTENTS (bv), 0, c_len);
1ee2c72e
LC		 509
510 return bv;
511}
512#undef FUNC_NAME
513
514SCM_DEFINE (scm_bytevector_length, "bytevector-length", 1, 0, 0,
515 (SCM bv),
516 "Return the length (in bytes) of @var{bv}.")
517#define FUNC_NAME s_scm_bytevector_length
518{
404bb5f8 519 return scm_from_uint (scm_c_bytevector_length (bv));
1ee2c72e
LC		 520}
521#undef FUNC_NAME
522
523SCM_DEFINE (scm_bytevector_eq_p, "bytevector=?", 2, 0, 0,
524 (SCM bv1, SCM bv2),
525 "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
526 "have the same length and contents.")
527#define FUNC_NAME s_scm_bytevector_eq_p
528{
529 SCM result = SCM_BOOL_F;
530 unsigned c_len1, c_len2;
531
532 SCM_VALIDATE_BYTEVECTOR (1, bv1);
533 SCM_VALIDATE_BYTEVECTOR (2, bv2);
534
535 c_len1 = SCM_BYTEVECTOR_LENGTH (bv1);
536 c_len2 = SCM_BYTEVECTOR_LENGTH (bv2);
537
a587d6a9
AW		 538 if (c_len1 == c_len2 && (SCM_BYTEVECTOR_ELEMENT_TYPE (bv1)
539 == SCM_BYTEVECTOR_ELEMENT_TYPE (bv2)))
1ee2c72e
LC		 540 {
541 signed char *c_bv1, *c_bv2;
542
543 c_bv1 = SCM_BYTEVECTOR_CONTENTS (bv1);
544 c_bv2 = SCM_BYTEVECTOR_CONTENTS (bv2);
545
546 result = scm_from_bool (!memcmp (c_bv1, c_bv2, c_len1));
547 }
548
549 return result;
550}
551#undef FUNC_NAME
552
553SCM_DEFINE (scm_bytevector_fill_x, "bytevector-fill!", 2, 0, 0,
554 (SCM bv, SCM fill),
555 "Fill bytevector @var{bv} with @var{fill}, a byte.")
556#define FUNC_NAME s_scm_bytevector_fill_x
557{
558 unsigned c_len, i;
559 signed char *c_bv, c_fill;
560
561 SCM_VALIDATE_BYTEVECTOR (1, bv);
562 c_fill = scm_to_int8 (fill);
563
564 c_len = SCM_BYTEVECTOR_LENGTH (bv);
565 c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
566
567 for (i = 0; i < c_len; i++)
568 c_bv[i] = c_fill;
569
570 return SCM_UNSPECIFIED;
571}
572#undef FUNC_NAME
573
574SCM_DEFINE (scm_bytevector_copy_x, "bytevector-copy!", 5, 0, 0,
575 (SCM source, SCM source_start, SCM target, SCM target_start,
576 SCM len),
577 "Copy @var{len} bytes from @var{source} into @var{target}, "
578 "starting reading from @var{source_start} (a positive index "
579 "within @var{source}) and start writing at "
580 "@var{target_start}.")
581#define FUNC_NAME s_scm_bytevector_copy_x
582{
583 unsigned c_len, c_source_len, c_target_len;
584 unsigned c_source_start, c_target_start;
585 signed char *c_source, *c_target;
586
587 SCM_VALIDATE_BYTEVECTOR (1, source);
588 SCM_VALIDATE_BYTEVECTOR (3, target);
589
590 c_len = scm_to_uint (len);
591 c_source_start = scm_to_uint (source_start);
592 c_target_start = scm_to_uint (target_start);
593
594 c_source = SCM_BYTEVECTOR_CONTENTS (source);
595 c_target = SCM_BYTEVECTOR_CONTENTS (target);
596 c_source_len = SCM_BYTEVECTOR_LENGTH (source);
597 c_target_len = SCM_BYTEVECTOR_LENGTH (target);
598
599 if (SCM_UNLIKELY (c_source_start + c_len > c_source_len))
600 scm_out_of_range (FUNC_NAME, source_start);
601 if (SCM_UNLIKELY (c_target_start + c_len > c_target_len))
602 scm_out_of_range (FUNC_NAME, target_start);
603
80719649
LC		 604 memmove (c_target + c_target_start,
605 c_source + c_source_start,
606 c_len);
1ee2c72e
LC		 607
608 return SCM_UNSPECIFIED;
609}
610#undef FUNC_NAME
611
612SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0,
613 (SCM bv),
614 "Return a newly allocated copy of @var{bv}.")
615#define FUNC_NAME s_scm_bytevector_copy
616{
617 SCM copy;
618 unsigned c_len;
619 signed char *c_bv, *c_copy;
620
621 SCM_VALIDATE_BYTEVECTOR (1, bv);
622
623 c_len = SCM_BYTEVECTOR_LENGTH (bv);
624 c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
625
10679f4c 626 copy = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
1ee2c72e
LC		 627 c_copy = SCM_BYTEVECTOR_CONTENTS (copy);
628 memcpy (c_copy, c_bv, c_len);
629
630 return copy;
631}
632#undef FUNC_NAME
633
782a82ee
AW		 634SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector",
635 1, 0, 0, (SCM array),
636 "Return a newly allocated bytevector whose contents\n"
637 "will be copied from the uniform array @var{array}.")
638#define FUNC_NAME s_scm_uniform_array_to_bytevector
639{
640 SCM contents, ret;
f5a51cae 641 size_t len, sz, byte_len;
782a82ee 642 scm_t_array_handle h;
f5a51cae 643 const void *elts;
782a82ee
AW		 644
645 contents = scm_array_contents (array, SCM_BOOL_T);
646 if (scm_is_false (contents))
647 scm_wrong_type_arg_msg (FUNC_NAME, 0, array, "uniform contiguous array");
648
649 scm_array_get_handle (contents, &h);
f5a51cae 650 assert (h.base == 0);
782a82ee 651
f5a51cae 652 elts = h.elements;
782a82ee 653 len = h.dims->inc * (h.dims->ubnd - h.dims->lbnd + 1);
f5a51cae
AW		 654 sz = scm_array_handle_uniform_element_bit_size (&h);
655 if (sz >= 8 && ((sz % 8) == 0))
656 byte_len = len * (sz / 8);
b0fae4ec 657 else if (sz < 8)
d65514a2
AW		 658 /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
659 units. */
660 byte_len = ((len * sz + 31) / 32) * 4;
b0fae4ec
AW		 661 else
662 /* an internal guile error, really */
663 SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL);
782a82ee 664
f5a51cae
AW		 665 ret = make_bytevector (byte_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
666 memcpy (SCM_BYTEVECTOR_CONTENTS (ret), elts, byte_len);
782a82ee
AW		 667
668 scm_array_handle_release (&h);
669
670 return ret;
671}
672#undef FUNC_NAME
673
1ee2c72e
LC		 674\f
675/* Operations on bytes and octets. */
676
677SCM_DEFINE (scm_bytevector_u8_ref, "bytevector-u8-ref", 2, 0, 0,
678 (SCM bv, SCM index),
679 "Return the octet located at @var{index} in @var{bv}.")
680#define FUNC_NAME s_scm_bytevector_u8_ref
681{
682 INTEGER_NATIVE_REF (8, unsigned);
683}
684#undef FUNC_NAME
685
686SCM_DEFINE (scm_bytevector_s8_ref, "bytevector-s8-ref", 2, 0, 0,
687 (SCM bv, SCM index),
688 "Return the byte located at @var{index} in @var{bv}.")
689#define FUNC_NAME s_scm_bytevector_s8_ref
690{
691 INTEGER_NATIVE_REF (8, signed);
692}
693#undef FUNC_NAME
694
695SCM_DEFINE (scm_bytevector_u8_set_x, "bytevector-u8-set!", 3, 0, 0,
696 (SCM bv, SCM index, SCM value),
697 "Return the octet located at @var{index} in @var{bv}.")
698#define FUNC_NAME s_scm_bytevector_u8_set_x
699{
700 INTEGER_NATIVE_SET (8, unsigned);
701}
702#undef FUNC_NAME
703
704SCM_DEFINE (scm_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0,
705 (SCM bv, SCM index, SCM value),
706 "Return the octet located at @var{index} in @var{bv}.")
cabf1b31 707#define FUNC_NAME s_scm_bytevector_s8_set_x
1ee2c72e
LC		 708{
709 INTEGER_NATIVE_SET (8, signed);
710}
711#undef FUNC_NAME
712
713#undef OCTET_ACCESSOR_PROLOGUE
714
715
716SCM_DEFINE (scm_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0,
717 (SCM bv),
718 "Return a newly allocated list of octets containing the "
719 "contents of @var{bv}.")
720#define FUNC_NAME s_scm_bytevector_to_u8_list
721{
722 SCM lst, pair;
723 unsigned c_len, i;
724 unsigned char *c_bv;
725
726 SCM_VALIDATE_BYTEVECTOR (1, bv);
727
728 c_len = SCM_BYTEVECTOR_LENGTH (bv);
729 c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
730
731 lst = scm_make_list (scm_from_uint (c_len), SCM_UNSPECIFIED);
732 for (i = 0, pair = lst;
733 i < c_len;
734 i++, pair = SCM_CDR (pair))
735 {
736 SCM_SETCAR (pair, SCM_I_MAKINUM (c_bv[i]));
737 }
738
739 return lst;
740}
741#undef FUNC_NAME
742
743SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0,
744 (SCM lst),
745 "Turn @var{lst}, a list of octets, into a bytevector.")
746#define FUNC_NAME s_scm_u8_list_to_bytevector
747{
748 SCM bv, item;
749 long c_len, i;
750 unsigned char *c_bv;
751
752 SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);
753
e286c973 754 bv = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
1ee2c72e
LC		 755 c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
756
757 for (i = 0; i < c_len; lst = SCM_CDR (lst), i++)
758 {
759 item = SCM_CAR (lst);
760
761 if (SCM_LIKELY (SCM_I_INUMP (item)))
762 {
e25f3727 763 scm_t_signed_bits c_item;
1ee2c72e
LC		 764
765 c_item = SCM_I_INUM (item);
766 if (SCM_LIKELY ((c_item >= 0) && (c_item < 256)))
767 c_bv[i] = (unsigned char) c_item;
768 else
769 goto type_error;
770 }
771 else
772 goto type_error;
773 }
774
775 return bv;
776
777 type_error:
778 scm_wrong_type_arg (FUNC_NAME, 1, item);
779
780 return SCM_BOOL_F;
781}
782#undef FUNC_NAME
783
784/* Compute the two's complement of VALUE (a positive integer) on SIZE octets
785 using (2^(SIZE * 8) - VALUE). */
786static inline void
787twos_complement (mpz_t value, size_t size)
788{
789 unsigned long bit_count;
790
791 /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
792 checking on SIZE performed earlier. */
793 bit_count = (unsigned long) size << 3UL;
794
795 if (SCM_LIKELY (bit_count < sizeof (unsigned long)))
796 mpz_ui_sub (value, 1UL << bit_count, value);
797 else
798 {
799 mpz_t max;
800
801 mpz_init (max);
802 mpz_ui_pow_ui (max, 2, bit_count);
803 mpz_sub (value, max, value);
804 mpz_clear (max);
805 }
806}
807
808static inline SCM
809bytevector_large_ref (const char *c_bv, size_t c_size, int signed_p,
810 SCM endianness)
811{
812 SCM result;
813 mpz_t c_mpz;
814 int c_endianness, negative_p = 0;
815
816 if (signed_p)
817 {
818 if (scm_is_eq (endianness, scm_sym_big))
819 negative_p = c_bv[0] & 0x80;
820 else
821 negative_p = c_bv[c_size - 1] & 0x80;
822 }
823
824 c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
825
826 mpz_init (c_mpz);
827 mpz_import (c_mpz, 1 /* 1 word */, 1 /* word order doesn't matter */,
828 c_size /* word is C_SIZE-byte long */,
829 c_endianness,
830 0 /* nails */, c_bv);
831
832 if (signed_p && negative_p)
833 {
834 twos_complement (c_mpz, c_size);
835 mpz_neg (c_mpz, c_mpz);
836 }
837
838 result = scm_from_mpz (c_mpz);
839 mpz_clear (c_mpz); /* FIXME: Needed? */
840
841 return result;
842}
843
844static inline int
845bytevector_large_set (char *c_bv, size_t c_size, int signed_p,
846 SCM value, SCM endianness)
847{
848 mpz_t c_mpz;
849 int c_endianness, c_sign, err = 0;
850
851 c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
852
853 mpz_init (c_mpz);
854 scm_to_mpz (value, c_mpz);
855
856 c_sign = mpz_sgn (c_mpz);
857 if (c_sign < 0)
858 {
859 if (SCM_LIKELY (signed_p))
860 {
861 mpz_neg (c_mpz, c_mpz);
862 twos_complement (c_mpz, c_size);
863 }
864 else
865 {
866 err = -1;
867 goto finish;
868 }
869 }
870
871 if (c_sign == 0)
872 /* Zero. */
873 memset (c_bv, 0, c_size);
874 else
875 {
876 size_t word_count, value_size;
877
878 value_size = (mpz_sizeinbase (c_mpz, 2) + (8 * c_size)) / (8 * c_size);
879 if (SCM_UNLIKELY (value_size > c_size))
880 {
881 err = -2;
882 goto finish;
883 }
884
885
886 mpz_export (c_bv, &word_count, 1 /* word order doesn't matter */,
887 c_size, c_endianness,
888 0 /* nails */, c_mpz);
889 if (SCM_UNLIKELY (word_count != 1))
890 /* Shouldn't happen since we already checked with VALUE_SIZE. */
891 abort ();
892 }
893
894 finish:
895 mpz_clear (c_mpz);
896
897 return err;
898}
899
900#define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \
901 unsigned long c_len, c_index, c_size; \
902 char *c_bv; \
903 \
904 SCM_VALIDATE_BYTEVECTOR (1, bv); \
905 c_index = scm_to_ulong (index); \
906 c_size = scm_to_ulong (size); \
907 \
908 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
909 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
910 \
911 /* C_SIZE must have its 3 higher bits set to zero so that \
912 multiplying it by 8 yields a number that fits in an \
913 unsigned long. */ \
914 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
915 scm_out_of_range (FUNC_NAME, size); \
916 if (SCM_UNLIKELY (c_index + c_size > c_len)) \
917 scm_out_of_range (FUNC_NAME, index);
918
919
920/* Template of an integer reference function. */
921#define GENERIC_INTEGER_REF(_sign) \
922 SCM result; \
923 \
924 if (c_size < 3) \
925 { \
926 int swap; \
927 _sign int value; \
928 \
caa92f5e 929 swap = !scm_is_eq (endianness, scm_i_native_endianness); \
1ee2c72e
LC		 930 switch (c_size) \
931 { \
932 case 1: \
933 { \
934 _sign char c_value8; \
935 memcpy (&c_value8, c_bv, 1); \
936 value = c_value8; \
937 } \
938 break; \
939 case 2: \
940 { \
941 INT_TYPE (16, _sign) c_value16; \
942 memcpy (&c_value16, c_bv, 2); \
943 if (swap) \
944 value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \
945 else \
946 value = c_value16; \
947 } \
948 break; \
949 default: \
950 abort (); \
951 } \
952 \
953 result = SCM_I_MAKINUM ((_sign int) value); \
954 } \
955 else \
956 result = bytevector_large_ref ((char *) c_bv, \
957 c_size, SIGNEDNESS (_sign), \
958 endianness); \
959 \
960 return result;
961
962static inline SCM
963bytevector_signed_ref (const char *c_bv, size_t c_size, SCM endianness)
964{
965 GENERIC_INTEGER_REF (signed);
966}
967
968static inline SCM
969bytevector_unsigned_ref (const char *c_bv, size_t c_size, SCM endianness)
970{
971 GENERIC_INTEGER_REF (unsigned);
972}
973
974
975/* Template of an integer assignment function. */
976#define GENERIC_INTEGER_SET(_sign) \
977 if (c_size < 3) \
978 { \
e25f3727 979 scm_t_signed_bits c_value; \
1ee2c72e
LC		 980 \
981 if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
982 goto range_error; \
983 \
984 c_value = SCM_I_INUM (value); \
985 switch (c_size) \
986 { \
987 case 1: \
988 if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \
989 { \
990 _sign char c_value8; \
991 c_value8 = (_sign char) c_value; \
992 memcpy (c_bv, &c_value8, 1); \
993 } \
994 else \
995 goto range_error; \
996 break; \
997 \
998 case 2: \
999 if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \
1000 { \
1001 int swap; \
1002 INT_TYPE (16, _sign) c_value16; \
1003 \
caa92f5e 1004 swap = !scm_is_eq (endianness, scm_i_native_endianness); \
1ee2c72e
LC		 1005 \
1006 if (swap) \
1007 c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \
1008 else \
1009 c_value16 = c_value; \
1010 \
1011 memcpy (c_bv, &c_value16, 2); \
1012 } \
1013 else \
1014 goto range_error; \
1015 break; \
1016 \
1017 default: \
1018 abort (); \
1019 } \
1020 } \
1021 else \
1022 { \
1023 int err; \
1024 \
1025 err = bytevector_large_set (c_bv, c_size, \
1026 SIGNEDNESS (_sign), \
1027 value, endianness); \
1028 if (err) \
1029 goto range_error; \
1030 } \
1031 \
1032 return; \
1033 \
1034 range_error: \
1035 scm_out_of_range (FUNC_NAME, value); \
1036 return;
1037
1038static inline void
1039bytevector_signed_set (char *c_bv, size_t c_size,
1040 SCM value, SCM endianness,
1041 const char *func_name)
1042#define FUNC_NAME func_name
1043{
1044 GENERIC_INTEGER_SET (signed);
1045}
1046#undef FUNC_NAME
1047
1048static inline void
1049bytevector_unsigned_set (char *c_bv, size_t c_size,
1050 SCM value, SCM endianness,
1051 const char *func_name)
1052#define FUNC_NAME func_name
1053{
1054 GENERIC_INTEGER_SET (unsigned);
1055}
1056#undef FUNC_NAME
1057
1058#undef GENERIC_INTEGER_SET
1059#undef GENERIC_INTEGER_REF
1060
1061
1062SCM_DEFINE (scm_bytevector_uint_ref, "bytevector-uint-ref", 4, 0, 0,
1063 (SCM bv, SCM index, SCM endianness, SCM size),
1064 "Return the @var{size}-octet long unsigned integer at index "
1065 "@var{index} in @var{bv}.")
1066#define FUNC_NAME s_scm_bytevector_uint_ref
1067{
1068 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
1069
1070 return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness));
1071}
1072#undef FUNC_NAME
1073
1074SCM_DEFINE (scm_bytevector_sint_ref, "bytevector-sint-ref", 4, 0, 0,
1075 (SCM bv, SCM index, SCM endianness, SCM size),
1076 "Return the @var{size}-octet long unsigned integer at index "
1077 "@var{index} in @var{bv}.")
1078#define FUNC_NAME s_scm_bytevector_sint_ref
1079{
1080 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
1081
1082 return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness));
1083}
1084#undef FUNC_NAME
1085
1086SCM_DEFINE (scm_bytevector_uint_set_x, "bytevector-uint-set!", 5, 0, 0,
1087 (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
1088 "Set the @var{size}-octet long unsigned integer at @var{index} "
1089 "to @var{value}.")
1090#define FUNC_NAME s_scm_bytevector_uint_set_x
1091{
1092 GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
1093
1094 bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness,
1095 FUNC_NAME);
1096
1097 return SCM_UNSPECIFIED;
1098}
1099#undef FUNC_NAME
1100
1101SCM_DEFINE (scm_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0,
1102 (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
1103 "Set the @var{size}-octet long signed integer at @var{index} "
1104 "to @var{value}.")
1105#define FUNC_NAME s_scm_bytevector_sint_set_x
1106{
1107 GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
1108
1109 bytevector_signed_set (&c_bv[c_index], c_size, value, endianness,
1110 FUNC_NAME);
1111
1112 return SCM_UNSPECIFIED;
1113}
1114#undef FUNC_NAME
1115
1116
1117\f
1118/* Operations on integers of arbitrary size. */
1119
1120#define INTEGERS_TO_LIST(_sign) \
1121 SCM lst, pair; \
1122 size_t i, c_len, c_size; \
1123 \
1124 SCM_VALIDATE_BYTEVECTOR (1, bv); \
1125 SCM_VALIDATE_SYMBOL (2, endianness); \
088cfb7d 1126 c_size = scm_to_unsigned_integer (size, 1, (size_t) -1); \
1ee2c72e
LC		 1127 \
1128 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
c099201d
MW		 1129 if (SCM_UNLIKELY (c_len % c_size != 0)) \
1130 scm_wrong_type_arg_msg \
1131 (FUNC_NAME, 0, size, \
1132 "an exact positive integer that divides the bytevector length"); \
1133 else if (SCM_UNLIKELY (c_len == 0)) \
1ee2c72e 1134 lst = SCM_EOL; \
1ee2c72e
LC		 1135 else \
1136 { \
1137 const char *c_bv; \
1138 \
1139 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1140 \
088cfb7d 1141 lst = scm_make_list (scm_from_size_t (c_len / c_size), \
1ee2c72e
LC		 1142 SCM_UNSPECIFIED); \
1143 for (i = 0, pair = lst; \
1144 i <= c_len - c_size; \
1145 i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
1146 { \
1147 SCM_SETCAR (pair, \
1148 bytevector_ ## _sign ## _ref (c_bv, c_size, \
1149 endianness)); \
1150 } \
1151 } \
1152 \
1153 return lst;
1154
1155SCM_DEFINE (scm_bytevector_to_sint_list, "bytevector->sint-list",
1156 3, 0, 0,
1157 (SCM bv, SCM endianness, SCM size),
1158 "Return a list of signed integers of @var{size} octets "
1159 "representing the contents of @var{bv}.")
1160#define FUNC_NAME s_scm_bytevector_to_sint_list
1161{
1162 INTEGERS_TO_LIST (signed);
1163}
1164#undef FUNC_NAME
1165
1166SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list",
1167 3, 0, 0,
1168 (SCM bv, SCM endianness, SCM size),
1169 "Return a list of unsigned integers of @var{size} octets "
1170 "representing the contents of @var{bv}.")
1171#define FUNC_NAME s_scm_bytevector_to_uint_list
1172{
1173 INTEGERS_TO_LIST (unsigned);
1174}
1175#undef FUNC_NAME
1176
1177#undef INTEGER_TO_LIST
1178
1179
1180#define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
1181 SCM bv; \
1182 long c_len; \
1183 size_t c_size; \
1184 char *c_bv, *c_bv_ptr; \
1185 \
1186 SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
1187 SCM_VALIDATE_SYMBOL (2, endianness); \
1188 c_size = scm_to_uint (size); \
1189 \
1190 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
1191 scm_out_of_range (FUNC_NAME, size); \
1192 \
e286c973 1193 bv = make_bytevector (c_len * c_size, SCM_ARRAY_ELEMENT_TYPE_VU8); \
1ee2c72e
LC		 1194 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1195 \
1196 for (c_bv_ptr = c_bv; \
1197 !scm_is_null (lst); \
1198 lst = SCM_CDR (lst), c_bv_ptr += c_size) \
1199 { \
1200 bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
1201 SCM_CAR (lst), endianness, \
1202 FUNC_NAME); \
1203 } \
1204 \
1205 return bv;
1206
1207
1208SCM_DEFINE (scm_uint_list_to_bytevector, "uint-list->bytevector",
1209 3, 0, 0,
1210 (SCM lst, SCM endianness, SCM size),
1211 "Return a bytevector containing the unsigned integers "
1212 "listed in @var{lst} and encoded on @var{size} octets "
1213 "according to @var{endianness}.")
1214#define FUNC_NAME s_scm_uint_list_to_bytevector
1215{
1216 INTEGER_LIST_TO_BYTEVECTOR (unsigned);
1217}
1218#undef FUNC_NAME
1219
1220SCM_DEFINE (scm_sint_list_to_bytevector, "sint-list->bytevector",
1221 3, 0, 0,
1222 (SCM lst, SCM endianness, SCM size),
1223 "Return a bytevector containing the signed integers "
1224 "listed in @var{lst} and encoded on @var{size} octets "
1225 "according to @var{endianness}.")
1226#define FUNC_NAME s_scm_sint_list_to_bytevector
1227{
1228 INTEGER_LIST_TO_BYTEVECTOR (signed);
1229}
1230#undef FUNC_NAME
1231
1232#undef INTEGER_LIST_TO_BYTEVECTOR
1233
1234
1235\f
1236/* Operations on 16-bit integers. */
1237
1238SCM_DEFINE (scm_bytevector_u16_ref, "bytevector-u16-ref",
1239 3, 0, 0,
1240 (SCM bv, SCM index, SCM endianness),
1241 "Return the unsigned 16-bit integer from @var{bv} at "
1242 "@var{index}.")
1243#define FUNC_NAME s_scm_bytevector_u16_ref
1244{
1245 INTEGER_REF (16, unsigned);
1246}
1247#undef FUNC_NAME
1248
1249SCM_DEFINE (scm_bytevector_s16_ref, "bytevector-s16-ref",
1250 3, 0, 0,
1251 (SCM bv, SCM index, SCM endianness),
1252 "Return the signed 16-bit integer from @var{bv} at "
1253 "@var{index}.")
1254#define FUNC_NAME s_scm_bytevector_s16_ref
1255{
1256 INTEGER_REF (16, signed);
1257}
1258#undef FUNC_NAME
1259
1260SCM_DEFINE (scm_bytevector_u16_native_ref, "bytevector-u16-native-ref",
1261 2, 0, 0,
1262 (SCM bv, SCM index),
1263 "Return the unsigned 16-bit integer from @var{bv} at "
1264 "@var{index} using the native endianness.")
1265#define FUNC_NAME s_scm_bytevector_u16_native_ref
1266{
1267 INTEGER_NATIVE_REF (16, unsigned);
1268}
1269#undef FUNC_NAME
1270
1271SCM_DEFINE (scm_bytevector_s16_native_ref, "bytevector-s16-native-ref",
1272 2, 0, 0,
1273 (SCM bv, SCM index),
1274 "Return the unsigned 16-bit integer from @var{bv} at "
1275 "@var{index} using the native endianness.")
1276#define FUNC_NAME s_scm_bytevector_s16_native_ref
1277{
1278 INTEGER_NATIVE_REF (16, signed);
1279}
1280#undef FUNC_NAME
1281
1282SCM_DEFINE (scm_bytevector_u16_set_x, "bytevector-u16-set!",
1283 4, 0, 0,
1284 (SCM bv, SCM index, SCM value, SCM endianness),
1285 "Store @var{value} in @var{bv} at @var{index} according to "
1286 "@var{endianness}.")
1287#define FUNC_NAME s_scm_bytevector_u16_set_x
1288{
1289 INTEGER_SET (16, unsigned);
1290}
1291#undef FUNC_NAME
1292
1293SCM_DEFINE (scm_bytevector_s16_set_x, "bytevector-s16-set!",
1294 4, 0, 0,
1295 (SCM bv, SCM index, SCM value, SCM endianness),
1296 "Store @var{value} in @var{bv} at @var{index} according to "
1297 "@var{endianness}.")
1298#define FUNC_NAME s_scm_bytevector_s16_set_x
1299{
1300 INTEGER_SET (16, signed);
1301}
1302#undef FUNC_NAME
1303
1304SCM_DEFINE (scm_bytevector_u16_native_set_x, "bytevector-u16-native-set!",
1305 3, 0, 0,
1306 (SCM bv, SCM index, SCM value),
1307 "Store the unsigned integer @var{value} at index @var{index} "
1308 "of @var{bv} using the native endianness.")
1309#define FUNC_NAME s_scm_bytevector_u16_native_set_x
1310{
1311 INTEGER_NATIVE_SET (16, unsigned);
1312}
1313#undef FUNC_NAME
1314
1315SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!",
1316 3, 0, 0,
1317 (SCM bv, SCM index, SCM value),
1318 "Store the signed integer @var{value} at index @var{index} "
1319 "of @var{bv} using the native endianness.")
1320#define FUNC_NAME s_scm_bytevector_s16_native_set_x
1321{
1322 INTEGER_NATIVE_SET (16, signed);
1323}
1324#undef FUNC_NAME
1325
1326
1327\f
1328/* Operations on 32-bit integers. */
1329
1330/* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
1331 arbitrary 32-bit integers. Thus we fall back to using the
1332 `large_{ref,set}' variants on 32-bit machines. */
1333
1334#define LARGE_INTEGER_REF(_len, _sign) \
1335 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1336 SCM_VALIDATE_SYMBOL (3, endianness); \
1337 \
1338 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1339 SIGNEDNESS (_sign), endianness));
1340
1341#define LARGE_INTEGER_SET(_len, _sign) \
1342 int err; \
1343 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1344 SCM_VALIDATE_SYMBOL (4, endianness); \
1345 \
1346 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1347 SIGNEDNESS (_sign), value, endianness); \
1348 if (SCM_UNLIKELY (err)) \
1349 scm_out_of_range (FUNC_NAME, value); \
1350 \
1351 return SCM_UNSPECIFIED;
1352
1353#define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
1354 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1355 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
caa92f5e 1356 SIGNEDNESS (_sign), scm_i_native_endianness));
1ee2c72e
LC		 1357
1358#define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
1359 int err; \
1360 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1361 \
1362 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1363 SIGNEDNESS (_sign), value, \
caa92f5e 1364 scm_i_native_endianness); \
1ee2c72e
LC		 1365 if (SCM_UNLIKELY (err)) \
1366 scm_out_of_range (FUNC_NAME, value); \
1367 \
1368 return SCM_UNSPECIFIED;
1369
1370
1371SCM_DEFINE (scm_bytevector_u32_ref, "bytevector-u32-ref",
1372 3, 0, 0,
1373 (SCM bv, SCM index, SCM endianness),
1374 "Return the unsigned 32-bit integer from @var{bv} at "
1375 "@var{index}.")
1376#define FUNC_NAME s_scm_bytevector_u32_ref
1377{
1378#if SIZEOF_VOID_P > 4
1379 INTEGER_REF (32, unsigned);
1380#else
1381 LARGE_INTEGER_REF (32, unsigned);
1382#endif
1383}
1384#undef FUNC_NAME
1385
1386SCM_DEFINE (scm_bytevector_s32_ref, "bytevector-s32-ref",
1387 3, 0, 0,
1388 (SCM bv, SCM index, SCM endianness),
1389 "Return the signed 32-bit integer from @var{bv} at "
1390 "@var{index}.")
1391#define FUNC_NAME s_scm_bytevector_s32_ref
1392{
1393#if SIZEOF_VOID_P > 4
1394 INTEGER_REF (32, signed);
1395#else
1396 LARGE_INTEGER_REF (32, signed);
1397#endif
1398}
1399#undef FUNC_NAME
1400
1401SCM_DEFINE (scm_bytevector_u32_native_ref, "bytevector-u32-native-ref",
1402 2, 0, 0,
1403 (SCM bv, SCM index),
1404 "Return the unsigned 32-bit integer from @var{bv} at "
1405 "@var{index} using the native endianness.")
1406#define FUNC_NAME s_scm_bytevector_u32_native_ref
1407{
1408#if SIZEOF_VOID_P > 4
1409 INTEGER_NATIVE_REF (32, unsigned);
1410#else
1411 LARGE_INTEGER_NATIVE_REF (32, unsigned);
1412#endif
1413}
1414#undef FUNC_NAME
1415
1416SCM_DEFINE (scm_bytevector_s32_native_ref, "bytevector-s32-native-ref",
1417 2, 0, 0,
1418 (SCM bv, SCM index),
1419 "Return the unsigned 32-bit integer from @var{bv} at "
1420 "@var{index} using the native endianness.")
1421#define FUNC_NAME s_scm_bytevector_s32_native_ref
1422{
1423#if SIZEOF_VOID_P > 4
1424 INTEGER_NATIVE_REF (32, signed);
1425#else
1426 LARGE_INTEGER_NATIVE_REF (32, signed);
1427#endif
1428}
1429#undef FUNC_NAME
1430
1431SCM_DEFINE (scm_bytevector_u32_set_x, "bytevector-u32-set!",
1432 4, 0, 0,
1433 (SCM bv, SCM index, SCM value, SCM endianness),
1434 "Store @var{value} in @var{bv} at @var{index} according to "
1435 "@var{endianness}.")
1436#define FUNC_NAME s_scm_bytevector_u32_set_x
1437{
1438#if SIZEOF_VOID_P > 4
1439 INTEGER_SET (32, unsigned);
1440#else
1441 LARGE_INTEGER_SET (32, unsigned);
1442#endif
1443}
1444#undef FUNC_NAME
1445
1446SCM_DEFINE (scm_bytevector_s32_set_x, "bytevector-s32-set!",
1447 4, 0, 0,
1448 (SCM bv, SCM index, SCM value, SCM endianness),
1449 "Store @var{value} in @var{bv} at @var{index} according to "
1450 "@var{endianness}.")
1451#define FUNC_NAME s_scm_bytevector_s32_set_x
1452{
1453#if SIZEOF_VOID_P > 4
1454 INTEGER_SET (32, signed);
1455#else
1456 LARGE_INTEGER_SET (32, signed);
1457#endif
1458}
1459#undef FUNC_NAME
1460
1461SCM_DEFINE (scm_bytevector_u32_native_set_x, "bytevector-u32-native-set!",
1462 3, 0, 0,
1463 (SCM bv, SCM index, SCM value),
1464 "Store the unsigned integer @var{value} at index @var{index} "
1465 "of @var{bv} using the native endianness.")
1466#define FUNC_NAME s_scm_bytevector_u32_native_set_x
1467{
1468#if SIZEOF_VOID_P > 4
1469 INTEGER_NATIVE_SET (32, unsigned);
1470#else
1471 LARGE_INTEGER_NATIVE_SET (32, unsigned);
1472#endif
1473}
1474#undef FUNC_NAME
1475
1476SCM_DEFINE (scm_bytevector_s32_native_set_x, "bytevector-s32-native-set!",
1477 3, 0, 0,
1478 (SCM bv, SCM index, SCM value),
1479 "Store the signed integer @var{value} at index @var{index} "
1480 "of @var{bv} using the native endianness.")
1481#define FUNC_NAME s_scm_bytevector_s32_native_set_x
1482{
1483#if SIZEOF_VOID_P > 4
1484 INTEGER_NATIVE_SET (32, signed);
1485#else
1486 LARGE_INTEGER_NATIVE_SET (32, signed);
1487#endif
1488}
1489#undef FUNC_NAME
1490
1491
1492\f
1493/* Operations on 64-bit integers. */
1494
1495/* For 64-bit integers, we use only the `large_{ref,set}' variant. */
1496
1497SCM_DEFINE (scm_bytevector_u64_ref, "bytevector-u64-ref",
1498 3, 0, 0,
1499 (SCM bv, SCM index, SCM endianness),
1500 "Return the unsigned 64-bit integer from @var{bv} at "
1501 "@var{index}.")
1502#define FUNC_NAME s_scm_bytevector_u64_ref
1503{
1504 LARGE_INTEGER_REF (64, unsigned);
1505}
1506#undef FUNC_NAME
1507
1508SCM_DEFINE (scm_bytevector_s64_ref, "bytevector-s64-ref",
1509 3, 0, 0,
1510 (SCM bv, SCM index, SCM endianness),
1511 "Return the signed 64-bit integer from @var{bv} at "
1512 "@var{index}.")
1513#define FUNC_NAME s_scm_bytevector_s64_ref
1514{
1515 LARGE_INTEGER_REF (64, signed);
1516}
1517#undef FUNC_NAME
1518
1519SCM_DEFINE (scm_bytevector_u64_native_ref, "bytevector-u64-native-ref",
1520 2, 0, 0,
1521 (SCM bv, SCM index),
1522 "Return the unsigned 64-bit integer from @var{bv} at "
1523 "@var{index} using the native endianness.")
1524#define FUNC_NAME s_scm_bytevector_u64_native_ref
1525{
1526 LARGE_INTEGER_NATIVE_REF (64, unsigned);
1527}
1528#undef FUNC_NAME
1529
1530SCM_DEFINE (scm_bytevector_s64_native_ref, "bytevector-s64-native-ref",
1531 2, 0, 0,
1532 (SCM bv, SCM index),
1533 "Return the unsigned 64-bit integer from @var{bv} at "
1534 "@var{index} using the native endianness.")
1535#define FUNC_NAME s_scm_bytevector_s64_native_ref
1536{
1537 LARGE_INTEGER_NATIVE_REF (64, signed);
1538}
1539#undef FUNC_NAME
1540
1541SCM_DEFINE (scm_bytevector_u64_set_x, "bytevector-u64-set!",
1542 4, 0, 0,
1543 (SCM bv, SCM index, SCM value, SCM endianness),
1544 "Store @var{value} in @var{bv} at @var{index} according to "
1545 "@var{endianness}.")
1546#define FUNC_NAME s_scm_bytevector_u64_set_x
1547{
1548 LARGE_INTEGER_SET (64, unsigned);
1549}
1550#undef FUNC_NAME
1551
1552SCM_DEFINE (scm_bytevector_s64_set_x, "bytevector-s64-set!",
1553 4, 0, 0,
1554 (SCM bv, SCM index, SCM value, SCM endianness),
1555 "Store @var{value} in @var{bv} at @var{index} according to "
1556 "@var{endianness}.")
1557#define FUNC_NAME s_scm_bytevector_s64_set_x
1558{
1559 LARGE_INTEGER_SET (64, signed);
1560}
1561#undef FUNC_NAME
1562
1563SCM_DEFINE (scm_bytevector_u64_native_set_x, "bytevector-u64-native-set!",
1564 3, 0, 0,
1565 (SCM bv, SCM index, SCM value),
1566 "Store the unsigned integer @var{value} at index @var{index} "
1567 "of @var{bv} using the native endianness.")
1568#define FUNC_NAME s_scm_bytevector_u64_native_set_x
1569{
1570 LARGE_INTEGER_NATIVE_SET (64, unsigned);
1571}
1572#undef FUNC_NAME
1573
1574SCM_DEFINE (scm_bytevector_s64_native_set_x, "bytevector-s64-native-set!",
1575 3, 0, 0,
1576 (SCM bv, SCM index, SCM value),
1577 "Store the signed integer @var{value} at index @var{index} "
1578 "of @var{bv} using the native endianness.")
1579#define FUNC_NAME s_scm_bytevector_s64_native_set_x
1580{
1581 LARGE_INTEGER_NATIVE_SET (64, signed);
1582}
1583#undef FUNC_NAME
1584
1585
1586\f
1587/* Operations on IEEE-754 numbers. */
1588
1589/* There are two possible word endians, visible in glibc's <ieee754.h>.
1590 However, in R6RS, when the endianness is `little', little endian is
1591 assumed for both the byte order and the word order. This is clear from
1592 Section 2.1 of R6RS-lib (in response to
1593 http://www.r6rs.org/formal-comments/comment-187.txt). */
1594
398446c7
LC		 1595union scm_ieee754_float
1596{
1597 float f;
1598 scm_t_uint32 i;
1599};
1600
1601union scm_ieee754_double
1602{
1603 double d;
1604 scm_t_uint64 i;
1605};
1606
1ee2c72e
LC		 1607
1608/* Convert to/from a floating-point number with different endianness. This
1609 method is probably not the most efficient but it should be portable. */
1610
1611static inline void
1612float_to_foreign_endianness (union scm_ieee754_float *target,
1613 float source)
1614{
398446c7 1615 union scm_ieee754_float input;
1ee2c72e 1616
398446c7
LC		 1617 input.f = source;
1618 target->i = bswap_32 (input.i);
1ee2c72e
LC		 1619}
1620
1621static inline float
1622float_from_foreign_endianness (const union scm_ieee754_float *source)
1623{
1624 union scm_ieee754_float result;
1625
398446c7 1626 result.i = bswap_32 (source->i);
1ee2c72e
LC		 1627
1628 return (result.f);
1629}
1630
1631static inline void
1632double_to_foreign_endianness (union scm_ieee754_double *target,
1633 double source)
1634{
398446c7 1635 union scm_ieee754_double input;
1ee2c72e 1636
398446c7
LC		 1637 input.d = source;
1638 target->i = bswap_64 (input.i);
1ee2c72e
LC		 1639}
1640
1641static inline double
1642double_from_foreign_endianness (const union scm_ieee754_double *source)
1643{
1644 union scm_ieee754_double result;
1645
398446c7 1646 result.i = bswap_64 (source->i);
1ee2c72e
LC		 1647
1648 return (result.d);
1649}
1650
1651/* Template macros to abstract over doubles and floats.
1652 XXX: Guile can only convert to/from doubles. */
1653#define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type
1654#define IEEE754_TO_SCM(_c_type) scm_from_double
1655#define IEEE754_FROM_SCM(_c_type) scm_to_double
1656#define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
1657 _c_type ## _from_foreign_endianness
1658#define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
1659 _c_type ## _to_foreign_endianness
1660
1661
cd43fdc5
AW		 1662/* FIXME: SCM_VALIDATE_REAL rejects integers, etc. grrr */
1663#define VALIDATE_REAL(pos, v) \
1664 do { \
ae255d65 1665 SCM_ASSERT_TYPE (scm_is_real (v), v, pos, FUNC_NAME, "real"); \
cd43fdc5
AW		 1666 } while (0)
1667
1ee2c72e
LC		 1668/* Templace getters and setters. */
1669
1670#define IEEE754_ACCESSOR_PROLOGUE(_type) \
1671 INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
1672
1673#define IEEE754_REF(_type) \
1674 _type c_result; \
1675 \
1676 IEEE754_ACCESSOR_PROLOGUE (_type); \
1677 SCM_VALIDATE_SYMBOL (3, endianness); \
1678 \
caa92f5e 1679 if (scm_is_eq (endianness, scm_i_native_endianness)) \
1ee2c72e
LC		 1680 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1681 else \
1682 { \
1683 IEEE754_UNION (_type) c_raw; \
1684 \
1685 memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
1686 c_result = \
1687 IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
1688 } \
1689 \
1690 return (IEEE754_TO_SCM (_type) (c_result));
1691
1692#define IEEE754_NATIVE_REF(_type) \
1693 _type c_result; \
1694 \
1695 IEEE754_ACCESSOR_PROLOGUE (_type); \
1696 \
1697 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1698 return (IEEE754_TO_SCM (_type) (c_result));
1699
1700#define IEEE754_SET(_type) \
1701 _type c_value; \
1702 \
1703 IEEE754_ACCESSOR_PROLOGUE (_type); \
cd43fdc5 1704 VALIDATE_REAL (3, value); \
1ee2c72e
LC		 1705 SCM_VALIDATE_SYMBOL (4, endianness); \
1706 c_value = IEEE754_FROM_SCM (_type) (value); \
1707 \
caa92f5e 1708 if (scm_is_eq (endianness, scm_i_native_endianness)) \
1ee2c72e
LC		 1709 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1710 else \
1711 { \
1712 IEEE754_UNION (_type) c_raw; \
1713 \
1714 IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
1715 memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
1716 } \
1717 \
1718 return SCM_UNSPECIFIED;
1719
1720#define IEEE754_NATIVE_SET(_type) \
1721 _type c_value; \
1722 \
1723 IEEE754_ACCESSOR_PROLOGUE (_type); \
cd43fdc5 1724 VALIDATE_REAL (3, value); \
1ee2c72e
LC		 1725 c_value = IEEE754_FROM_SCM (_type) (value); \
1726 \
1727 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1728 return SCM_UNSPECIFIED;
1729
1730
1731/* Single precision. */
1732
1733SCM_DEFINE (scm_bytevector_ieee_single_ref,
1734 "bytevector-ieee-single-ref",
1735 3, 0, 0,
1736 (SCM bv, SCM index, SCM endianness),
1737 "Return the IEEE-754 single from @var{bv} at "
1738 "@var{index}.")
1739#define FUNC_NAME s_scm_bytevector_ieee_single_ref
1740{
1741 IEEE754_REF (float);
1742}
1743#undef FUNC_NAME
1744
1745SCM_DEFINE (scm_bytevector_ieee_single_native_ref,
1746 "bytevector-ieee-single-native-ref",
1747 2, 0, 0,
1748 (SCM bv, SCM index),
1749 "Return the IEEE-754 single from @var{bv} at "
1750 "@var{index} using the native endianness.")
1751#define FUNC_NAME s_scm_bytevector_ieee_single_native_ref
1752{
1753 IEEE754_NATIVE_REF (float);
1754}
1755#undef FUNC_NAME
1756
1757SCM_DEFINE (scm_bytevector_ieee_single_set_x,
1758 "bytevector-ieee-single-set!",
1759 4, 0, 0,
1760 (SCM bv, SCM index, SCM value, SCM endianness),
1761 "Store real @var{value} in @var{bv} at @var{index} according to "
1762 "@var{endianness}.")
1763#define FUNC_NAME s_scm_bytevector_ieee_single_set_x
1764{
1765 IEEE754_SET (float);
1766}
1767#undef FUNC_NAME
1768
1769SCM_DEFINE (scm_bytevector_ieee_single_native_set_x,
1770 "bytevector-ieee-single-native-set!",
1771 3, 0, 0,
1772 (SCM bv, SCM index, SCM value),
1773 "Store the real @var{value} at index @var{index} "
1774 "of @var{bv} using the native endianness.")
1775#define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x
1776{
1777 IEEE754_NATIVE_SET (float);
1778}
1779#undef FUNC_NAME
1780
1781
1782/* Double precision. */
1783
1784SCM_DEFINE (scm_bytevector_ieee_double_ref,
1785 "bytevector-ieee-double-ref",
1786 3, 0, 0,
1787 (SCM bv, SCM index, SCM endianness),
1788 "Return the IEEE-754 double from @var{bv} at "
1789 "@var{index}.")
1790#define FUNC_NAME s_scm_bytevector_ieee_double_ref
1791{
1792 IEEE754_REF (double);
1793}
1794#undef FUNC_NAME
1795
1796SCM_DEFINE (scm_bytevector_ieee_double_native_ref,
1797 "bytevector-ieee-double-native-ref",
1798 2, 0, 0,
1799 (SCM bv, SCM index),
1800 "Return the IEEE-754 double from @var{bv} at "
1801 "@var{index} using the native endianness.")
1802#define FUNC_NAME s_scm_bytevector_ieee_double_native_ref
1803{
1804 IEEE754_NATIVE_REF (double);
1805}
1806#undef FUNC_NAME
1807
1808SCM_DEFINE (scm_bytevector_ieee_double_set_x,
1809 "bytevector-ieee-double-set!",
1810 4, 0, 0,
1811 (SCM bv, SCM index, SCM value, SCM endianness),
1812 "Store real @var{value} in @var{bv} at @var{index} according to "
1813 "@var{endianness}.")
1814#define FUNC_NAME s_scm_bytevector_ieee_double_set_x
1815{
1816 IEEE754_SET (double);
1817}
1818#undef FUNC_NAME
1819
1820SCM_DEFINE (scm_bytevector_ieee_double_native_set_x,
1821 "bytevector-ieee-double-native-set!",
1822 3, 0, 0,
1823 (SCM bv, SCM index, SCM value),
1824 "Store the real @var{value} at index @var{index} "
1825 "of @var{bv} using the native endianness.")
1826#define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x
1827{
1828 IEEE754_NATIVE_SET (double);
1829}
1830#undef FUNC_NAME
1831
1832
1833#undef IEEE754_UNION
1834#undef IEEE754_TO_SCM
1835#undef IEEE754_FROM_SCM
1836#undef IEEE754_FROM_FOREIGN_ENDIANNESS
1837#undef IEEE754_TO_FOREIGN_ENDIANNESS
1838#undef IEEE754_REF
1839#undef IEEE754_NATIVE_REF
1840#undef IEEE754_SET
1841#undef IEEE754_NATIVE_SET
1842
1843\f
1844/* Operations on strings. */
1845
1846
1847/* Produce a function that returns the length of a UTF-encoded string. */
1848#define UTF_STRLEN_FUNCTION(_utf_width) \
1849static inline size_t \
1850utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
1851{ \
1852 size_t len = 0; \
1853 const uint ## _utf_width ## _t *ptr; \
1854 for (ptr = str; \
1855 *ptr != 0; \
1856 ptr++) \
1857 { \
1858 len++; \
1859 } \
1860 \
1861 return (len * ((_utf_width) / 8)); \
1862}
1863
1864UTF_STRLEN_FUNCTION (8)
1865
1866
1867/* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
1868#define UTF_STRLEN(_utf_width, _str) \
1869 utf ## _utf_width ## _strlen (_str)
1870
1871/* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
1872 ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
1873 encoding name). */
1874static inline void
1875utf_encoding_name (char *name, size_t utf_width, SCM endianness)
1876{
1877 strcpy (name, "UTF-");
1878 strcat (name, ((utf_width == 8)
1879 ? "8"
1880 : ((utf_width == 16)
1881 ? "16"
1882 : ((utf_width == 32)
1883 ? "32"
1884 : "??"))));
1885 strcat (name,
1886 ((scm_is_eq (endianness, scm_sym_big))
1887 ? "BE"
1888 : ((scm_is_eq (endianness, scm_sym_little))
1889 ? "LE"
1890 : "unknown")));
1891}
1892
1893/* Maximum length of a UTF encoding name. */
1894#define MAX_UTF_ENCODING_NAME_LEN 16
1895
1896/* Produce the body of a `string->utf' function. */
3a5bc4fa
MG		 1897#define STRING_TO_UTF(_utf_width) \
1898 SCM utf; \
1899 int err; \
1900 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1901 char *c_utf = NULL; \
1902 size_t c_strlen, c_utf_len = 0; \
1903 \
1904 SCM_VALIDATE_STRING (1, str); \
d223c3fc 1905 if (scm_is_eq (endianness, SCM_UNDEFINED)) \
3a5bc4fa
MG		 1906 endianness = scm_sym_big; \
1907 else \
1908 SCM_VALIDATE_SYMBOL (2, endianness); \
1909 \
1910 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1911 \
1912 c_strlen = scm_i_string_length (str); \
1913 if (scm_i_is_narrow_string (str)) \
1914 { \
1915 err = mem_iconveh (scm_i_string_chars (str), c_strlen, \
1916 "ISO-8859-1", c_utf_name, \
1917 iconveh_question_mark, NULL, \
1918 &c_utf, &c_utf_len); \
1919 if (SCM_UNLIKELY (err)) \
1920 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1921 scm_list_1 (str), err); \
1922 } \
1923 else \
1924 { \
1925 const scm_t_wchar *wbuf = scm_i_string_wide_chars (str); \
1926 c_utf = u32_conv_to_encoding (c_utf_name, \
1927 iconveh_question_mark, \
1928 (scm_t_uint32 *) wbuf, \
1929 c_strlen, NULL, NULL, &c_utf_len); \
1930 if (SCM_UNLIKELY (c_utf == NULL)) \
1931 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1932 scm_list_1 (str), errno); \
1933 } \
1934 scm_dynwind_begin (0); \
1935 scm_dynwind_free (c_utf); \
1936 utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8); \
1937 memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len); \
1938 scm_dynwind_end (); \
1939 \
1940 return (utf);
1ee2c72e
LC		 1941
1942
1943
1944SCM_DEFINE (scm_string_to_utf8, "string->utf8",
1945 1, 0, 0,
1946 (SCM str),
1947 "Return a newly allocated bytevector that contains the UTF-8 "
1948 "encoding of @var{str}.")
1949#define FUNC_NAME s_scm_string_to_utf8
1950{
1951 SCM utf;
c2c3bddb
AW		 1952 scm_t_uint8 *c_utf;
1953 size_t c_utf_len = 0;
1ee2c72e
LC		 1954
1955 SCM_VALIDATE_STRING (1, str);
1956
c2c3bddb
AW		 1957 c_utf = (scm_t_uint8 *) scm_to_utf8_stringn (str, &c_utf_len);
1958 utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
1959 memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len);
1960 free (c_utf);
1ee2c72e
LC		 1961
1962 return (utf);
1963}
1964#undef FUNC_NAME
1965
1966SCM_DEFINE (scm_string_to_utf16, "string->utf16",
1967 1, 1, 0,
1968 (SCM str, SCM endianness),
1969 "Return a newly allocated bytevector that contains the UTF-16 "
1970 "encoding of @var{str}.")
1971#define FUNC_NAME s_scm_string_to_utf16
1972{
1973 STRING_TO_UTF (16);
1974}
1975#undef FUNC_NAME
1976
c2c3bddb
AW		 1977static void
1978swap_u32 (scm_t_wchar *vals, size_t len)
1979{
1980 size_t n;
1981 for (n = 0; n < len; n++)
1982 vals[n] = bswap_32 (vals[n]);
1983}
1984
1ee2c72e
LC		 1985SCM_DEFINE (scm_string_to_utf32, "string->utf32",
1986 1, 1, 0,
1987 (SCM str, SCM endianness),
1988 "Return a newly allocated bytevector that contains the UTF-32 "
1989 "encoding of @var{str}.")
1990#define FUNC_NAME s_scm_string_to_utf32
1991{
c2c3bddb
AW		 1992 SCM bv;
1993 scm_t_wchar *wchars;
1994 size_t wchar_len, bytes_len;
1995
1996 wchars = scm_to_utf32_stringn (str, &wchar_len);
1997 bytes_len = wchar_len * sizeof (scm_t_wchar);
1998 if (!scm_is_eq (SCM_UNBNDP (endianness) ? scm_endianness_big : endianness,
1999 scm_i_native_endianness))
2000 swap_u32 (wchars, wchar_len);
2001
2002 bv = make_bytevector (bytes_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
2003 memcpy (SCM_BYTEVECTOR_CONTENTS (bv), wchars, bytes_len);
2004 free (wchars);
2005
2006 return bv;
1ee2c72e
LC		 2007}
2008#undef FUNC_NAME
2009
2010
2011/* Produce the body of a function that converts a UTF-encoded bytevector to a
2012 string. */
2013#define UTF_TO_STRING(_utf_width) \
2014 SCM str = SCM_BOOL_F; \
2015 int err; \
3a5bc4fa 2016 char *c_str = NULL; \
1ee2c72e 2017 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
3a5bc4fa
MG		 2018 char *c_utf; \
2019 size_t c_strlen = 0, c_utf_len = 0; \
1ee2c72e
LC		 2020 \
2021 SCM_VALIDATE_BYTEVECTOR (1, utf); \
d223c3fc 2022 if (scm_is_eq (endianness, SCM_UNDEFINED)) \
1ee2c72e
LC		 2023 endianness = scm_sym_big; \
2024 else \
2025 SCM_VALIDATE_SYMBOL (2, endianness); \
2026 \
2027 c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \
2028 c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
2029 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
2030 \
1ee2c72e 2031 err = mem_iconveh (c_utf, c_utf_len, \
3a5bc4fa 2032 c_utf_name, "UTF-8", \
1ee2c72e
LC		 2033 iconveh_question_mark, NULL, \
2034 &c_str, &c_strlen); \
2035 if (SCM_UNLIKELY (err)) \
2036 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
2037 scm_list_1 (utf), err); \
2038 else \
3a5bc4fa 2039 { \
686df516 2040 str = scm_from_utf8_stringn (c_str, c_strlen); \
3a5bc4fa
MG		 2041 free (c_str); \
2042 } \
1ee2c72e
LC		 2043 return (str);
2044
2045
2046SCM_DEFINE (scm_utf8_to_string, "utf8->string",
2047 1, 0, 0,
2048 (SCM utf),
2049 "Return a newly allocate string that contains from the UTF-8-"
2050 "encoded contents of bytevector @var{utf}.")
2051#define FUNC_NAME s_scm_utf8_to_string
2052{
2053 SCM str;
1ee2c72e 2054 const char *c_utf;
3a5bc4fa 2055 size_t c_utf_len = 0;
1ee2c72e
LC		 2056
2057 SCM_VALIDATE_BYTEVECTOR (1, utf);
2058
2059 c_utf_len = SCM_BYTEVECTOR_LENGTH (utf);
1ee2c72e 2060 c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf);
8c76a897 2061 str = scm_from_utf8_stringn (c_utf, c_utf_len);
1ee2c72e
LC		 2062
2063 return (str);
2064}
2065#undef FUNC_NAME
2066
2067SCM_DEFINE (scm_utf16_to_string, "utf16->string",
2068 1, 1, 0,
2069 (SCM utf, SCM endianness),
2070 "Return a newly allocate string that contains from the UTF-16-"
2071 "encoded contents of bytevector @var{utf}.")
2072#define FUNC_NAME s_scm_utf16_to_string
2073{
2074 UTF_TO_STRING (16);
2075}
2076#undef FUNC_NAME
2077
2078SCM_DEFINE (scm_utf32_to_string, "utf32->string",
2079 1, 1, 0,
2080 (SCM utf, SCM endianness),
2081 "Return a newly allocate string that contains from the UTF-32-"
2082 "encoded contents of bytevector @var{utf}.")
2083#define FUNC_NAME s_scm_utf32_to_string
2084{
2085 UTF_TO_STRING (32);
2086}
2087#undef FUNC_NAME
2088
1ee2c72e
LC		 2089\f
2090/* Initialization. */
2091
cfb4702f
LC		 2092void
2093scm_bootstrap_bytevectors (void)
2094{
807e5a66 2095 /* This must be instantiated here because the generalized-vector API may
07d22c02 2096 want to access bytevectors even though `(rnrs bytevectors)' hasn't been
807e5a66 2097 loaded. */
562cd1b8 2098 scm_null_bytevector = make_bytevector (0, SCM_ARRAY_ELEMENT_TYPE_VU8);
cfb4702f 2099
caa92f5e 2100#ifdef WORDS_BIGENDIAN
4a655e50 2101 scm_i_native_endianness = scm_from_latin1_symbol ("big");
caa92f5e 2102#else
4a655e50 2103 scm_i_native_endianness = scm_from_latin1_symbol ("little");
caa92f5e
AW		 2104#endif
2105
44602b08
AW		 2106 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
2107 "scm_init_bytevectors",
cfb4702f
LC		 2108 (scm_t_extension_init_func) scm_init_bytevectors,
2109 NULL);
2a610be5 2110
cf64dca6
AW		 2111 scm_i_register_vector_constructor
2112 (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8],
2113 scm_make_bytevector);
cfb4702f
LC		 2114}
2115
1ee2c72e
LC		 2116void
2117scm_init_bytevectors (void)
2118{
2119#include "libguile/bytevectors.x"
2120
1ee2c72e
LC		 2121 scm_endianness_big = scm_sym_big;
2122 scm_endianness_little = scm_sym_little;
1ee2c72e 2123}
Unnamed repository; edit this file 'description' to name the repository.