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