HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Fix array map functions with empty arguments
[bpt/guile.git] / libguile / bytevectors.c
CommitLineData
8c76a897 1/* Copyright (C) 2009, 2010, 2011, 2012, 2013 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))
0aed71aa 335 new_bv = PTR2SCM (scm_gc_realloc (SCM2PTR (bv),
3fe87cf7
LC		 336 c_len + SCM_BYTEVECTOR_HEADER_BYTES,
337 c_new_len + SCM_BYTEVECTOR_HEADER_BYTES,
338 SCM_GC_BYTEVECTOR));
339 else
340 {
341 signed char *c_bv;
342
343 c_bv = scm_gc_realloc (SCM_BYTEVECTOR_CONTENTS (bv),
344 c_len, c_new_len, SCM_GC_BYTEVECTOR);
345 SCM_BYTEVECTOR_SET_CONTENTS (bv, c_bv);
346
347 new_bv = bv;
348 }
1ee2c72e 349
0665b3ff 350 return new_bv;
1ee2c72e
LC		 351}
352
404bb5f8
LC		 353int
354scm_is_bytevector (SCM obj)
355{
807e5a66 356 return SCM_BYTEVECTOR_P (obj);
404bb5f8
LC		 357}
358
359size_t
360scm_c_bytevector_length (SCM bv)
361#define FUNC_NAME "scm_c_bytevector_length"
362{
363 SCM_VALIDATE_BYTEVECTOR (1, bv);
364
365 return SCM_BYTEVECTOR_LENGTH (bv);
366}
367#undef FUNC_NAME
368
369scm_t_uint8
370scm_c_bytevector_ref (SCM bv, size_t index)
371#define FUNC_NAME "scm_c_bytevector_ref"
372{
373 size_t c_len;
374 const scm_t_uint8 *c_bv;
375
376 SCM_VALIDATE_BYTEVECTOR (1, bv);
377
378 c_len = SCM_BYTEVECTOR_LENGTH (bv);
379 c_bv = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bv);
380
381 if (SCM_UNLIKELY (index >= c_len))
382 scm_out_of_range (FUNC_NAME, scm_from_size_t (index));
383
384 return c_bv[index];
385}
386#undef FUNC_NAME
387
388void
389scm_c_bytevector_set_x (SCM bv, size_t index, scm_t_uint8 value)
390#define FUNC_NAME "scm_c_bytevector_set_x"
391{
392 size_t c_len;
393 scm_t_uint8 *c_bv;
394
395 SCM_VALIDATE_BYTEVECTOR (1, bv);
396
397 c_len = SCM_BYTEVECTOR_LENGTH (bv);
398 c_bv = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bv);
399
400 if (SCM_UNLIKELY (index >= c_len))
401 scm_out_of_range (FUNC_NAME, scm_from_size_t (index));
402
403 c_bv[index] = value;
404}
405#undef FUNC_NAME
406
e286c973
AW		 407
408\f
807e5a66
LC		 409int
410scm_i_print_bytevector (SCM bv, SCM port, scm_print_state *pstate SCM_UNUSED)
1ee2c72e 411{
e286c973
AW		 412 ssize_t ubnd, inc, i;
413 scm_t_array_handle h;
414
415 scm_array_get_handle (bv, &h);
1ee2c72e 416
0607ebbf 417 scm_putc_unlocked ('#', port);
e286c973 418 scm_write (scm_array_handle_element_type (&h), port);
0607ebbf 419 scm_putc_unlocked ('(', port);
e286c973
AW		 420 for (i = h.dims[0].lbnd, ubnd = h.dims[0].ubnd, inc = h.dims[0].inc;
421 i <= ubnd; i += inc)
1ee2c72e
LC		 422 {
423 if (i > 0)
0607ebbf 424 scm_putc_unlocked (' ', port);
e286c973 425 scm_write (scm_array_handle_ref (&h, i), port);
1ee2c72e 426 }
0607ebbf 427 scm_putc_unlocked (')', port);
1ee2c72e 428
1ee2c72e
LC		 429 return 1;
430}
431
1ee2c72e
LC		 432\f
433/* General operations. */
434
435SCM_SYMBOL (scm_sym_big, "big");
436SCM_SYMBOL (scm_sym_little, "little");
437
438SCM scm_endianness_big, scm_endianness_little;
439
440/* Host endianness (a symbol). */
caa92f5e 441SCM scm_i_native_endianness = SCM_UNSPECIFIED;
1ee2c72e
LC		 442
443/* Byte-swapping. */
444#ifndef bswap_24
445# define bswap_24(_x) \
446 ((((_x) & 0xff0000) >> 16) | \
447 (((_x) & 0x00ff00)) | \
448 (((_x) & 0x0000ff) << 16))
449#endif
450
451
452SCM_DEFINE (scm_native_endianness, "native-endianness", 0, 0, 0,
453 (void),
454 "Return a symbol denoting the machine's native endianness.")
455#define FUNC_NAME s_scm_native_endianness
456{
caa92f5e 457 return scm_i_native_endianness;
1ee2c72e
LC		 458}
459#undef FUNC_NAME
460
461SCM_DEFINE (scm_bytevector_p, "bytevector?", 1, 0, 0,
462 (SCM obj),
463 "Return true if @var{obj} is a bytevector.")
464#define FUNC_NAME s_scm_bytevector_p
465{
404bb5f8 466 return scm_from_bool (scm_is_bytevector (obj));
1ee2c72e
LC		 467}
468#undef FUNC_NAME
469
470SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0,
471 (SCM len, SCM fill),
472 "Return a newly allocated bytevector of @var{len} bytes, "
473 "optionally filled with @var{fill}.")
474#define FUNC_NAME s_scm_make_bytevector
475{
476 SCM bv;
477 unsigned c_len;
478 signed char c_fill = '\0';
479
480 SCM_VALIDATE_UINT_COPY (1, len, c_len);
d223c3fc 481 if (!scm_is_eq (fill, SCM_UNDEFINED))
1ee2c72e
LC		 482 {
483 int value;
484
485 value = scm_to_int (fill);
486 if (SCM_UNLIKELY ((value < -128) || (value > 255)))
487 scm_out_of_range (FUNC_NAME, fill);
488 c_fill = (signed char) value;
489 }
490
e286c973 491 bv = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
d223c3fc 492 if (!scm_is_eq (fill, SCM_UNDEFINED))
1ee2c72e
LC		 493 {
494 unsigned i;
495 signed char *contents;
496
497 contents = SCM_BYTEVECTOR_CONTENTS (bv);
498 for (i = 0; i < c_len; i++)
499 contents[i] = c_fill;
500 }
3ef6650d
AW		 501 else
502 memset (SCM_BYTEVECTOR_CONTENTS (bv), 0, c_len);
1ee2c72e
LC		 503
504 return bv;
505}
506#undef FUNC_NAME
507
508SCM_DEFINE (scm_bytevector_length, "bytevector-length", 1, 0, 0,
509 (SCM bv),
510 "Return the length (in bytes) of @var{bv}.")
511#define FUNC_NAME s_scm_bytevector_length
512{
404bb5f8 513 return scm_from_uint (scm_c_bytevector_length (bv));
1ee2c72e
LC		 514}
515#undef FUNC_NAME
516
517SCM_DEFINE (scm_bytevector_eq_p, "bytevector=?", 2, 0, 0,
518 (SCM bv1, SCM bv2),
519 "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
520 "have the same length and contents.")
521#define FUNC_NAME s_scm_bytevector_eq_p
522{
523 SCM result = SCM_BOOL_F;
524 unsigned c_len1, c_len2;
525
526 SCM_VALIDATE_BYTEVECTOR (1, bv1);
527 SCM_VALIDATE_BYTEVECTOR (2, bv2);
528
529 c_len1 = SCM_BYTEVECTOR_LENGTH (bv1);
530 c_len2 = SCM_BYTEVECTOR_LENGTH (bv2);
531
a587d6a9
AW		 532 if (c_len1 == c_len2 && (SCM_BYTEVECTOR_ELEMENT_TYPE (bv1)
533 == SCM_BYTEVECTOR_ELEMENT_TYPE (bv2)))
1ee2c72e
LC		 534 {
535 signed char *c_bv1, *c_bv2;
536
537 c_bv1 = SCM_BYTEVECTOR_CONTENTS (bv1);
538 c_bv2 = SCM_BYTEVECTOR_CONTENTS (bv2);
539
540 result = scm_from_bool (!memcmp (c_bv1, c_bv2, c_len1));
541 }
542
543 return result;
544}
545#undef FUNC_NAME
546
547SCM_DEFINE (scm_bytevector_fill_x, "bytevector-fill!", 2, 0, 0,
548 (SCM bv, SCM fill),
549 "Fill bytevector @var{bv} with @var{fill}, a byte.")
550#define FUNC_NAME s_scm_bytevector_fill_x
551{
552 unsigned c_len, i;
553 signed char *c_bv, c_fill;
554
555 SCM_VALIDATE_BYTEVECTOR (1, bv);
556 c_fill = scm_to_int8 (fill);
557
558 c_len = SCM_BYTEVECTOR_LENGTH (bv);
559 c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
560
561 for (i = 0; i < c_len; i++)
562 c_bv[i] = c_fill;
563
564 return SCM_UNSPECIFIED;
565}
566#undef FUNC_NAME
567
568SCM_DEFINE (scm_bytevector_copy_x, "bytevector-copy!", 5, 0, 0,
569 (SCM source, SCM source_start, SCM target, SCM target_start,
570 SCM len),
571 "Copy @var{len} bytes from @var{source} into @var{target}, "
572 "starting reading from @var{source_start} (a positive index "
573 "within @var{source}) and start writing at "
574 "@var{target_start}.")
575#define FUNC_NAME s_scm_bytevector_copy_x
576{
577 unsigned c_len, c_source_len, c_target_len;
578 unsigned c_source_start, c_target_start;
579 signed char *c_source, *c_target;
580
581 SCM_VALIDATE_BYTEVECTOR (1, source);
582 SCM_VALIDATE_BYTEVECTOR (3, target);
583
584 c_len = scm_to_uint (len);
585 c_source_start = scm_to_uint (source_start);
586 c_target_start = scm_to_uint (target_start);
587
588 c_source = SCM_BYTEVECTOR_CONTENTS (source);
589 c_target = SCM_BYTEVECTOR_CONTENTS (target);
590 c_source_len = SCM_BYTEVECTOR_LENGTH (source);
591 c_target_len = SCM_BYTEVECTOR_LENGTH (target);
592
593 if (SCM_UNLIKELY (c_source_start + c_len > c_source_len))
594 scm_out_of_range (FUNC_NAME, source_start);
595 if (SCM_UNLIKELY (c_target_start + c_len > c_target_len))
596 scm_out_of_range (FUNC_NAME, target_start);
597
80719649
LC		 598 memmove (c_target + c_target_start,
599 c_source + c_source_start,
600 c_len);
1ee2c72e
LC		 601
602 return SCM_UNSPECIFIED;
603}
604#undef FUNC_NAME
605
606SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0,
607 (SCM bv),
608 "Return a newly allocated copy of @var{bv}.")
609#define FUNC_NAME s_scm_bytevector_copy
610{
611 SCM copy;
612 unsigned c_len;
613 signed char *c_bv, *c_copy;
614
615 SCM_VALIDATE_BYTEVECTOR (1, bv);
616
617 c_len = SCM_BYTEVECTOR_LENGTH (bv);
618 c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
619
e286c973 620 copy = make_bytevector (c_len, SCM_BYTEVECTOR_ELEMENT_TYPE (bv));
1ee2c72e
LC		 621 c_copy = SCM_BYTEVECTOR_CONTENTS (copy);
622 memcpy (c_copy, c_bv, c_len);
623
624 return copy;
625}
626#undef FUNC_NAME
627
782a82ee
AW		 628SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector",
629 1, 0, 0, (SCM array),
630 "Return a newly allocated bytevector whose contents\n"
631 "will be copied from the uniform array @var{array}.")
632#define FUNC_NAME s_scm_uniform_array_to_bytevector
633{
634 SCM contents, ret;
f5a51cae 635 size_t len, sz, byte_len;
782a82ee 636 scm_t_array_handle h;
f5a51cae 637 const void *elts;
782a82ee
AW		 638
639 contents = scm_array_contents (array, SCM_BOOL_T);
640 if (scm_is_false (contents))
641 scm_wrong_type_arg_msg (FUNC_NAME, 0, array, "uniform contiguous array");
642
643 scm_array_get_handle (contents, &h);
f5a51cae 644 assert (h.base == 0);
782a82ee 645
f5a51cae 646 elts = h.elements;
782a82ee 647 len = h.dims->inc * (h.dims->ubnd - h.dims->lbnd + 1);
f5a51cae
AW		 648 sz = scm_array_handle_uniform_element_bit_size (&h);
649 if (sz >= 8 && ((sz % 8) == 0))
650 byte_len = len * (sz / 8);
b0fae4ec 651 else if (sz < 8)
d65514a2
AW		 652 /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
653 units. */
654 byte_len = ((len * sz + 31) / 32) * 4;
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); \
088cfb7d 1120 c_size = scm_to_unsigned_integer (size, 1, (size_t) -1); \
1ee2c72e
LC		 1121 \
1122 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
c099201d
MW		 1123 if (SCM_UNLIKELY (c_len % c_size != 0)) \
1124 scm_wrong_type_arg_msg \
1125 (FUNC_NAME, 0, size, \
1126 "an exact positive integer that divides the bytevector length"); \
1127 else if (SCM_UNLIKELY (c_len == 0)) \
1ee2c72e 1128 lst = SCM_EOL; \
1ee2c72e
LC		 1129 else \
1130 { \
1131 const char *c_bv; \
1132 \
1133 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1134 \
088cfb7d 1135 lst = scm_make_list (scm_from_size_t (c_len / c_size), \
1ee2c72e
LC		 1136 SCM_UNSPECIFIED); \
1137 for (i = 0, pair = lst; \
1138 i <= c_len - c_size; \
1139 i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
1140 { \
1141 SCM_SETCAR (pair, \
1142 bytevector_ ## _sign ## _ref (c_bv, c_size, \
1143 endianness)); \
1144 } \
1145 } \
1146 \
1147 return lst;
1148
1149SCM_DEFINE (scm_bytevector_to_sint_list, "bytevector->sint-list",
1150 3, 0, 0,
1151 (SCM bv, SCM endianness, SCM size),
1152 "Return a list of signed integers of @var{size} octets "
1153 "representing the contents of @var{bv}.")
1154#define FUNC_NAME s_scm_bytevector_to_sint_list
1155{
1156 INTEGERS_TO_LIST (signed);
1157}
1158#undef FUNC_NAME
1159
1160SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list",
1161 3, 0, 0,
1162 (SCM bv, SCM endianness, SCM size),
1163 "Return a list of unsigned integers of @var{size} octets "
1164 "representing the contents of @var{bv}.")
1165#define FUNC_NAME s_scm_bytevector_to_uint_list
1166{
1167 INTEGERS_TO_LIST (unsigned);
1168}
1169#undef FUNC_NAME
1170
1171#undef INTEGER_TO_LIST
1172
1173
1174#define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
1175 SCM bv; \
1176 long c_len; \
1177 size_t c_size; \
1178 char *c_bv, *c_bv_ptr; \
1179 \
1180 SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
1181 SCM_VALIDATE_SYMBOL (2, endianness); \
1182 c_size = scm_to_uint (size); \
1183 \
1184 if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
1185 scm_out_of_range (FUNC_NAME, size); \
1186 \
e286c973 1187 bv = make_bytevector (c_len * c_size, SCM_ARRAY_ELEMENT_TYPE_VU8); \
1ee2c72e
LC		 1188 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
1189 \
1190 for (c_bv_ptr = c_bv; \
1191 !scm_is_null (lst); \
1192 lst = SCM_CDR (lst), c_bv_ptr += c_size) \
1193 { \
1194 bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
1195 SCM_CAR (lst), endianness, \
1196 FUNC_NAME); \
1197 } \
1198 \
1199 return bv;
1200
1201
1202SCM_DEFINE (scm_uint_list_to_bytevector, "uint-list->bytevector",
1203 3, 0, 0,
1204 (SCM lst, SCM endianness, SCM size),
1205 "Return a bytevector containing the unsigned integers "
1206 "listed in @var{lst} and encoded on @var{size} octets "
1207 "according to @var{endianness}.")
1208#define FUNC_NAME s_scm_uint_list_to_bytevector
1209{
1210 INTEGER_LIST_TO_BYTEVECTOR (unsigned);
1211}
1212#undef FUNC_NAME
1213
1214SCM_DEFINE (scm_sint_list_to_bytevector, "sint-list->bytevector",
1215 3, 0, 0,
1216 (SCM lst, SCM endianness, SCM size),
1217 "Return a bytevector containing the signed integers "
1218 "listed in @var{lst} and encoded on @var{size} octets "
1219 "according to @var{endianness}.")
1220#define FUNC_NAME s_scm_sint_list_to_bytevector
1221{
1222 INTEGER_LIST_TO_BYTEVECTOR (signed);
1223}
1224#undef FUNC_NAME
1225
1226#undef INTEGER_LIST_TO_BYTEVECTOR
1227
1228
1229\f
1230/* Operations on 16-bit integers. */
1231
1232SCM_DEFINE (scm_bytevector_u16_ref, "bytevector-u16-ref",
1233 3, 0, 0,
1234 (SCM bv, SCM index, SCM endianness),
1235 "Return the unsigned 16-bit integer from @var{bv} at "
1236 "@var{index}.")
1237#define FUNC_NAME s_scm_bytevector_u16_ref
1238{
1239 INTEGER_REF (16, unsigned);
1240}
1241#undef FUNC_NAME
1242
1243SCM_DEFINE (scm_bytevector_s16_ref, "bytevector-s16-ref",
1244 3, 0, 0,
1245 (SCM bv, SCM index, SCM endianness),
1246 "Return the signed 16-bit integer from @var{bv} at "
1247 "@var{index}.")
1248#define FUNC_NAME s_scm_bytevector_s16_ref
1249{
1250 INTEGER_REF (16, signed);
1251}
1252#undef FUNC_NAME
1253
1254SCM_DEFINE (scm_bytevector_u16_native_ref, "bytevector-u16-native-ref",
1255 2, 0, 0,
1256 (SCM bv, SCM index),
1257 "Return the unsigned 16-bit integer from @var{bv} at "
1258 "@var{index} using the native endianness.")
1259#define FUNC_NAME s_scm_bytevector_u16_native_ref
1260{
1261 INTEGER_NATIVE_REF (16, unsigned);
1262}
1263#undef FUNC_NAME
1264
1265SCM_DEFINE (scm_bytevector_s16_native_ref, "bytevector-s16-native-ref",
1266 2, 0, 0,
1267 (SCM bv, SCM index),
1268 "Return the unsigned 16-bit integer from @var{bv} at "
1269 "@var{index} using the native endianness.")
1270#define FUNC_NAME s_scm_bytevector_s16_native_ref
1271{
1272 INTEGER_NATIVE_REF (16, signed);
1273}
1274#undef FUNC_NAME
1275
1276SCM_DEFINE (scm_bytevector_u16_set_x, "bytevector-u16-set!",
1277 4, 0, 0,
1278 (SCM bv, SCM index, SCM value, SCM endianness),
1279 "Store @var{value} in @var{bv} at @var{index} according to "
1280 "@var{endianness}.")
1281#define FUNC_NAME s_scm_bytevector_u16_set_x
1282{
1283 INTEGER_SET (16, unsigned);
1284}
1285#undef FUNC_NAME
1286
1287SCM_DEFINE (scm_bytevector_s16_set_x, "bytevector-s16-set!",
1288 4, 0, 0,
1289 (SCM bv, SCM index, SCM value, SCM endianness),
1290 "Store @var{value} in @var{bv} at @var{index} according to "
1291 "@var{endianness}.")
1292#define FUNC_NAME s_scm_bytevector_s16_set_x
1293{
1294 INTEGER_SET (16, signed);
1295}
1296#undef FUNC_NAME
1297
1298SCM_DEFINE (scm_bytevector_u16_native_set_x, "bytevector-u16-native-set!",
1299 3, 0, 0,
1300 (SCM bv, SCM index, SCM value),
1301 "Store the unsigned integer @var{value} at index @var{index} "
1302 "of @var{bv} using the native endianness.")
1303#define FUNC_NAME s_scm_bytevector_u16_native_set_x
1304{
1305 INTEGER_NATIVE_SET (16, unsigned);
1306}
1307#undef FUNC_NAME
1308
1309SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!",
1310 3, 0, 0,
1311 (SCM bv, SCM index, SCM value),
1312 "Store the signed integer @var{value} at index @var{index} "
1313 "of @var{bv} using the native endianness.")
1314#define FUNC_NAME s_scm_bytevector_s16_native_set_x
1315{
1316 INTEGER_NATIVE_SET (16, signed);
1317}
1318#undef FUNC_NAME
1319
1320
1321\f
1322/* Operations on 32-bit integers. */
1323
1324/* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
1325 arbitrary 32-bit integers. Thus we fall back to using the
1326 `large_{ref,set}' variants on 32-bit machines. */
1327
1328#define LARGE_INTEGER_REF(_len, _sign) \
1329 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1330 SCM_VALIDATE_SYMBOL (3, endianness); \
1331 \
1332 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
1333 SIGNEDNESS (_sign), endianness));
1334
1335#define LARGE_INTEGER_SET(_len, _sign) \
1336 int err; \
1337 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1338 SCM_VALIDATE_SYMBOL (4, endianness); \
1339 \
1340 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1341 SIGNEDNESS (_sign), value, endianness); \
1342 if (SCM_UNLIKELY (err)) \
1343 scm_out_of_range (FUNC_NAME, value); \
1344 \
1345 return SCM_UNSPECIFIED;
1346
1347#define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
1348 INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
1349 return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
caa92f5e 1350 SIGNEDNESS (_sign), scm_i_native_endianness));
1ee2c72e
LC		 1351
1352#define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
1353 int err; \
1354 INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
1355 \
1356 err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
1357 SIGNEDNESS (_sign), value, \
caa92f5e 1358 scm_i_native_endianness); \
1ee2c72e
LC		 1359 if (SCM_UNLIKELY (err)) \
1360 scm_out_of_range (FUNC_NAME, value); \
1361 \
1362 return SCM_UNSPECIFIED;
1363
1364
1365SCM_DEFINE (scm_bytevector_u32_ref, "bytevector-u32-ref",
1366 3, 0, 0,
1367 (SCM bv, SCM index, SCM endianness),
1368 "Return the unsigned 32-bit integer from @var{bv} at "
1369 "@var{index}.")
1370#define FUNC_NAME s_scm_bytevector_u32_ref
1371{
1372#if SIZEOF_VOID_P > 4
1373 INTEGER_REF (32, unsigned);
1374#else
1375 LARGE_INTEGER_REF (32, unsigned);
1376#endif
1377}
1378#undef FUNC_NAME
1379
1380SCM_DEFINE (scm_bytevector_s32_ref, "bytevector-s32-ref",
1381 3, 0, 0,
1382 (SCM bv, SCM index, SCM endianness),
1383 "Return the signed 32-bit integer from @var{bv} at "
1384 "@var{index}.")
1385#define FUNC_NAME s_scm_bytevector_s32_ref
1386{
1387#if SIZEOF_VOID_P > 4
1388 INTEGER_REF (32, signed);
1389#else
1390 LARGE_INTEGER_REF (32, signed);
1391#endif
1392}
1393#undef FUNC_NAME
1394
1395SCM_DEFINE (scm_bytevector_u32_native_ref, "bytevector-u32-native-ref",
1396 2, 0, 0,
1397 (SCM bv, SCM index),
1398 "Return the unsigned 32-bit integer from @var{bv} at "
1399 "@var{index} using the native endianness.")
1400#define FUNC_NAME s_scm_bytevector_u32_native_ref
1401{
1402#if SIZEOF_VOID_P > 4
1403 INTEGER_NATIVE_REF (32, unsigned);
1404#else
1405 LARGE_INTEGER_NATIVE_REF (32, unsigned);
1406#endif
1407}
1408#undef FUNC_NAME
1409
1410SCM_DEFINE (scm_bytevector_s32_native_ref, "bytevector-s32-native-ref",
1411 2, 0, 0,
1412 (SCM bv, SCM index),
1413 "Return the unsigned 32-bit integer from @var{bv} at "
1414 "@var{index} using the native endianness.")
1415#define FUNC_NAME s_scm_bytevector_s32_native_ref
1416{
1417#if SIZEOF_VOID_P > 4
1418 INTEGER_NATIVE_REF (32, signed);
1419#else
1420 LARGE_INTEGER_NATIVE_REF (32, signed);
1421#endif
1422}
1423#undef FUNC_NAME
1424
1425SCM_DEFINE (scm_bytevector_u32_set_x, "bytevector-u32-set!",
1426 4, 0, 0,
1427 (SCM bv, SCM index, SCM value, SCM endianness),
1428 "Store @var{value} in @var{bv} at @var{index} according to "
1429 "@var{endianness}.")
1430#define FUNC_NAME s_scm_bytevector_u32_set_x
1431{
1432#if SIZEOF_VOID_P > 4
1433 INTEGER_SET (32, unsigned);
1434#else
1435 LARGE_INTEGER_SET (32, unsigned);
1436#endif
1437}
1438#undef FUNC_NAME
1439
1440SCM_DEFINE (scm_bytevector_s32_set_x, "bytevector-s32-set!",
1441 4, 0, 0,
1442 (SCM bv, SCM index, SCM value, SCM endianness),
1443 "Store @var{value} in @var{bv} at @var{index} according to "
1444 "@var{endianness}.")
1445#define FUNC_NAME s_scm_bytevector_s32_set_x
1446{
1447#if SIZEOF_VOID_P > 4
1448 INTEGER_SET (32, signed);
1449#else
1450 LARGE_INTEGER_SET (32, signed);
1451#endif
1452}
1453#undef FUNC_NAME
1454
1455SCM_DEFINE (scm_bytevector_u32_native_set_x, "bytevector-u32-native-set!",
1456 3, 0, 0,
1457 (SCM bv, SCM index, SCM value),
1458 "Store the unsigned integer @var{value} at index @var{index} "
1459 "of @var{bv} using the native endianness.")
1460#define FUNC_NAME s_scm_bytevector_u32_native_set_x
1461{
1462#if SIZEOF_VOID_P > 4
1463 INTEGER_NATIVE_SET (32, unsigned);
1464#else
1465 LARGE_INTEGER_NATIVE_SET (32, unsigned);
1466#endif
1467}
1468#undef FUNC_NAME
1469
1470SCM_DEFINE (scm_bytevector_s32_native_set_x, "bytevector-s32-native-set!",
1471 3, 0, 0,
1472 (SCM bv, SCM index, SCM value),
1473 "Store the signed integer @var{value} at index @var{index} "
1474 "of @var{bv} using the native endianness.")
1475#define FUNC_NAME s_scm_bytevector_s32_native_set_x
1476{
1477#if SIZEOF_VOID_P > 4
1478 INTEGER_NATIVE_SET (32, signed);
1479#else
1480 LARGE_INTEGER_NATIVE_SET (32, signed);
1481#endif
1482}
1483#undef FUNC_NAME
1484
1485
1486\f
1487/* Operations on 64-bit integers. */
1488
1489/* For 64-bit integers, we use only the `large_{ref,set}' variant. */
1490
1491SCM_DEFINE (scm_bytevector_u64_ref, "bytevector-u64-ref",
1492 3, 0, 0,
1493 (SCM bv, SCM index, SCM endianness),
1494 "Return the unsigned 64-bit integer from @var{bv} at "
1495 "@var{index}.")
1496#define FUNC_NAME s_scm_bytevector_u64_ref
1497{
1498 LARGE_INTEGER_REF (64, unsigned);
1499}
1500#undef FUNC_NAME
1501
1502SCM_DEFINE (scm_bytevector_s64_ref, "bytevector-s64-ref",
1503 3, 0, 0,
1504 (SCM bv, SCM index, SCM endianness),
1505 "Return the signed 64-bit integer from @var{bv} at "
1506 "@var{index}.")
1507#define FUNC_NAME s_scm_bytevector_s64_ref
1508{
1509 LARGE_INTEGER_REF (64, signed);
1510}
1511#undef FUNC_NAME
1512
1513SCM_DEFINE (scm_bytevector_u64_native_ref, "bytevector-u64-native-ref",
1514 2, 0, 0,
1515 (SCM bv, SCM index),
1516 "Return the unsigned 64-bit integer from @var{bv} at "
1517 "@var{index} using the native endianness.")
1518#define FUNC_NAME s_scm_bytevector_u64_native_ref
1519{
1520 LARGE_INTEGER_NATIVE_REF (64, unsigned);
1521}
1522#undef FUNC_NAME
1523
1524SCM_DEFINE (scm_bytevector_s64_native_ref, "bytevector-s64-native-ref",
1525 2, 0, 0,
1526 (SCM bv, SCM index),
1527 "Return the unsigned 64-bit integer from @var{bv} at "
1528 "@var{index} using the native endianness.")
1529#define FUNC_NAME s_scm_bytevector_s64_native_ref
1530{
1531 LARGE_INTEGER_NATIVE_REF (64, signed);
1532}
1533#undef FUNC_NAME
1534
1535SCM_DEFINE (scm_bytevector_u64_set_x, "bytevector-u64-set!",
1536 4, 0, 0,
1537 (SCM bv, SCM index, SCM value, SCM endianness),
1538 "Store @var{value} in @var{bv} at @var{index} according to "
1539 "@var{endianness}.")
1540#define FUNC_NAME s_scm_bytevector_u64_set_x
1541{
1542 LARGE_INTEGER_SET (64, unsigned);
1543}
1544#undef FUNC_NAME
1545
1546SCM_DEFINE (scm_bytevector_s64_set_x, "bytevector-s64-set!",
1547 4, 0, 0,
1548 (SCM bv, SCM index, SCM value, SCM endianness),
1549 "Store @var{value} in @var{bv} at @var{index} according to "
1550 "@var{endianness}.")
1551#define FUNC_NAME s_scm_bytevector_s64_set_x
1552{
1553 LARGE_INTEGER_SET (64, signed);
1554}
1555#undef FUNC_NAME
1556
1557SCM_DEFINE (scm_bytevector_u64_native_set_x, "bytevector-u64-native-set!",
1558 3, 0, 0,
1559 (SCM bv, SCM index, SCM value),
1560 "Store the unsigned integer @var{value} at index @var{index} "
1561 "of @var{bv} using the native endianness.")
1562#define FUNC_NAME s_scm_bytevector_u64_native_set_x
1563{
1564 LARGE_INTEGER_NATIVE_SET (64, unsigned);
1565}
1566#undef FUNC_NAME
1567
1568SCM_DEFINE (scm_bytevector_s64_native_set_x, "bytevector-s64-native-set!",
1569 3, 0, 0,
1570 (SCM bv, SCM index, SCM value),
1571 "Store the signed integer @var{value} at index @var{index} "
1572 "of @var{bv} using the native endianness.")
1573#define FUNC_NAME s_scm_bytevector_s64_native_set_x
1574{
1575 LARGE_INTEGER_NATIVE_SET (64, signed);
1576}
1577#undef FUNC_NAME
1578
1579
1580\f
1581/* Operations on IEEE-754 numbers. */
1582
1583/* There are two possible word endians, visible in glibc's <ieee754.h>.
1584 However, in R6RS, when the endianness is `little', little endian is
1585 assumed for both the byte order and the word order. This is clear from
1586 Section 2.1 of R6RS-lib (in response to
1587 http://www.r6rs.org/formal-comments/comment-187.txt). */
1588
398446c7
LC		 1589union scm_ieee754_float
1590{
1591 float f;
1592 scm_t_uint32 i;
1593};
1594
1595union scm_ieee754_double
1596{
1597 double d;
1598 scm_t_uint64 i;
1599};
1600
1ee2c72e
LC		 1601
1602/* Convert to/from a floating-point number with different endianness. This
1603 method is probably not the most efficient but it should be portable. */
1604
1605static inline void
1606float_to_foreign_endianness (union scm_ieee754_float *target,
1607 float source)
1608{
398446c7 1609 union scm_ieee754_float input;
1ee2c72e 1610
398446c7
LC		 1611 input.f = source;
1612 target->i = bswap_32 (input.i);
1ee2c72e
LC		 1613}
1614
1615static inline float
1616float_from_foreign_endianness (const union scm_ieee754_float *source)
1617{
1618 union scm_ieee754_float result;
1619
398446c7 1620 result.i = bswap_32 (source->i);
1ee2c72e
LC		 1621
1622 return (result.f);
1623}
1624
1625static inline void
1626double_to_foreign_endianness (union scm_ieee754_double *target,
1627 double source)
1628{
398446c7 1629 union scm_ieee754_double input;
1ee2c72e 1630
398446c7
LC		 1631 input.d = source;
1632 target->i = bswap_64 (input.i);
1ee2c72e
LC		 1633}
1634
1635static inline double
1636double_from_foreign_endianness (const union scm_ieee754_double *source)
1637{
1638 union scm_ieee754_double result;
1639
398446c7 1640 result.i = bswap_64 (source->i);
1ee2c72e
LC		 1641
1642 return (result.d);
1643}
1644
1645/* Template macros to abstract over doubles and floats.
1646 XXX: Guile can only convert to/from doubles. */
1647#define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type
1648#define IEEE754_TO_SCM(_c_type) scm_from_double
1649#define IEEE754_FROM_SCM(_c_type) scm_to_double
1650#define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
1651 _c_type ## _from_foreign_endianness
1652#define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
1653 _c_type ## _to_foreign_endianness
1654
1655
cd43fdc5
AW		 1656/* FIXME: SCM_VALIDATE_REAL rejects integers, etc. grrr */
1657#define VALIDATE_REAL(pos, v) \
1658 do { \
ae255d65 1659 SCM_ASSERT_TYPE (scm_is_real (v), v, pos, FUNC_NAME, "real"); \
cd43fdc5
AW		 1660 } while (0)
1661
1ee2c72e
LC		 1662/* Templace getters and setters. */
1663
1664#define IEEE754_ACCESSOR_PROLOGUE(_type) \
1665 INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
1666
1667#define IEEE754_REF(_type) \
1668 _type c_result; \
1669 \
1670 IEEE754_ACCESSOR_PROLOGUE (_type); \
1671 SCM_VALIDATE_SYMBOL (3, endianness); \
1672 \
caa92f5e 1673 if (scm_is_eq (endianness, scm_i_native_endianness)) \
1ee2c72e
LC		 1674 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1675 else \
1676 { \
1677 IEEE754_UNION (_type) c_raw; \
1678 \
1679 memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
1680 c_result = \
1681 IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
1682 } \
1683 \
1684 return (IEEE754_TO_SCM (_type) (c_result));
1685
1686#define IEEE754_NATIVE_REF(_type) \
1687 _type c_result; \
1688 \
1689 IEEE754_ACCESSOR_PROLOGUE (_type); \
1690 \
1691 memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
1692 return (IEEE754_TO_SCM (_type) (c_result));
1693
1694#define IEEE754_SET(_type) \
1695 _type c_value; \
1696 \
1697 IEEE754_ACCESSOR_PROLOGUE (_type); \
cd43fdc5 1698 VALIDATE_REAL (3, value); \
1ee2c72e
LC		 1699 SCM_VALIDATE_SYMBOL (4, endianness); \
1700 c_value = IEEE754_FROM_SCM (_type) (value); \
1701 \
caa92f5e 1702 if (scm_is_eq (endianness, scm_i_native_endianness)) \
1ee2c72e
LC		 1703 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1704 else \
1705 { \
1706 IEEE754_UNION (_type) c_raw; \
1707 \
1708 IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
1709 memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
1710 } \
1711 \
1712 return SCM_UNSPECIFIED;
1713
1714#define IEEE754_NATIVE_SET(_type) \
1715 _type c_value; \
1716 \
1717 IEEE754_ACCESSOR_PROLOGUE (_type); \
cd43fdc5 1718 VALIDATE_REAL (3, value); \
1ee2c72e
LC		 1719 c_value = IEEE754_FROM_SCM (_type) (value); \
1720 \
1721 memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
1722 return SCM_UNSPECIFIED;
1723
1724
1725/* Single precision. */
1726
1727SCM_DEFINE (scm_bytevector_ieee_single_ref,
1728 "bytevector-ieee-single-ref",
1729 3, 0, 0,
1730 (SCM bv, SCM index, SCM endianness),
1731 "Return the IEEE-754 single from @var{bv} at "
1732 "@var{index}.")
1733#define FUNC_NAME s_scm_bytevector_ieee_single_ref
1734{
1735 IEEE754_REF (float);
1736}
1737#undef FUNC_NAME
1738
1739SCM_DEFINE (scm_bytevector_ieee_single_native_ref,
1740 "bytevector-ieee-single-native-ref",
1741 2, 0, 0,
1742 (SCM bv, SCM index),
1743 "Return the IEEE-754 single from @var{bv} at "
1744 "@var{index} using the native endianness.")
1745#define FUNC_NAME s_scm_bytevector_ieee_single_native_ref
1746{
1747 IEEE754_NATIVE_REF (float);
1748}
1749#undef FUNC_NAME
1750
1751SCM_DEFINE (scm_bytevector_ieee_single_set_x,
1752 "bytevector-ieee-single-set!",
1753 4, 0, 0,
1754 (SCM bv, SCM index, SCM value, SCM endianness),
1755 "Store real @var{value} in @var{bv} at @var{index} according to "
1756 "@var{endianness}.")
1757#define FUNC_NAME s_scm_bytevector_ieee_single_set_x
1758{
1759 IEEE754_SET (float);
1760}
1761#undef FUNC_NAME
1762
1763SCM_DEFINE (scm_bytevector_ieee_single_native_set_x,
1764 "bytevector-ieee-single-native-set!",
1765 3, 0, 0,
1766 (SCM bv, SCM index, SCM value),
1767 "Store the real @var{value} at index @var{index} "
1768 "of @var{bv} using the native endianness.")
1769#define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x
1770{
1771 IEEE754_NATIVE_SET (float);
1772}
1773#undef FUNC_NAME
1774
1775
1776/* Double precision. */
1777
1778SCM_DEFINE (scm_bytevector_ieee_double_ref,
1779 "bytevector-ieee-double-ref",
1780 3, 0, 0,
1781 (SCM bv, SCM index, SCM endianness),
1782 "Return the IEEE-754 double from @var{bv} at "
1783 "@var{index}.")
1784#define FUNC_NAME s_scm_bytevector_ieee_double_ref
1785{
1786 IEEE754_REF (double);
1787}
1788#undef FUNC_NAME
1789
1790SCM_DEFINE (scm_bytevector_ieee_double_native_ref,
1791 "bytevector-ieee-double-native-ref",
1792 2, 0, 0,
1793 (SCM bv, SCM index),
1794 "Return the IEEE-754 double from @var{bv} at "
1795 "@var{index} using the native endianness.")
1796#define FUNC_NAME s_scm_bytevector_ieee_double_native_ref
1797{
1798 IEEE754_NATIVE_REF (double);
1799}
1800#undef FUNC_NAME
1801
1802SCM_DEFINE (scm_bytevector_ieee_double_set_x,
1803 "bytevector-ieee-double-set!",
1804 4, 0, 0,
1805 (SCM bv, SCM index, SCM value, SCM endianness),
1806 "Store real @var{value} in @var{bv} at @var{index} according to "
1807 "@var{endianness}.")
1808#define FUNC_NAME s_scm_bytevector_ieee_double_set_x
1809{
1810 IEEE754_SET (double);
1811}
1812#undef FUNC_NAME
1813
1814SCM_DEFINE (scm_bytevector_ieee_double_native_set_x,
1815 "bytevector-ieee-double-native-set!",
1816 3, 0, 0,
1817 (SCM bv, SCM index, SCM value),
1818 "Store the real @var{value} at index @var{index} "
1819 "of @var{bv} using the native endianness.")
1820#define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x
1821{
1822 IEEE754_NATIVE_SET (double);
1823}
1824#undef FUNC_NAME
1825
1826
1827#undef IEEE754_UNION
1828#undef IEEE754_TO_SCM
1829#undef IEEE754_FROM_SCM
1830#undef IEEE754_FROM_FOREIGN_ENDIANNESS
1831#undef IEEE754_TO_FOREIGN_ENDIANNESS
1832#undef IEEE754_REF
1833#undef IEEE754_NATIVE_REF
1834#undef IEEE754_SET
1835#undef IEEE754_NATIVE_SET
1836
1837\f
1838/* Operations on strings. */
1839
1840
1841/* Produce a function that returns the length of a UTF-encoded string. */
1842#define UTF_STRLEN_FUNCTION(_utf_width) \
1843static inline size_t \
1844utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
1845{ \
1846 size_t len = 0; \
1847 const uint ## _utf_width ## _t *ptr; \
1848 for (ptr = str; \
1849 *ptr != 0; \
1850 ptr++) \
1851 { \
1852 len++; \
1853 } \
1854 \
1855 return (len * ((_utf_width) / 8)); \
1856}
1857
1858UTF_STRLEN_FUNCTION (8)
1859
1860
1861/* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
1862#define UTF_STRLEN(_utf_width, _str) \
1863 utf ## _utf_width ## _strlen (_str)
1864
1865/* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
1866 ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
1867 encoding name). */
1868static inline void
1869utf_encoding_name (char *name, size_t utf_width, SCM endianness)
1870{
1871 strcpy (name, "UTF-");
1872 strcat (name, ((utf_width == 8)
1873 ? "8"
1874 : ((utf_width == 16)
1875 ? "16"
1876 : ((utf_width == 32)
1877 ? "32"
1878 : "??"))));
1879 strcat (name,
1880 ((scm_is_eq (endianness, scm_sym_big))
1881 ? "BE"
1882 : ((scm_is_eq (endianness, scm_sym_little))
1883 ? "LE"
1884 : "unknown")));
1885}
1886
1887/* Maximum length of a UTF encoding name. */
1888#define MAX_UTF_ENCODING_NAME_LEN 16
1889
1890/* Produce the body of a `string->utf' function. */
3a5bc4fa
MG		 1891#define STRING_TO_UTF(_utf_width) \
1892 SCM utf; \
1893 int err; \
1894 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
1895 char *c_utf = NULL; \
1896 size_t c_strlen, c_utf_len = 0; \
1897 \
1898 SCM_VALIDATE_STRING (1, str); \
d223c3fc 1899 if (scm_is_eq (endianness, SCM_UNDEFINED)) \
3a5bc4fa
MG		 1900 endianness = scm_sym_big; \
1901 else \
1902 SCM_VALIDATE_SYMBOL (2, endianness); \
1903 \
1904 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
1905 \
1906 c_strlen = scm_i_string_length (str); \
1907 if (scm_i_is_narrow_string (str)) \
1908 { \
1909 err = mem_iconveh (scm_i_string_chars (str), c_strlen, \
1910 "ISO-8859-1", c_utf_name, \
1911 iconveh_question_mark, NULL, \
1912 &c_utf, &c_utf_len); \
1913 if (SCM_UNLIKELY (err)) \
1914 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1915 scm_list_1 (str), err); \
1916 } \
1917 else \
1918 { \
1919 const scm_t_wchar *wbuf = scm_i_string_wide_chars (str); \
1920 c_utf = u32_conv_to_encoding (c_utf_name, \
1921 iconveh_question_mark, \
1922 (scm_t_uint32 *) wbuf, \
1923 c_strlen, NULL, NULL, &c_utf_len); \
1924 if (SCM_UNLIKELY (c_utf == NULL)) \
1925 scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
1926 scm_list_1 (str), errno); \
1927 } \
1928 scm_dynwind_begin (0); \
1929 scm_dynwind_free (c_utf); \
1930 utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8); \
1931 memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len); \
1932 scm_dynwind_end (); \
1933 \
1934 return (utf);
1ee2c72e
LC		 1935
1936
1937
1938SCM_DEFINE (scm_string_to_utf8, "string->utf8",
1939 1, 0, 0,
1940 (SCM str),
1941 "Return a newly allocated bytevector that contains the UTF-8 "
1942 "encoding of @var{str}.")
1943#define FUNC_NAME s_scm_string_to_utf8
1944{
1945 SCM utf;
c2c3bddb
AW		 1946 scm_t_uint8 *c_utf;
1947 size_t c_utf_len = 0;
1ee2c72e
LC		 1948
1949 SCM_VALIDATE_STRING (1, str);
1950
c2c3bddb
AW		 1951 c_utf = (scm_t_uint8 *) scm_to_utf8_stringn (str, &c_utf_len);
1952 utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
1953 memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len);
1954 free (c_utf);
1ee2c72e
LC		 1955
1956 return (utf);
1957}
1958#undef FUNC_NAME
1959
1960SCM_DEFINE (scm_string_to_utf16, "string->utf16",
1961 1, 1, 0,
1962 (SCM str, SCM endianness),
1963 "Return a newly allocated bytevector that contains the UTF-16 "
1964 "encoding of @var{str}.")
1965#define FUNC_NAME s_scm_string_to_utf16
1966{
1967 STRING_TO_UTF (16);
1968}
1969#undef FUNC_NAME
1970
c2c3bddb
AW		 1971static void
1972swap_u32 (scm_t_wchar *vals, size_t len)
1973{
1974 size_t n;
1975 for (n = 0; n < len; n++)
1976 vals[n] = bswap_32 (vals[n]);
1977}
1978
1ee2c72e
LC		 1979SCM_DEFINE (scm_string_to_utf32, "string->utf32",
1980 1, 1, 0,
1981 (SCM str, SCM endianness),
1982 "Return a newly allocated bytevector that contains the UTF-32 "
1983 "encoding of @var{str}.")
1984#define FUNC_NAME s_scm_string_to_utf32
1985{
c2c3bddb
AW		 1986 SCM bv;
1987 scm_t_wchar *wchars;
1988 size_t wchar_len, bytes_len;
1989
1990 wchars = scm_to_utf32_stringn (str, &wchar_len);
1991 bytes_len = wchar_len * sizeof (scm_t_wchar);
1992 if (!scm_is_eq (SCM_UNBNDP (endianness) ? scm_endianness_big : endianness,
1993 scm_i_native_endianness))
1994 swap_u32 (wchars, wchar_len);
1995
1996 bv = make_bytevector (bytes_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
1997 memcpy (SCM_BYTEVECTOR_CONTENTS (bv), wchars, bytes_len);
1998 free (wchars);
1999
2000 return bv;
1ee2c72e
LC		 2001}
2002#undef FUNC_NAME
2003
2004
2005/* Produce the body of a function that converts a UTF-encoded bytevector to a
2006 string. */
2007#define UTF_TO_STRING(_utf_width) \
2008 SCM str = SCM_BOOL_F; \
2009 int err; \
3a5bc4fa 2010 char *c_str = NULL; \
1ee2c72e 2011 char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
3a5bc4fa
MG		 2012 char *c_utf; \
2013 size_t c_strlen = 0, c_utf_len = 0; \
1ee2c72e
LC		 2014 \
2015 SCM_VALIDATE_BYTEVECTOR (1, utf); \
d223c3fc 2016 if (scm_is_eq (endianness, SCM_UNDEFINED)) \
1ee2c72e
LC		 2017 endianness = scm_sym_big; \
2018 else \
2019 SCM_VALIDATE_SYMBOL (2, endianness); \
2020 \
2021 c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \
2022 c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
2023 utf_encoding_name (c_utf_name, (_utf_width), endianness); \
2024 \
1ee2c72e 2025 err = mem_iconveh (c_utf, c_utf_len, \
3a5bc4fa 2026 c_utf_name, "UTF-8", \
1ee2c72e
LC		 2027 iconveh_question_mark, NULL, \
2028 &c_str, &c_strlen); \
2029 if (SCM_UNLIKELY (err)) \
2030 scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
2031 scm_list_1 (utf), err); \
2032 else \
3a5bc4fa 2033 { \
686df516 2034 str = scm_from_utf8_stringn (c_str, c_strlen); \
3a5bc4fa
MG		 2035 free (c_str); \
2036 } \
1ee2c72e
LC		 2037 return (str);
2038
2039
2040SCM_DEFINE (scm_utf8_to_string, "utf8->string",
2041 1, 0, 0,
2042 (SCM utf),
2043 "Return a newly allocate string that contains from the UTF-8-"
2044 "encoded contents of bytevector @var{utf}.")
2045#define FUNC_NAME s_scm_utf8_to_string
2046{
2047 SCM str;
1ee2c72e 2048 const char *c_utf;
3a5bc4fa 2049 size_t c_utf_len = 0;
1ee2c72e
LC		 2050
2051 SCM_VALIDATE_BYTEVECTOR (1, utf);
2052
2053 c_utf_len = SCM_BYTEVECTOR_LENGTH (utf);
1ee2c72e 2054 c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf);
8c76a897 2055 str = scm_from_utf8_stringn (c_utf, c_utf_len);
1ee2c72e
LC		 2056
2057 return (str);
2058}
2059#undef FUNC_NAME
2060
2061SCM_DEFINE (scm_utf16_to_string, "utf16->string",
2062 1, 1, 0,
2063 (SCM utf, SCM endianness),
2064 "Return a newly allocate string that contains from the UTF-16-"
2065 "encoded contents of bytevector @var{utf}.")
2066#define FUNC_NAME s_scm_utf16_to_string
2067{
2068 UTF_TO_STRING (16);
2069}
2070#undef FUNC_NAME
2071
2072SCM_DEFINE (scm_utf32_to_string, "utf32->string",
2073 1, 1, 0,
2074 (SCM utf, SCM endianness),
2075 "Return a newly allocate string that contains from the UTF-32-"
2076 "encoded contents of bytevector @var{utf}.")
2077#define FUNC_NAME s_scm_utf32_to_string
2078{
2079 UTF_TO_STRING (32);
2080}
2081#undef FUNC_NAME
2082
1ee2c72e 2083\f
2a610be5
AW		 2084/* Bytevectors as generalized vectors & arrays. */
2085
4bc95fcc
LC		 2086#define COMPLEX_ACCESSOR_PROLOGUE(_type) \
2087 size_t c_len, c_index; \
2088 char *c_bv; \
2089 \
2090 SCM_VALIDATE_BYTEVECTOR (1, bv); \
2091 c_index = scm_to_size_t (index); \
2092 \
2093 c_len = SCM_BYTEVECTOR_LENGTH (bv); \
2094 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
2095 \
2096 if (SCM_UNLIKELY (c_index + 2 * sizeof (_type) - 1 >= c_len)) \
2097 scm_out_of_range (FUNC_NAME, index);
e286c973 2098
4bc95fcc
LC		 2099/* Template for native access to complex numbers of type TYPE. */
2100#define COMPLEX_NATIVE_REF(_type) \
2101 SCM result; \
2102 \
2103 COMPLEX_ACCESSOR_PROLOGUE (_type); \
2104 \
2105 { \
2106 _type real, imag; \
2107 \
2108 memcpy (&real, &c_bv[c_index], sizeof (_type)); \
2109 memcpy (&imag, &c_bv[c_index + sizeof (_type)], sizeof (_type)); \
2110 \
2111 result = scm_c_make_rectangular (real, imag); \
2112 } \
2113 \
2114 return result;
e286c973
AW		 2115
2116static SCM
4bc95fcc
LC		 2117bytevector_ref_c32 (SCM bv, SCM index)
2118#define FUNC_NAME "bytevector_ref_c32"
2119{
2120 COMPLEX_NATIVE_REF (float);
e286c973 2121}
4bc95fcc 2122#undef FUNC_NAME
e286c973
AW		 2123
2124static SCM
4bc95fcc
LC		 2125bytevector_ref_c64 (SCM bv, SCM index)
2126#define FUNC_NAME "bytevector_ref_c64"
2127{
2128 COMPLEX_NATIVE_REF (double);
e286c973 2129}
4bc95fcc 2130#undef FUNC_NAME
e286c973
AW		 2131
2132typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM);
2133
4bc95fcc
LC		 2134static const scm_t_bytevector_ref_fn
2135bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
e286c973
AW		 2136{
2137 NULL, /* SCM */
2138 NULL, /* CHAR */
2139 NULL, /* BIT */
2140 scm_bytevector_u8_ref, /* VU8 */
2141 scm_bytevector_u8_ref, /* U8 */
2142 scm_bytevector_s8_ref,
2143 scm_bytevector_u16_native_ref,
2144 scm_bytevector_s16_native_ref,
2145 scm_bytevector_u32_native_ref,
2146 scm_bytevector_s32_native_ref,
2147 scm_bytevector_u64_native_ref,
2148 scm_bytevector_s64_native_ref,
2149 scm_bytevector_ieee_single_native_ref,
2150 scm_bytevector_ieee_double_native_ref,
2151 bytevector_ref_c32,
2152 bytevector_ref_c64
2153};
2154
2a610be5
AW		 2155static SCM
2156bv_handle_ref (scm_t_array_handle *h, size_t index)
2157{
e286c973
AW		 2158 SCM byte_index;
2159 scm_t_bytevector_ref_fn ref_fn;
2160
2161 ref_fn = bytevector_ref_fns[h->element_type];
2162 byte_index =
2163 scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
2164 return ref_fn (h->array, byte_index);
2165}
2166
4bc95fcc
LC		 2167/* Template for native modification of complex numbers of type TYPE. */
2168#define COMPLEX_NATIVE_SET(_type) \
2169 COMPLEX_ACCESSOR_PROLOGUE (_type); \
2170 \
2171 { \
2172 _type real, imag; \
2173 real = scm_c_real_part (value); \
2174 imag = scm_c_imag_part (value); \
2175 \
2176 memcpy (&c_bv[c_index], &real, sizeof (_type)); \
2177 memcpy (&c_bv[c_index + sizeof (_type)], &imag, sizeof (_type)); \
2178 } \
2179 \
e286c973 2180 return SCM_UNSPECIFIED;
4bc95fcc 2181
e286c973 2182static SCM
4bc95fcc
LC		 2183bytevector_set_c32 (SCM bv, SCM index, SCM value)
2184#define FUNC_NAME "bytevector_set_c32"
1e8f9392 2185{
4bc95fcc 2186 COMPLEX_NATIVE_SET (float);
2a610be5 2187}
4bc95fcc 2188#undef FUNC_NAME
2a610be5 2189
e286c973 2190static SCM
4bc95fcc
LC		 2191bytevector_set_c64 (SCM bv, SCM index, SCM value)
2192#define FUNC_NAME "bytevector_set_c64"
1e8f9392 2193{
4bc95fcc 2194 COMPLEX_NATIVE_SET (double);
e286c973 2195}
4bc95fcc 2196#undef FUNC_NAME
e286c973
AW		 2197
2198typedef SCM (*scm_t_bytevector_set_fn)(SCM, SCM, SCM);
2199
2200const scm_t_bytevector_set_fn bytevector_set_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
2201{
2202 NULL, /* SCM */
2203 NULL, /* CHAR */
2204 NULL, /* BIT */
2205 scm_bytevector_u8_set_x, /* VU8 */
2206 scm_bytevector_u8_set_x, /* U8 */
2207 scm_bytevector_s8_set_x,
2208 scm_bytevector_u16_native_set_x,
2209 scm_bytevector_s16_native_set_x,
2210 scm_bytevector_u32_native_set_x,
2211 scm_bytevector_s32_native_set_x,
2212 scm_bytevector_u64_native_set_x,
2213 scm_bytevector_s64_native_set_x,
2214 scm_bytevector_ieee_single_native_set_x,
2215 scm_bytevector_ieee_double_native_set_x,
2216 bytevector_set_c32,
2217 bytevector_set_c64
2218};
2219
2a610be5
AW		 2220static void
2221bv_handle_set_x (scm_t_array_handle *h, size_t index, SCM val)
2222{
e286c973
AW		 2223 SCM byte_index;
2224 scm_t_bytevector_set_fn set_fn;
2225
2226 set_fn = bytevector_set_fns[h->element_type];
2227 byte_index =
2228 scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
2229 set_fn (h->array, byte_index, val);
2a610be5
AW		 2230}
2231
2232static void
2233bytevector_get_handle (SCM v, scm_t_array_handle *h)
2234{
2235 h->array = v;
2236 h->ndims = 1;
2237 h->dims = &h->dim0;
2238 h->dim0.lbnd = 0;
e286c973 2239 h->dim0.ubnd = SCM_BYTEVECTOR_TYPED_LENGTH (v) - 1;
2a610be5 2240 h->dim0.inc = 1;
e286c973 2241 h->element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (v);
2a610be5
AW		 2242 h->elements = h->writable_elements = SCM_BYTEVECTOR_CONTENTS (v);
2243}
2244
2245\f
1ee2c72e
LC		 2246/* Initialization. */
2247
cfb4702f
LC		 2248void
2249scm_bootstrap_bytevectors (void)
2250{
807e5a66 2251 /* This must be instantiated here because the generalized-vector API may
07d22c02 2252 want to access bytevectors even though `(rnrs bytevectors)' hasn't been
807e5a66 2253 loaded. */
562cd1b8 2254 scm_null_bytevector = make_bytevector (0, SCM_ARRAY_ELEMENT_TYPE_VU8);
cfb4702f 2255
caa92f5e 2256#ifdef WORDS_BIGENDIAN
4a655e50 2257 scm_i_native_endianness = scm_from_latin1_symbol ("big");
caa92f5e 2258#else
4a655e50 2259 scm_i_native_endianness = scm_from_latin1_symbol ("little");
caa92f5e
AW		 2260#endif
2261
44602b08
AW		 2262 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
2263 "scm_init_bytevectors",
cfb4702f
LC		 2264 (scm_t_extension_init_func) scm_init_bytevectors,
2265 NULL);
2a610be5
AW		 2266
2267 {
2268 scm_t_array_implementation impl;
807e5a66
LC		 2269
2270 impl.tag = scm_tc7_bytevector;
2271 impl.mask = 0x7f;
2a610be5
AW		 2272 impl.vref = bv_handle_ref;
2273 impl.vset = bv_handle_set_x;
2274 impl.get_handle = bytevector_get_handle;
2275 scm_i_register_array_implementation (&impl);
f45eccff
AW		 2276 scm_i_register_vector_constructor
2277 (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8],
2278 scm_make_bytevector);
2a610be5 2279 }
cfb4702f
LC		 2280}
2281
1ee2c72e
LC		 2282void
2283scm_init_bytevectors (void)
2284{
2285#include "libguile/bytevectors.x"
2286
1ee2c72e
LC		 2287 scm_endianness_big = scm_sym_big;
2288 scm_endianness_little = scm_sym_little;
1ee2c72e 2289}
Unnamed repository; edit this file 'description' to name the repository.