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