Commit | Line | Data |
---|---|---|
69d2000d | 1 | /* srfi-4.c --- Uniform numeric vector datatypes. |
f8579182 | 2 | * |
438974d0 | 3 | * Copyright (C) 2001, 2004, 2006, 2009 Free Software Foundation, Inc. |
f8579182 MV |
4 | * |
5 | * This library is free software; you can redistribute it and/or | |
53befeb7 NJ |
6 | * modify it under the terms of the GNU Lesser General Public License |
7 | * as published by the Free Software Foundation; either version 3 of | |
8 | * the License, or (at your option) any later version. | |
f8579182 | 9 | * |
53befeb7 NJ |
10 | * This library is distributed in the hope that it will be useful, but |
11 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
f8579182 MV |
12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | * Lesser General Public License for more details. | |
14 | * | |
15 | * You should have received a copy of the GNU Lesser General Public | |
16 | * License along with this library; if not, write to the Free Software | |
53befeb7 NJ |
17 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
18 | * 02110-1301 USA | |
f8579182 MV |
19 | */ |
20 | ||
dbb605f5 | 21 | #ifdef HAVE_CONFIG_H |
69730f92 MV |
22 | # include <config.h> |
23 | #endif | |
24 | ||
f8579182 | 25 | #include <string.h> |
69730f92 | 26 | #include <errno.h> |
f8579182 MV |
27 | #include <stdio.h> |
28 | ||
69730f92 MV |
29 | #include "libguile/_scm.h" |
30 | #include "libguile/__scm.h" | |
1c44468d | 31 | #include "libguile/bdw-gc.h" |
f8579182 | 32 | #include "libguile/srfi-4.h" |
cf396142 | 33 | #include "libguile/bitvectors.h" |
438974d0 | 34 | #include "libguile/bytevectors.h" |
f332e957 | 35 | #include "libguile/generalized-vectors.h" |
476b894c | 36 | #include "libguile/uniform.h" |
f8579182 | 37 | #include "libguile/error.h" |
ac8ed3db | 38 | #include "libguile/eval.h" |
f8579182 MV |
39 | #include "libguile/read.h" |
40 | #include "libguile/ports.h" | |
41 | #include "libguile/chars.h" | |
69730f92 | 42 | #include "libguile/vectors.h" |
2fa901a5 | 43 | #include "libguile/arrays.h" |
69730f92 | 44 | #include "libguile/strings.h" |
00c17d45 | 45 | #include "libguile/strports.h" |
69730f92 | 46 | #include "libguile/dynwind.h" |
6e433d8b | 47 | #include "libguile/deprecation.h" |
69730f92 MV |
48 | |
49 | #ifdef HAVE_UNISTD_H | |
50 | #include <unistd.h> | |
51 | #endif | |
52 | ||
53 | #ifdef HAVE_IO_H | |
54 | #include <io.h> | |
55 | #endif | |
f8579182 | 56 | |
69d2000d | 57 | /* Smob type code for uniform numeric vectors. */ |
f8579182 MV |
58 | int scm_tc16_uvec = 0; |
59 | ||
4330ee25 | 60 | #define SCM_IS_UVEC(obj) SCM_SMOB_PREDICATE (scm_tc16_uvec, (obj)) |
f8579182 | 61 | |
69d2000d | 62 | /* Accessor macros for the three components of a uniform numeric |
f8579182 MV |
63 | vector: |
64 | - The type tag (one of the symbolic constants below). | |
65 | - The vector's length (counted in elements). | |
66 | - The address of the data area (holding the elements of the | |
67 | vector). */ | |
00f8b368 AW |
68 | #define SCM_UVEC_TYPE(u) (SCM_SMOB_DATA_1(u)) |
69 | #define SCM_UVEC_LENGTH(u) ((size_t)SCM_SMOB_DATA_2(u)) | |
70 | #define SCM_UVEC_BASE(u) ((void *)SCM_SMOB_DATA_3(u)) | |
f8579182 MV |
71 | |
72 | ||
69d2000d | 73 | /* Symbolic constants encoding the various types of uniform |
f8579182 MV |
74 | numeric vectors. */ |
75 | #define SCM_UVEC_U8 0 | |
76 | #define SCM_UVEC_S8 1 | |
77 | #define SCM_UVEC_U16 2 | |
78 | #define SCM_UVEC_S16 3 | |
79 | #define SCM_UVEC_U32 4 | |
80 | #define SCM_UVEC_S32 5 | |
81 | #define SCM_UVEC_U64 6 | |
82 | #define SCM_UVEC_S64 7 | |
83 | #define SCM_UVEC_F32 8 | |
84 | #define SCM_UVEC_F64 9 | |
cbdc8379 MV |
85 | #define SCM_UVEC_C32 10 |
86 | #define SCM_UVEC_C64 11 | |
f8579182 MV |
87 | |
88 | ||
89 | /* This array maps type tags to the size of the elements. */ | |
cbdc8379 | 90 | static const int uvec_sizes[12] = { |
f8579182 MV |
91 | 1, 1, |
92 | 2, 2, | |
93 | 4, 4, | |
00c17d45 | 94 | #if SCM_HAVE_T_INT64 |
f8579182 | 95 | 8, 8, |
00c17d45 MV |
96 | #else |
97 | sizeof (SCM), sizeof (SCM), | |
98 | #endif | |
cbdc8379 MV |
99 | sizeof(float), sizeof(double), |
100 | 2*sizeof(float), 2*sizeof(double) | |
f8579182 MV |
101 | }; |
102 | ||
cbdc8379 | 103 | static const char *uvec_tags[12] = { |
e0e49670 MV |
104 | "u8", "s8", |
105 | "u16", "s16", | |
106 | "u32", "s32", | |
107 | "u64", "s64", | |
cbdc8379 MV |
108 | "f32", "f64", |
109 | "c32", "c64", | |
e0e49670 MV |
110 | }; |
111 | ||
cbdc8379 | 112 | static const char *uvec_names[12] = { |
f8579182 MV |
113 | "u8vector", "s8vector", |
114 | "u16vector", "s16vector", | |
115 | "u32vector", "s32vector", | |
116 | "u64vector", "s64vector", | |
cbdc8379 MV |
117 | "f32vector", "f64vector", |
118 | "c32vector", "c64vector" | |
f8579182 MV |
119 | }; |
120 | ||
121 | /* ================================================================ */ | |
122 | /* SMOB procedures. */ | |
123 | /* ================================================================ */ | |
124 | ||
125 | ||
69d2000d | 126 | /* Smob print hook for uniform vectors. */ |
f8579182 MV |
127 | static int |
128 | uvec_print (SCM uvec, SCM port, scm_print_state *pstate) | |
129 | { | |
130 | union { | |
131 | scm_t_uint8 *u8; | |
132 | scm_t_int8 *s8; | |
133 | scm_t_uint16 *u16; | |
134 | scm_t_int16 *s16; | |
135 | scm_t_uint32 *u32; | |
136 | scm_t_int32 *s32; | |
137 | #if SCM_HAVE_T_INT64 | |
138 | scm_t_uint64 *u64; | |
139 | scm_t_int64 *s64; | |
140 | #endif | |
141 | float *f32; | |
142 | double *f64; | |
00c17d45 | 143 | SCM *fake_64; |
f8579182 MV |
144 | } np; |
145 | ||
146 | size_t i = 0; | |
147 | const size_t uvlen = SCM_UVEC_LENGTH (uvec); | |
f8579182 MV |
148 | void *uptr = SCM_UVEC_BASE (uvec); |
149 | ||
150 | switch (SCM_UVEC_TYPE (uvec)) | |
151 | { | |
e0e49670 MV |
152 | case SCM_UVEC_U8: np.u8 = (scm_t_uint8 *) uptr; break; |
153 | case SCM_UVEC_S8: np.s8 = (scm_t_int8 *) uptr; break; | |
154 | case SCM_UVEC_U16: np.u16 = (scm_t_uint16 *) uptr; break; | |
155 | case SCM_UVEC_S16: np.s16 = (scm_t_int16 *) uptr; break; | |
156 | case SCM_UVEC_U32: np.u32 = (scm_t_uint32 *) uptr; break; | |
157 | case SCM_UVEC_S32: np.s32 = (scm_t_int32 *) uptr; break; | |
f8579182 | 158 | #if SCM_HAVE_T_INT64 |
e0e49670 MV |
159 | case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break; |
160 | case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break; | |
00c17d45 MV |
161 | #else |
162 | case SCM_UVEC_U64: | |
163 | case SCM_UVEC_S64: np.fake_64 = (SCM *) uptr; break; | |
164 | #endif | |
e0e49670 MV |
165 | case SCM_UVEC_F32: np.f32 = (float *) uptr; break; |
166 | case SCM_UVEC_F64: np.f64 = (double *) uptr; break; | |
cbdc8379 MV |
167 | case SCM_UVEC_C32: np.f32 = (float *) uptr; break; |
168 | case SCM_UVEC_C64: np.f64 = (double *) uptr; break; | |
f8579182 MV |
169 | default: |
170 | abort (); /* Sanity check. */ | |
171 | break; | |
172 | } | |
173 | ||
174 | scm_putc ('#', port); | |
e0e49670 | 175 | scm_puts (uvec_tags [SCM_UVEC_TYPE (uvec)], port); |
f8579182 MV |
176 | scm_putc ('(', port); |
177 | ||
178 | while (i < uvlen) | |
179 | { | |
180 | if (i != 0) scm_puts (" ", port); | |
181 | switch (SCM_UVEC_TYPE (uvec)) | |
182 | { | |
183 | case SCM_UVEC_U8: scm_uintprint (*np.u8, 10, port); np.u8++; break; | |
184 | case SCM_UVEC_S8: scm_intprint (*np.s8, 10, port); np.s8++; break; | |
185 | case SCM_UVEC_U16: scm_uintprint (*np.u16, 10, port); np.u16++; break; | |
186 | case SCM_UVEC_S16: scm_intprint (*np.s16, 10, port); np.s16++; break; | |
187 | case SCM_UVEC_U32: scm_uintprint (*np.u32, 10, port); np.u32++; break; | |
188 | case SCM_UVEC_S32: scm_intprint (*np.s32, 10, port); np.s32++; break; | |
189 | #if SCM_HAVE_T_INT64 | |
190 | case SCM_UVEC_U64: scm_uintprint (*np.u64, 10, port); np.u64++; break; | |
191 | case SCM_UVEC_S64: scm_intprint (*np.s64, 10, port); np.s64++; break; | |
00c17d45 MV |
192 | #else |
193 | case SCM_UVEC_U64: | |
194 | case SCM_UVEC_S64: scm_iprin1 (*np.fake_64, port, pstate); | |
195 | np.fake_64++; break; | |
f8579182 MV |
196 | #endif |
197 | case SCM_UVEC_F32: scm_i_print_double (*np.f32, port); np.f32++; break; | |
198 | case SCM_UVEC_F64: scm_i_print_double (*np.f64, port); np.f64++; break; | |
cbdc8379 MV |
199 | case SCM_UVEC_C32: |
200 | scm_i_print_complex (np.f32[0], np.f32[1], port); | |
201 | np.f32 += 2; | |
202 | break; | |
203 | case SCM_UVEC_C64: | |
204 | scm_i_print_complex (np.f64[0], np.f64[1], port); | |
205 | np.f64 += 2; | |
206 | break; | |
f8579182 MV |
207 | default: |
208 | abort (); /* Sanity check. */ | |
209 | break; | |
210 | } | |
211 | i++; | |
212 | } | |
213 | scm_remember_upto_here_1 (uvec); | |
214 | scm_puts (")", port); | |
215 | return 1; | |
216 | } | |
217 | ||
e0e49670 MV |
218 | const char * |
219 | scm_i_uniform_vector_tag (SCM uvec) | |
220 | { | |
221 | return uvec_tags[SCM_UVEC_TYPE (uvec)]; | |
222 | } | |
223 | ||
f8579182 MV |
224 | static SCM |
225 | uvec_equalp (SCM a, SCM b) | |
226 | { | |
227 | SCM result = SCM_BOOL_T; | |
228 | if (SCM_UVEC_TYPE (a) != SCM_UVEC_TYPE (b)) | |
229 | result = SCM_BOOL_F; | |
230 | else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b)) | |
231 | result = SCM_BOOL_F; | |
00c17d45 MV |
232 | #if SCM_HAVE_T_INT64 == 0 |
233 | else if (SCM_UVEC_TYPE (a) == SCM_UVEC_U64 | |
234 | || SCM_UVEC_TYPE (a) == SCM_UVEC_S64) | |
235 | { | |
236 | SCM *aptr = (SCM *)SCM_UVEC_BASE (a), *bptr = (SCM *)SCM_UVEC_BASE (b); | |
237 | size_t len = SCM_UVEC_LENGTH (a), i; | |
238 | for (i = 0; i < len; i++) | |
239 | if (scm_is_false (scm_num_eq_p (*aptr++, *bptr++))) | |
240 | { | |
241 | result = SCM_BOOL_F; | |
242 | break; | |
243 | } | |
244 | } | |
245 | #endif | |
f8579182 MV |
246 | else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b), |
247 | SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0) | |
248 | result = SCM_BOOL_F; | |
249 | ||
250 | scm_remember_upto_here_2 (a, b); | |
251 | return result; | |
252 | } | |
253 | ||
f8579182 MV |
254 | |
255 | /* ================================================================ */ | |
256 | /* Utility procedures. */ | |
257 | /* ================================================================ */ | |
258 | ||
b0c0a310 | 259 | static SCM_C_INLINE_KEYWORD int |
f8579182 MV |
260 | is_uvec (int type, SCM obj) |
261 | { | |
4330ee25 MV |
262 | if (SCM_IS_UVEC (obj)) |
263 | return SCM_UVEC_TYPE (obj) == type; | |
04b87de5 | 264 | if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1) |
4330ee25 | 265 | { |
04b87de5 | 266 | SCM v = SCM_I_ARRAY_V (obj); |
4330ee25 MV |
267 | return SCM_IS_UVEC (v) && SCM_UVEC_TYPE (v) == type; |
268 | } | |
269 | return 0; | |
f8579182 MV |
270 | } |
271 | ||
b0c0a310 | 272 | static SCM_C_INLINE_KEYWORD SCM |
f8579182 MV |
273 | uvec_p (int type, SCM obj) |
274 | { | |
275 | return scm_from_bool (is_uvec (type, obj)); | |
276 | } | |
277 | ||
b0c0a310 | 278 | static SCM_C_INLINE_KEYWORD void |
f8579182 MV |
279 | uvec_assert (int type, SCM obj) |
280 | { | |
281 | if (!is_uvec (type, obj)) | |
282 | scm_wrong_type_arg_msg (NULL, 0, obj, uvec_names[type]); | |
283 | } | |
284 | ||
d7e7a02a LC |
285 | /* Invoke free(3) on DATA, a user-provided buffer passed to one of the |
286 | `scm_take_' functions. */ | |
287 | static void | |
288 | free_user_data (GC_PTR data, GC_PTR unused) | |
289 | { | |
290 | free (data); | |
291 | } | |
292 | ||
faa00365 | 293 | static SCM |
ab7acbb7 | 294 | take_uvec (int type, void *base, size_t len) |
faa00365 MV |
295 | { |
296 | SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, (scm_t_bits) base); | |
297 | } | |
298 | ||
69d2000d | 299 | /* Create a new, uninitialized uniform numeric vector of type TYPE |
f8579182 MV |
300 | with space for LEN elements. */ |
301 | static SCM | |
faa00365 | 302 | alloc_uvec (int type, size_t len) |
f8579182 | 303 | { |
811eb6d0 MV |
304 | void *base; |
305 | if (len > SCM_I_SIZE_MAX / uvec_sizes[type]) | |
306 | scm_out_of_range (NULL, scm_from_size_t (len)); | |
307 | base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]); | |
00c17d45 MV |
308 | #if SCM_HAVE_T_INT64 == 0 |
309 | if (type == SCM_UVEC_U64 || type == SCM_UVEC_S64) | |
310 | { | |
311 | SCM *ptr = (SCM *)base; | |
312 | size_t i; | |
313 | for (i = 0; i < len; i++) | |
314 | *ptr++ = SCM_UNSPECIFIED; | |
315 | } | |
316 | #endif | |
faa00365 | 317 | return take_uvec (type, base, len); |
f8579182 MV |
318 | } |
319 | ||
320 | /* GCC doesn't seem to want to optimize unused switch clauses away, | |
321 | so we use a big 'if' in the next two functions. | |
322 | */ | |
323 | ||
b0c0a310 | 324 | static SCM_C_INLINE_KEYWORD SCM |
4330ee25 | 325 | uvec_fast_ref (int type, const void *base, size_t c_idx) |
f8579182 MV |
326 | { |
327 | if (type == SCM_UVEC_U8) | |
328 | return scm_from_uint8 (((scm_t_uint8*)base)[c_idx]); | |
329 | else if (type == SCM_UVEC_S8) | |
330 | return scm_from_int8 (((scm_t_int8*)base)[c_idx]); | |
331 | else if (type == SCM_UVEC_U16) | |
332 | return scm_from_uint16 (((scm_t_uint16*)base)[c_idx]); | |
333 | else if (type == SCM_UVEC_S16) | |
334 | return scm_from_int16 (((scm_t_int16*)base)[c_idx]); | |
335 | else if (type == SCM_UVEC_U32) | |
336 | return scm_from_uint32 (((scm_t_uint32*)base)[c_idx]); | |
337 | else if (type == SCM_UVEC_S32) | |
338 | return scm_from_int32 (((scm_t_int32*)base)[c_idx]); | |
339 | #if SCM_HAVE_T_INT64 | |
340 | else if (type == SCM_UVEC_U64) | |
341 | return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]); | |
342 | else if (type == SCM_UVEC_S64) | |
343 | return scm_from_int64 (((scm_t_int64*)base)[c_idx]); | |
00c17d45 MV |
344 | #else |
345 | else if (type == SCM_UVEC_U64) | |
346 | return ((SCM *)base)[c_idx]; | |
347 | else if (type == SCM_UVEC_S64) | |
348 | return ((SCM *)base)[c_idx]; | |
f8579182 MV |
349 | #endif |
350 | else if (type == SCM_UVEC_F32) | |
351 | return scm_from_double (((float*)base)[c_idx]); | |
352 | else if (type == SCM_UVEC_F64) | |
353 | return scm_from_double (((double*)base)[c_idx]); | |
cbdc8379 MV |
354 | else if (type == SCM_UVEC_C32) |
355 | return scm_c_make_rectangular (((float*)base)[2*c_idx], | |
356 | ((float*)base)[2*c_idx+1]); | |
357 | else if (type == SCM_UVEC_C64) | |
358 | return scm_c_make_rectangular (((double*)base)[2*c_idx], | |
359 | ((double*)base)[2*c_idx+1]); | |
28d4aef1 MV |
360 | else |
361 | return SCM_BOOL_F; | |
f8579182 MV |
362 | } |
363 | ||
00c17d45 MV |
364 | #if SCM_HAVE_T_INT64 == 0 |
365 | static SCM scm_uint64_min, scm_uint64_max; | |
366 | static SCM scm_int64_min, scm_int64_max; | |
367 | ||
368 | static void | |
369 | assert_exact_integer_range (SCM val, SCM min, SCM max) | |
370 | { | |
371 | if (!scm_is_integer (val) | |
372 | || scm_is_false (scm_exact_p (val))) | |
373 | scm_wrong_type_arg_msg (NULL, 0, val, "exact integer"); | |
374 | if (scm_is_true (scm_less_p (val, min)) | |
375 | || scm_is_true (scm_gr_p (val, max))) | |
376 | scm_out_of_range (NULL, val); | |
377 | } | |
378 | #endif | |
379 | ||
b0c0a310 | 380 | static SCM_C_INLINE_KEYWORD void |
f8579182 MV |
381 | uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val) |
382 | { | |
383 | if (type == SCM_UVEC_U8) | |
384 | (((scm_t_uint8*)base)[c_idx]) = scm_to_uint8 (val); | |
385 | else if (type == SCM_UVEC_S8) | |
386 | (((scm_t_int8*)base)[c_idx]) = scm_to_int8 (val); | |
387 | else if (type == SCM_UVEC_U16) | |
388 | (((scm_t_uint16*)base)[c_idx]) = scm_to_uint16 (val); | |
389 | else if (type == SCM_UVEC_S16) | |
390 | (((scm_t_int16*)base)[c_idx]) = scm_to_int16 (val); | |
391 | else if (type == SCM_UVEC_U32) | |
392 | (((scm_t_uint32*)base)[c_idx]) = scm_to_uint32 (val); | |
393 | else if (type == SCM_UVEC_S32) | |
394 | (((scm_t_int32*)base)[c_idx]) = scm_to_int32 (val); | |
395 | #if SCM_HAVE_T_INT64 | |
396 | else if (type == SCM_UVEC_U64) | |
397 | (((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val); | |
398 | else if (type == SCM_UVEC_S64) | |
399 | (((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val); | |
00c17d45 MV |
400 | #else |
401 | else if (type == SCM_UVEC_U64) | |
402 | { | |
403 | assert_exact_integer_range (val, scm_uint64_min, scm_uint64_max); | |
404 | ((SCM *)base)[c_idx] = val; | |
405 | } | |
406 | else if (type == SCM_UVEC_S64) | |
407 | { | |
408 | assert_exact_integer_range (val, scm_int64_min, scm_int64_max); | |
409 | ((SCM *)base)[c_idx] = val; | |
410 | } | |
f8579182 MV |
411 | #endif |
412 | else if (type == SCM_UVEC_F32) | |
413 | (((float*)base)[c_idx]) = scm_to_double (val); | |
414 | else if (type == SCM_UVEC_F64) | |
415 | (((double*)base)[c_idx]) = scm_to_double (val); | |
cbdc8379 MV |
416 | else if (type == SCM_UVEC_C32) |
417 | { | |
418 | (((float*)base)[2*c_idx]) = scm_c_real_part (val); | |
419 | (((float*)base)[2*c_idx+1]) = scm_c_imag_part (val); | |
420 | } | |
421 | else if (type == SCM_UVEC_C64) | |
422 | { | |
423 | (((double*)base)[2*c_idx]) = scm_c_real_part (val); | |
424 | (((double*)base)[2*c_idx+1]) = scm_c_imag_part (val); | |
425 | } | |
f8579182 MV |
426 | } |
427 | ||
b0c0a310 | 428 | static SCM_C_INLINE_KEYWORD SCM |
f8579182 MV |
429 | make_uvec (int type, SCM len, SCM fill) |
430 | { | |
811eb6d0 | 431 | size_t c_len = scm_to_size_t (len); |
f8579182 MV |
432 | SCM uvec = alloc_uvec (type, c_len); |
433 | if (!SCM_UNBNDP (fill)) | |
434 | { | |
435 | size_t idx; | |
436 | void *base = SCM_UVEC_BASE (uvec); | |
437 | for (idx = 0; idx < c_len; idx++) | |
438 | uvec_fast_set_x (type, base, idx, fill); | |
439 | } | |
440 | return uvec; | |
441 | } | |
442 | ||
b0c0a310 | 443 | static SCM_C_INLINE_KEYWORD void * |
4330ee25 MV |
444 | uvec_writable_elements (int type, SCM uvec, scm_t_array_handle *handle, |
445 | size_t *lenp, ssize_t *incp) | |
446 | { | |
447 | if (type >= 0) | |
448 | { | |
449 | SCM v = uvec; | |
04b87de5 MV |
450 | if (SCM_I_ARRAYP (v)) |
451 | v = SCM_I_ARRAY_V (v); | |
4330ee25 MV |
452 | uvec_assert (type, v); |
453 | } | |
454 | ||
455 | return scm_uniform_vector_writable_elements (uvec, handle, lenp, incp); | |
456 | } | |
457 | ||
b0c0a310 | 458 | static SCM_C_INLINE_KEYWORD const void * |
4330ee25 MV |
459 | uvec_elements (int type, SCM uvec, scm_t_array_handle *handle, |
460 | size_t *lenp, ssize_t *incp) | |
461 | { | |
462 | return uvec_writable_elements (type, uvec, handle, lenp, incp); | |
463 | } | |
464 | ||
5e320e59 MV |
465 | static int |
466 | uvec_type (scm_t_array_handle *h) | |
467 | { | |
468 | SCM v = h->array; | |
04b87de5 MV |
469 | if (SCM_I_ARRAYP (v)) |
470 | v = SCM_I_ARRAY_V (v); | |
5e320e59 MV |
471 | return SCM_UVEC_TYPE (v); |
472 | } | |
473 | ||
4330ee25 MV |
474 | static SCM |
475 | uvec_to_list (int type, SCM uvec) | |
476 | { | |
477 | scm_t_array_handle handle; | |
478 | size_t len; | |
479 | ssize_t i, inc; | |
480 | const void *elts; | |
481 | SCM res = SCM_EOL; | |
482 | ||
483 | elts = uvec_elements (type, uvec, &handle, &len, &inc); | |
2a610be5 AW |
484 | for (i = len - 1; i >= 0; i--) |
485 | res = scm_cons (scm_array_handle_ref (&handle, i*inc), res); | |
4330ee25 MV |
486 | scm_array_handle_release (&handle); |
487 | return res; | |
488 | } | |
489 | ||
b0c0a310 | 490 | static SCM_C_INLINE_KEYWORD SCM |
f8579182 MV |
491 | uvec_length (int type, SCM uvec) |
492 | { | |
4330ee25 MV |
493 | scm_t_array_handle handle; |
494 | size_t len; | |
495 | ssize_t inc; | |
496 | uvec_elements (type, uvec, &handle, &len, &inc); | |
497 | scm_array_handle_release (&handle); | |
498 | return scm_from_size_t (len); | |
f8579182 MV |
499 | } |
500 | ||
b0c0a310 | 501 | static SCM_C_INLINE_KEYWORD SCM |
f8579182 MV |
502 | uvec_ref (int type, SCM uvec, SCM idx) |
503 | { | |
4330ee25 MV |
504 | scm_t_array_handle handle; |
505 | size_t i, len; | |
506 | ssize_t inc; | |
507 | const void *elts; | |
f8579182 MV |
508 | SCM res; |
509 | ||
4330ee25 | 510 | elts = uvec_elements (type, uvec, &handle, &len, &inc); |
5e320e59 MV |
511 | if (type < 0) |
512 | type = uvec_type (&handle); | |
4330ee25 MV |
513 | i = scm_to_unsigned_integer (idx, 0, len-1); |
514 | res = uvec_fast_ref (type, elts, i*inc); | |
515 | scm_array_handle_release (&handle); | |
f8579182 MV |
516 | return res; |
517 | } | |
518 | ||
b0c0a310 | 519 | static SCM_C_INLINE_KEYWORD SCM |
f8579182 MV |
520 | uvec_set_x (int type, SCM uvec, SCM idx, SCM val) |
521 | { | |
4330ee25 MV |
522 | scm_t_array_handle handle; |
523 | size_t i, len; | |
524 | ssize_t inc; | |
525 | void *elts; | |
f8579182 | 526 | |
4330ee25 | 527 | elts = uvec_writable_elements (type, uvec, &handle, &len, &inc); |
5e320e59 MV |
528 | if (type < 0) |
529 | type = uvec_type (&handle); | |
4330ee25 MV |
530 | i = scm_to_unsigned_integer (idx, 0, len-1); |
531 | uvec_fast_set_x (type, elts, i*inc, val); | |
532 | scm_array_handle_release (&handle); | |
f8579182 MV |
533 | return SCM_UNSPECIFIED; |
534 | } | |
535 | ||
b0c0a310 | 536 | static SCM_C_INLINE_KEYWORD SCM |
f8579182 MV |
537 | list_to_uvec (int type, SCM list) |
538 | { | |
539 | SCM uvec; | |
540 | void *base; | |
541 | long idx; | |
542 | long len = scm_ilength (list); | |
543 | if (len < 0) | |
544 | scm_wrong_type_arg_msg (NULL, 0, list, "proper list"); | |
545 | ||
546 | uvec = alloc_uvec (type, len); | |
547 | base = SCM_UVEC_BASE (uvec); | |
548 | idx = 0; | |
549 | while (scm_is_pair (list) && idx < len) | |
550 | { | |
551 | uvec_fast_set_x (type, base, idx, SCM_CAR (list)); | |
552 | list = SCM_CDR (list); | |
553 | idx++; | |
554 | } | |
555 | return uvec; | |
556 | } | |
557 | ||
f301dbf3 MV |
558 | SCM_SYMBOL (scm_sym_a, "a"); |
559 | SCM_SYMBOL (scm_sym_b, "b"); | |
f8579182 | 560 | |
e0e49670 | 561 | SCM |
f301dbf3 | 562 | scm_i_generalized_vector_type (SCM v) |
e0e49670 | 563 | { |
811eb6d0 | 564 | if (scm_is_vector (v)) |
f301dbf3 | 565 | return SCM_BOOL_T; |
811eb6d0 | 566 | else if (scm_is_string (v)) |
f301dbf3 | 567 | return scm_sym_a; |
811eb6d0 | 568 | else if (scm_is_bitvector (v)) |
f301dbf3 | 569 | return scm_sym_b; |
811eb6d0 | 570 | else if (scm_is_uniform_vector (v)) |
f301dbf3 | 571 | return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]); |
438974d0 LC |
572 | else if (scm_is_bytevector (v)) |
573 | return scm_from_locale_symbol ("vu8"); | |
811eb6d0 MV |
574 | else |
575 | return SCM_BOOL_F; | |
e0e49670 MV |
576 | } |
577 | ||
69730f92 MV |
578 | SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0, |
579 | (SCM uvec, SCM port_or_fd, SCM start, SCM end), | |
580 | "Fill the elements of @var{uvec} by reading\n" | |
581 | "raw bytes from @var{port-or-fdes}, using host byte order.\n\n" | |
582 | "The optional arguments @var{start} (inclusive) and @var{end}\n" | |
583 | "(exclusive) allow a specified region to be read,\n" | |
584 | "leaving the remainder of the vector unchanged.\n\n" | |
585 | "When @var{port-or-fdes} is a port, all specified elements\n" | |
586 | "of @var{uvec} are attempted to be read, potentially blocking\n" | |
587 | "while waiting formore input or end-of-file.\n" | |
588 | "When @var{port-or-fd} is an integer, a single call to\n" | |
589 | "read(2) is made.\n\n" | |
590 | "An error is signalled when the last element has only\n" | |
591 | "been partially filled before reaching end-of-file or in\n" | |
592 | "the single call to read(2).\n\n" | |
6e708ef2 MV |
593 | "@code{uniform-vector-read!} returns the number of elements\n" |
594 | "read.\n\n" | |
69730f92 MV |
595 | "@var{port-or-fdes} may be omitted, in which case it defaults\n" |
596 | "to the value returned by @code{(current-input-port)}.") | |
597 | #define FUNC_NAME s_scm_uniform_vector_read_x | |
598 | { | |
6e708ef2 | 599 | scm_t_array_handle handle; |
69730f92 | 600 | size_t vlen, sz, ans; |
6e708ef2 | 601 | ssize_t inc; |
69730f92 MV |
602 | size_t cstart, cend; |
603 | size_t remaining, off; | |
2b829bbb | 604 | char *base; |
69730f92 MV |
605 | |
606 | if (SCM_UNBNDP (port_or_fd)) | |
9de87eea | 607 | port_or_fd = scm_current_input_port (); |
69730f92 MV |
608 | else |
609 | SCM_ASSERT (scm_is_integer (port_or_fd) | |
610 | || (SCM_OPINPORTP (port_or_fd)), | |
611 | port_or_fd, SCM_ARG2, FUNC_NAME); | |
612 | ||
6e708ef2 MV |
613 | if (!scm_is_uniform_vector (uvec)) |
614 | scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector"); | |
69730f92 | 615 | |
6e708ef2 | 616 | base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc); |
fea99690 | 617 | sz = scm_array_handle_uniform_element_size (&handle); |
6e708ef2 MV |
618 | |
619 | if (inc != 1) | |
620 | { | |
621 | /* XXX - we should of course support non contiguous vectors. */ | |
622 | scm_misc_error (NULL, "only contiguous vectors are supported: ~a", | |
623 | scm_list_1 (uvec)); | |
624 | } | |
69730f92 MV |
625 | |
626 | cstart = 0; | |
627 | cend = vlen; | |
628 | if (!SCM_UNBNDP (start)) | |
629 | { | |
630 | cstart = scm_to_unsigned_integer (start, 0, vlen); | |
631 | if (!SCM_UNBNDP (end)) | |
632 | cend = scm_to_unsigned_integer (end, cstart, vlen); | |
633 | } | |
634 | ||
635 | remaining = (cend - cstart) * sz; | |
636 | off = cstart * sz; | |
637 | ||
638 | if (SCM_NIMP (port_or_fd)) | |
639 | { | |
69730f92 | 640 | ans = cend - cstart; |
b5cb4464 NJ |
641 | remaining -= scm_c_read (port_or_fd, base + off, remaining); |
642 | if (remaining % sz != 0) | |
643 | SCM_MISC_ERROR ("unexpected EOF", SCM_EOL); | |
644 | ans -= remaining / sz; | |
69730f92 MV |
645 | } |
646 | else /* file descriptor. */ | |
647 | { | |
648 | int fd = scm_to_int (port_or_fd); | |
649 | int n; | |
650 | ||
651 | SCM_SYSCALL (n = read (fd, base + off, remaining)); | |
652 | if (n == -1) | |
653 | SCM_SYSERROR; | |
654 | if (n % sz != 0) | |
655 | SCM_MISC_ERROR ("unexpected EOF", SCM_EOL); | |
656 | ans = n / sz; | |
657 | } | |
658 | ||
fea99690 MV |
659 | scm_array_handle_release (&handle); |
660 | ||
69730f92 MV |
661 | return scm_from_size_t (ans); |
662 | } | |
663 | #undef FUNC_NAME | |
664 | ||
665 | SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0, | |
666 | (SCM uvec, SCM port_or_fd, SCM start, SCM end), | |
667 | "Write the elements of @var{uvec} as raw bytes to\n" | |
668 | "@var{port-or-fdes}, in the host byte order.\n\n" | |
669 | "The optional arguments @var{start} (inclusive)\n" | |
670 | "and @var{end} (exclusive) allow\n" | |
671 | "a specified region to be written.\n\n" | |
672 | "When @var{port-or-fdes} is a port, all specified elements\n" | |
673 | "of @var{uvec} are attempted to be written, potentially blocking\n" | |
674 | "while waiting for more room.\n" | |
675 | "When @var{port-or-fd} is an integer, a single call to\n" | |
676 | "write(2) is made.\n\n" | |
677 | "An error is signalled when the last element has only\n" | |
678 | "been partially written in the single call to write(2).\n\n" | |
679 | "The number of objects actually written is returned.\n" | |
680 | "@var{port-or-fdes} may be\n" | |
681 | "omitted, in which case it defaults to the value returned by\n" | |
682 | "@code{(current-output-port)}.") | |
683 | #define FUNC_NAME s_scm_uniform_vector_write | |
684 | { | |
6e708ef2 | 685 | scm_t_array_handle handle; |
69730f92 | 686 | size_t vlen, sz, ans; |
6e708ef2 | 687 | ssize_t inc; |
69730f92 MV |
688 | size_t cstart, cend; |
689 | size_t amount, off; | |
2b829bbb | 690 | const char *base; |
69730f92 MV |
691 | |
692 | port_or_fd = SCM_COERCE_OUTPORT (port_or_fd); | |
693 | ||
694 | if (SCM_UNBNDP (port_or_fd)) | |
9de87eea | 695 | port_or_fd = scm_current_output_port (); |
69730f92 MV |
696 | else |
697 | SCM_ASSERT (scm_is_integer (port_or_fd) | |
698 | || (SCM_OPOUTPORTP (port_or_fd)), | |
699 | port_or_fd, SCM_ARG2, FUNC_NAME); | |
700 | ||
6e708ef2 | 701 | base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc); |
fea99690 | 702 | sz = scm_array_handle_uniform_element_size (&handle); |
6e708ef2 MV |
703 | |
704 | if (inc != 1) | |
705 | { | |
706 | /* XXX - we should of course support non contiguous vectors. */ | |
707 | scm_misc_error (NULL, "only contiguous vectors are supported: ~a", | |
708 | scm_list_1 (uvec)); | |
709 | } | |
69730f92 MV |
710 | |
711 | cstart = 0; | |
712 | cend = vlen; | |
713 | if (!SCM_UNBNDP (start)) | |
714 | { | |
715 | cstart = scm_to_unsigned_integer (start, 0, vlen); | |
716 | if (!SCM_UNBNDP (end)) | |
717 | cend = scm_to_unsigned_integer (end, cstart, vlen); | |
718 | } | |
719 | ||
720 | amount = (cend - cstart) * sz; | |
721 | off = cstart * sz; | |
722 | ||
723 | if (SCM_NIMP (port_or_fd)) | |
724 | { | |
725 | scm_lfwrite (base + off, amount, port_or_fd); | |
726 | ans = cend - cstart; | |
727 | } | |
728 | else /* file descriptor. */ | |
729 | { | |
730 | int fd = scm_to_int (port_or_fd), n; | |
731 | SCM_SYSCALL (n = write (fd, base + off, amount)); | |
732 | if (n == -1) | |
733 | SCM_SYSERROR; | |
734 | if (n % sz != 0) | |
735 | SCM_MISC_ERROR ("last element only written partially", SCM_EOL); | |
736 | ans = n / sz; | |
737 | } | |
738 | ||
fea99690 MV |
739 | scm_array_handle_release (&handle); |
740 | ||
69730f92 MV |
741 | return scm_from_size_t (ans); |
742 | } | |
743 | #undef FUNC_NAME | |
744 | ||
f8579182 MV |
745 | /* ================================================================ */ |
746 | /* Exported procedures. */ | |
747 | /* ================================================================ */ | |
748 | ||
e0e49670 MV |
749 | #define TYPE SCM_UVEC_U8 |
750 | #define TAG u8 | |
751 | #define CTYPE scm_t_uint8 | |
f8579182 MV |
752 | #include "libguile/srfi-4.i.c" |
753 | ||
e0e49670 MV |
754 | #define TYPE SCM_UVEC_S8 |
755 | #define TAG s8 | |
756 | #define CTYPE scm_t_int8 | |
f8579182 MV |
757 | #include "libguile/srfi-4.i.c" |
758 | ||
e0e49670 MV |
759 | #define TYPE SCM_UVEC_U16 |
760 | #define TAG u16 | |
761 | #define CTYPE scm_t_uint16 | |
f8579182 MV |
762 | #include "libguile/srfi-4.i.c" |
763 | ||
e0e49670 MV |
764 | #define TYPE SCM_UVEC_S16 |
765 | #define TAG s16 | |
766 | #define CTYPE scm_t_int16 | |
f8579182 MV |
767 | #include "libguile/srfi-4.i.c" |
768 | ||
e0e49670 MV |
769 | #define TYPE SCM_UVEC_U32 |
770 | #define TAG u32 | |
771 | #define CTYPE scm_t_uint32 | |
f8579182 MV |
772 | #include "libguile/srfi-4.i.c" |
773 | ||
e0e49670 MV |
774 | #define TYPE SCM_UVEC_S32 |
775 | #define TAG s32 | |
776 | #define CTYPE scm_t_int32 | |
f8579182 MV |
777 | #include "libguile/srfi-4.i.c" |
778 | ||
e0e49670 MV |
779 | #define TYPE SCM_UVEC_U64 |
780 | #define TAG u64 | |
00c17d45 | 781 | #if SCM_HAVE_T_UINT64 |
e0e49670 | 782 | #define CTYPE scm_t_uint64 |
00c17d45 | 783 | #endif |
f8579182 MV |
784 | #include "libguile/srfi-4.i.c" |
785 | ||
e0e49670 MV |
786 | #define TYPE SCM_UVEC_S64 |
787 | #define TAG s64 | |
00c17d45 | 788 | #if SCM_HAVE_T_INT64 |
e0e49670 | 789 | #define CTYPE scm_t_int64 |
00c17d45 | 790 | #endif |
f8579182 MV |
791 | #include "libguile/srfi-4.i.c" |
792 | ||
e0e49670 MV |
793 | #define TYPE SCM_UVEC_F32 |
794 | #define TAG f32 | |
795 | #define CTYPE float | |
f8579182 MV |
796 | #include "libguile/srfi-4.i.c" |
797 | ||
e0e49670 MV |
798 | #define TYPE SCM_UVEC_F64 |
799 | #define TAG f64 | |
800 | #define CTYPE double | |
f8579182 MV |
801 | #include "libguile/srfi-4.i.c" |
802 | ||
cbdc8379 MV |
803 | #define TYPE SCM_UVEC_C32 |
804 | #define TAG c32 | |
805 | #define CTYPE float | |
806 | #include "libguile/srfi-4.i.c" | |
807 | ||
808 | #define TYPE SCM_UVEC_C64 | |
809 | #define TAG c64 | |
810 | #define CTYPE double | |
811 | #include "libguile/srfi-4.i.c" | |
812 | ||
ac8ed3db AW |
813 | #define DEFINE_SCHEME_PROXY100(cname, modname, scmname) \ |
814 | SCM cname (SCM arg1) \ | |
815 | { \ | |
816 | static SCM var = SCM_BOOL_F; \ | |
817 | if (scm_is_false (var)) \ | |
818 | var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \ | |
819 | return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \ | |
820 | } | |
821 | ||
822 | #define DEFPROXY100(cname, scmname) \ | |
823 | DEFINE_SCHEME_PROXY100 (cname, MOD, scmname) | |
824 | ||
825 | #define DEFINE_SRFI_4_GNU_PROXIES(tag) \ | |
826 | DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector") | |
827 | ||
828 | #define MOD "srfi srfi-4 gnu" | |
829 | DEFINE_SRFI_4_GNU_PROXIES (u8); | |
830 | DEFINE_SRFI_4_GNU_PROXIES (s8); | |
831 | DEFINE_SRFI_4_GNU_PROXIES (u16); | |
832 | DEFINE_SRFI_4_GNU_PROXIES (s16); | |
833 | DEFINE_SRFI_4_GNU_PROXIES (u32); | |
834 | DEFINE_SRFI_4_GNU_PROXIES (s32); | |
835 | DEFINE_SRFI_4_GNU_PROXIES (u64); | |
836 | DEFINE_SRFI_4_GNU_PROXIES (s64); | |
837 | DEFINE_SRFI_4_GNU_PROXIES (f32); | |
838 | DEFINE_SRFI_4_GNU_PROXIES (f64); | |
839 | DEFINE_SRFI_4_GNU_PROXIES (c32); | |
840 | DEFINE_SRFI_4_GNU_PROXIES (c64); | |
841 | ||
842 | ||
4ea4bc4c MV |
843 | static scm_i_t_array_ref uvec_reffers[12] = { |
844 | u8ref, s8ref, | |
845 | u16ref, s16ref, | |
846 | u32ref, s32ref, | |
847 | u64ref, s64ref, | |
848 | f32ref, f64ref, | |
849 | c32ref, c64ref | |
850 | }; | |
851 | ||
852 | static scm_i_t_array_set uvec_setters[12] = { | |
853 | u8set, s8set, | |
854 | u16set, s16set, | |
855 | u32set, s32set, | |
856 | u64set, s64set, | |
857 | f32set, f64set, | |
858 | c32set, c64set | |
859 | }; | |
860 | ||
2a610be5 AW |
861 | static SCM |
862 | uvec_handle_ref (scm_t_array_handle *h, size_t index) | |
4ea4bc4c | 863 | { |
2a610be5 | 864 | return uvec_reffers [SCM_UVEC_TYPE(h->array)] (h, index); |
4ea4bc4c MV |
865 | } |
866 | ||
2a610be5 AW |
867 | static void |
868 | uvec_handle_set (scm_t_array_handle *h, size_t index, SCM val) | |
4ea4bc4c | 869 | { |
2a610be5 | 870 | uvec_setters [SCM_UVEC_TYPE(h->array)] (h, index, val); |
4ea4bc4c MV |
871 | } |
872 | ||
2a610be5 AW |
873 | static void |
874 | uvec_get_handle (SCM v, scm_t_array_handle *h) | |
4ea4bc4c | 875 | { |
2a610be5 AW |
876 | h->array = v; |
877 | h->ndims = 1; | |
878 | h->dims = &h->dim0; | |
879 | h->dim0.lbnd = 0; | |
880 | h->dim0.ubnd = SCM_UVEC_LENGTH (v) - 1; | |
881 | h->dim0.inc = 1; | |
882 | h->element_type = SCM_UVEC_TYPE (v) + SCM_ARRAY_ELEMENT_TYPE_U8; | |
883 | h->elements = h->writable_elements = SCM_UVEC_BASE (v); | |
4ea4bc4c MV |
884 | } |
885 | ||
735bcfe5 AW |
886 | SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_tc16_uvec), |
887 | SCM_SMOB_TYPE_MASK, | |
2a610be5 | 888 | uvec_handle_ref, uvec_handle_set, |
f65e0168 | 889 | uvec_get_handle) |
2a610be5 | 890 | |
f8579182 MV |
891 | void |
892 | scm_init_srfi_4 (void) | |
893 | { | |
894 | scm_tc16_uvec = scm_make_smob_type ("uvec", 0); | |
895 | scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp); | |
f8579182 | 896 | scm_set_smob_print (scm_tc16_uvec, uvec_print); |
f301dbf3 | 897 | |
00c17d45 | 898 | #if SCM_HAVE_T_INT64 == 0 |
f39448c5 AW |
899 | scm_uint64_min = scm_from_int (0); |
900 | scm_uint64_max = scm_c_read_string ("18446744073709551615"); | |
901 | scm_int64_min = scm_c_read_string ("-9223372036854775808"); | |
902 | scm_int64_max = scm_c_read_string ("9223372036854775807"); | |
00c17d45 MV |
903 | #endif |
904 | ||
f45eccff AW |
905 | #define REGISTER(tag, TAG) \ |
906 | scm_i_register_vector_constructor \ | |
907 | (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG], \ | |
908 | scm_make_##tag##vector) | |
909 | ||
910 | REGISTER (u8, U8); | |
911 | REGISTER (s8, S8); | |
912 | REGISTER (u16, U16); | |
913 | REGISTER (s16, S16); | |
914 | REGISTER (u32, U32); | |
915 | REGISTER (s32, S32); | |
916 | REGISTER (u64, U64); | |
917 | REGISTER (s64, S64); | |
918 | REGISTER (f32, F32); | |
919 | REGISTER (f64, F64); | |
920 | REGISTER (c32, C32); | |
921 | REGISTER (c64, C64); | |
922 | ||
f8579182 | 923 | #include "libguile/srfi-4.x" |
cbdc8379 | 924 | |
f8579182 MV |
925 | } |
926 | ||
927 | /* End of srfi-4.c. */ |