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" | |
f8579182 | 31 | #include "libguile/srfi-4.h" |
cf396142 | 32 | #include "libguile/bitvectors.h" |
438974d0 | 33 | #include "libguile/bytevectors.h" |
f332e957 | 34 | #include "libguile/generalized-vectors.h" |
f8579182 MV |
35 | #include "libguile/error.h" |
36 | #include "libguile/read.h" | |
37 | #include "libguile/ports.h" | |
38 | #include "libguile/chars.h" | |
69730f92 | 39 | #include "libguile/vectors.h" |
2fa901a5 | 40 | #include "libguile/arrays.h" |
69730f92 | 41 | #include "libguile/strings.h" |
00c17d45 | 42 | #include "libguile/strports.h" |
69730f92 | 43 | #include "libguile/dynwind.h" |
6e433d8b | 44 | #include "libguile/deprecation.h" |
69730f92 MV |
45 | |
46 | #ifdef HAVE_UNISTD_H | |
47 | #include <unistd.h> | |
48 | #endif | |
49 | ||
50 | #ifdef HAVE_IO_H | |
51 | #include <io.h> | |
52 | #endif | |
f8579182 | 53 | |
69d2000d | 54 | /* Smob type code for uniform numeric vectors. */ |
f8579182 MV |
55 | int scm_tc16_uvec = 0; |
56 | ||
4330ee25 | 57 | #define SCM_IS_UVEC(obj) SCM_SMOB_PREDICATE (scm_tc16_uvec, (obj)) |
f8579182 | 58 | |
69d2000d | 59 | /* Accessor macros for the three components of a uniform numeric |
f8579182 MV |
60 | vector: |
61 | - The type tag (one of the symbolic constants below). | |
62 | - The vector's length (counted in elements). | |
63 | - The address of the data area (holding the elements of the | |
64 | vector). */ | |
65 | #define SCM_UVEC_TYPE(u) (SCM_CELL_WORD_1(u)) | |
66 | #define SCM_UVEC_LENGTH(u) ((size_t)SCM_CELL_WORD_2(u)) | |
67 | #define SCM_UVEC_BASE(u) ((void *)SCM_CELL_WORD_3(u)) | |
68 | ||
69 | ||
69d2000d | 70 | /* Symbolic constants encoding the various types of uniform |
f8579182 MV |
71 | numeric vectors. */ |
72 | #define SCM_UVEC_U8 0 | |
73 | #define SCM_UVEC_S8 1 | |
74 | #define SCM_UVEC_U16 2 | |
75 | #define SCM_UVEC_S16 3 | |
76 | #define SCM_UVEC_U32 4 | |
77 | #define SCM_UVEC_S32 5 | |
78 | #define SCM_UVEC_U64 6 | |
79 | #define SCM_UVEC_S64 7 | |
80 | #define SCM_UVEC_F32 8 | |
81 | #define SCM_UVEC_F64 9 | |
cbdc8379 MV |
82 | #define SCM_UVEC_C32 10 |
83 | #define SCM_UVEC_C64 11 | |
f8579182 MV |
84 | |
85 | ||
86 | /* This array maps type tags to the size of the elements. */ | |
cbdc8379 | 87 | static const int uvec_sizes[12] = { |
f8579182 MV |
88 | 1, 1, |
89 | 2, 2, | |
90 | 4, 4, | |
00c17d45 | 91 | #if SCM_HAVE_T_INT64 |
f8579182 | 92 | 8, 8, |
00c17d45 MV |
93 | #else |
94 | sizeof (SCM), sizeof (SCM), | |
95 | #endif | |
cbdc8379 MV |
96 | sizeof(float), sizeof(double), |
97 | 2*sizeof(float), 2*sizeof(double) | |
f8579182 MV |
98 | }; |
99 | ||
cbdc8379 | 100 | static const char *uvec_tags[12] = { |
e0e49670 MV |
101 | "u8", "s8", |
102 | "u16", "s16", | |
103 | "u32", "s32", | |
104 | "u64", "s64", | |
cbdc8379 MV |
105 | "f32", "f64", |
106 | "c32", "c64", | |
e0e49670 MV |
107 | }; |
108 | ||
cbdc8379 | 109 | static const char *uvec_names[12] = { |
f8579182 MV |
110 | "u8vector", "s8vector", |
111 | "u16vector", "s16vector", | |
112 | "u32vector", "s32vector", | |
113 | "u64vector", "s64vector", | |
cbdc8379 MV |
114 | "f32vector", "f64vector", |
115 | "c32vector", "c64vector" | |
f8579182 MV |
116 | }; |
117 | ||
118 | /* ================================================================ */ | |
119 | /* SMOB procedures. */ | |
120 | /* ================================================================ */ | |
121 | ||
122 | ||
69d2000d | 123 | /* Smob print hook for uniform vectors. */ |
f8579182 MV |
124 | static int |
125 | uvec_print (SCM uvec, SCM port, scm_print_state *pstate) | |
126 | { | |
127 | union { | |
128 | scm_t_uint8 *u8; | |
129 | scm_t_int8 *s8; | |
130 | scm_t_uint16 *u16; | |
131 | scm_t_int16 *s16; | |
132 | scm_t_uint32 *u32; | |
133 | scm_t_int32 *s32; | |
134 | #if SCM_HAVE_T_INT64 | |
135 | scm_t_uint64 *u64; | |
136 | scm_t_int64 *s64; | |
137 | #endif | |
138 | float *f32; | |
139 | double *f64; | |
00c17d45 | 140 | SCM *fake_64; |
f8579182 MV |
141 | } np; |
142 | ||
143 | size_t i = 0; | |
144 | const size_t uvlen = SCM_UVEC_LENGTH (uvec); | |
f8579182 MV |
145 | void *uptr = SCM_UVEC_BASE (uvec); |
146 | ||
147 | switch (SCM_UVEC_TYPE (uvec)) | |
148 | { | |
e0e49670 MV |
149 | case SCM_UVEC_U8: np.u8 = (scm_t_uint8 *) uptr; break; |
150 | case SCM_UVEC_S8: np.s8 = (scm_t_int8 *) uptr; break; | |
151 | case SCM_UVEC_U16: np.u16 = (scm_t_uint16 *) uptr; break; | |
152 | case SCM_UVEC_S16: np.s16 = (scm_t_int16 *) uptr; break; | |
153 | case SCM_UVEC_U32: np.u32 = (scm_t_uint32 *) uptr; break; | |
154 | case SCM_UVEC_S32: np.s32 = (scm_t_int32 *) uptr; break; | |
f8579182 | 155 | #if SCM_HAVE_T_INT64 |
e0e49670 MV |
156 | case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break; |
157 | case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break; | |
00c17d45 MV |
158 | #else |
159 | case SCM_UVEC_U64: | |
160 | case SCM_UVEC_S64: np.fake_64 = (SCM *) uptr; break; | |
161 | #endif | |
e0e49670 MV |
162 | case SCM_UVEC_F32: np.f32 = (float *) uptr; break; |
163 | case SCM_UVEC_F64: np.f64 = (double *) uptr; break; | |
cbdc8379 MV |
164 | case SCM_UVEC_C32: np.f32 = (float *) uptr; break; |
165 | case SCM_UVEC_C64: np.f64 = (double *) uptr; break; | |
f8579182 MV |
166 | default: |
167 | abort (); /* Sanity check. */ | |
168 | break; | |
169 | } | |
170 | ||
171 | scm_putc ('#', port); | |
e0e49670 | 172 | scm_puts (uvec_tags [SCM_UVEC_TYPE (uvec)], port); |
f8579182 MV |
173 | scm_putc ('(', port); |
174 | ||
175 | while (i < uvlen) | |
176 | { | |
177 | if (i != 0) scm_puts (" ", port); | |
178 | switch (SCM_UVEC_TYPE (uvec)) | |
179 | { | |
180 | case SCM_UVEC_U8: scm_uintprint (*np.u8, 10, port); np.u8++; break; | |
181 | case SCM_UVEC_S8: scm_intprint (*np.s8, 10, port); np.s8++; break; | |
182 | case SCM_UVEC_U16: scm_uintprint (*np.u16, 10, port); np.u16++; break; | |
183 | case SCM_UVEC_S16: scm_intprint (*np.s16, 10, port); np.s16++; break; | |
184 | case SCM_UVEC_U32: scm_uintprint (*np.u32, 10, port); np.u32++; break; | |
185 | case SCM_UVEC_S32: scm_intprint (*np.s32, 10, port); np.s32++; break; | |
186 | #if SCM_HAVE_T_INT64 | |
187 | case SCM_UVEC_U64: scm_uintprint (*np.u64, 10, port); np.u64++; break; | |
188 | case SCM_UVEC_S64: scm_intprint (*np.s64, 10, port); np.s64++; break; | |
00c17d45 MV |
189 | #else |
190 | case SCM_UVEC_U64: | |
191 | case SCM_UVEC_S64: scm_iprin1 (*np.fake_64, port, pstate); | |
192 | np.fake_64++; break; | |
f8579182 MV |
193 | #endif |
194 | case SCM_UVEC_F32: scm_i_print_double (*np.f32, port); np.f32++; break; | |
195 | case SCM_UVEC_F64: scm_i_print_double (*np.f64, port); np.f64++; break; | |
cbdc8379 MV |
196 | case SCM_UVEC_C32: |
197 | scm_i_print_complex (np.f32[0], np.f32[1], port); | |
198 | np.f32 += 2; | |
199 | break; | |
200 | case SCM_UVEC_C64: | |
201 | scm_i_print_complex (np.f64[0], np.f64[1], port); | |
202 | np.f64 += 2; | |
203 | break; | |
f8579182 MV |
204 | default: |
205 | abort (); /* Sanity check. */ | |
206 | break; | |
207 | } | |
208 | i++; | |
209 | } | |
210 | scm_remember_upto_here_1 (uvec); | |
211 | scm_puts (")", port); | |
212 | return 1; | |
213 | } | |
214 | ||
e0e49670 MV |
215 | const char * |
216 | scm_i_uniform_vector_tag (SCM uvec) | |
217 | { | |
218 | return uvec_tags[SCM_UVEC_TYPE (uvec)]; | |
219 | } | |
220 | ||
f8579182 MV |
221 | static SCM |
222 | uvec_equalp (SCM a, SCM b) | |
223 | { | |
224 | SCM result = SCM_BOOL_T; | |
225 | if (SCM_UVEC_TYPE (a) != SCM_UVEC_TYPE (b)) | |
226 | result = SCM_BOOL_F; | |
227 | else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b)) | |
228 | result = SCM_BOOL_F; | |
00c17d45 MV |
229 | #if SCM_HAVE_T_INT64 == 0 |
230 | else if (SCM_UVEC_TYPE (a) == SCM_UVEC_U64 | |
231 | || SCM_UVEC_TYPE (a) == SCM_UVEC_S64) | |
232 | { | |
233 | SCM *aptr = (SCM *)SCM_UVEC_BASE (a), *bptr = (SCM *)SCM_UVEC_BASE (b); | |
234 | size_t len = SCM_UVEC_LENGTH (a), i; | |
235 | for (i = 0; i < len; i++) | |
236 | if (scm_is_false (scm_num_eq_p (*aptr++, *bptr++))) | |
237 | { | |
238 | result = SCM_BOOL_F; | |
239 | break; | |
240 | } | |
241 | } | |
242 | #endif | |
f8579182 MV |
243 | else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b), |
244 | SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0) | |
245 | result = SCM_BOOL_F; | |
246 | ||
247 | scm_remember_upto_here_2 (a, b); | |
248 | return result; | |
249 | } | |
250 | ||
00c17d45 MV |
251 | /* Mark hook. Only used when U64 and S64 are implemented as SCMs. */ |
252 | ||
253 | #if SCM_HAVE_T_INT64 == 0 | |
254 | static SCM | |
255 | uvec_mark (SCM uvec) | |
256 | { | |
257 | if (SCM_UVEC_TYPE (uvec) == SCM_UVEC_U64 | |
258 | || SCM_UVEC_TYPE (uvec) == SCM_UVEC_S64) | |
259 | { | |
260 | SCM *ptr = (SCM *)SCM_UVEC_BASE (uvec); | |
261 | size_t len = SCM_UVEC_LENGTH (uvec), i; | |
262 | for (i = 0; i < len; i++) | |
263 | scm_gc_mark (*ptr++); | |
264 | } | |
265 | return SCM_BOOL_F; | |
266 | } | |
267 | #endif | |
268 | ||
69d2000d | 269 | /* Smob free hook for uniform numeric vectors. */ |
f8579182 MV |
270 | static size_t |
271 | uvec_free (SCM uvec) | |
272 | { | |
273 | int type = SCM_UVEC_TYPE (uvec); | |
274 | scm_gc_free (SCM_UVEC_BASE (uvec), | |
275 | SCM_UVEC_LENGTH (uvec) * uvec_sizes[type], | |
276 | uvec_names[type]); | |
277 | return 0; | |
278 | } | |
279 | ||
280 | /* ================================================================ */ | |
281 | /* Utility procedures. */ | |
282 | /* ================================================================ */ | |
283 | ||
b0c0a310 | 284 | static SCM_C_INLINE_KEYWORD int |
f8579182 MV |
285 | is_uvec (int type, SCM obj) |
286 | { | |
4330ee25 MV |
287 | if (SCM_IS_UVEC (obj)) |
288 | return SCM_UVEC_TYPE (obj) == type; | |
04b87de5 | 289 | if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1) |
4330ee25 | 290 | { |
04b87de5 | 291 | SCM v = SCM_I_ARRAY_V (obj); |
4330ee25 MV |
292 | return SCM_IS_UVEC (v) && SCM_UVEC_TYPE (v) == type; |
293 | } | |
294 | return 0; | |
f8579182 MV |
295 | } |
296 | ||
b0c0a310 | 297 | static SCM_C_INLINE_KEYWORD SCM |
f8579182 MV |
298 | uvec_p (int type, SCM obj) |
299 | { | |
300 | return scm_from_bool (is_uvec (type, obj)); | |
301 | } | |
302 | ||
b0c0a310 | 303 | static SCM_C_INLINE_KEYWORD void |
f8579182 MV |
304 | uvec_assert (int type, SCM obj) |
305 | { | |
306 | if (!is_uvec (type, obj)) | |
307 | scm_wrong_type_arg_msg (NULL, 0, obj, uvec_names[type]); | |
308 | } | |
309 | ||
faa00365 | 310 | static SCM |
ab7acbb7 | 311 | take_uvec (int type, void *base, size_t len) |
faa00365 MV |
312 | { |
313 | SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, (scm_t_bits) base); | |
314 | } | |
315 | ||
69d2000d | 316 | /* Create a new, uninitialized uniform numeric vector of type TYPE |
f8579182 MV |
317 | with space for LEN elements. */ |
318 | static SCM | |
faa00365 | 319 | alloc_uvec (int type, size_t len) |
f8579182 | 320 | { |
811eb6d0 MV |
321 | void *base; |
322 | if (len > SCM_I_SIZE_MAX / uvec_sizes[type]) | |
323 | scm_out_of_range (NULL, scm_from_size_t (len)); | |
324 | base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]); | |
00c17d45 MV |
325 | #if SCM_HAVE_T_INT64 == 0 |
326 | if (type == SCM_UVEC_U64 || type == SCM_UVEC_S64) | |
327 | { | |
328 | SCM *ptr = (SCM *)base; | |
329 | size_t i; | |
330 | for (i = 0; i < len; i++) | |
331 | *ptr++ = SCM_UNSPECIFIED; | |
332 | } | |
333 | #endif | |
faa00365 | 334 | return take_uvec (type, base, len); |
f8579182 MV |
335 | } |
336 | ||
337 | /* GCC doesn't seem to want to optimize unused switch clauses away, | |
338 | so we use a big 'if' in the next two functions. | |
339 | */ | |
340 | ||
b0c0a310 | 341 | static SCM_C_INLINE_KEYWORD SCM |
4330ee25 | 342 | uvec_fast_ref (int type, const void *base, size_t c_idx) |
f8579182 MV |
343 | { |
344 | if (type == SCM_UVEC_U8) | |
345 | return scm_from_uint8 (((scm_t_uint8*)base)[c_idx]); | |
346 | else if (type == SCM_UVEC_S8) | |
347 | return scm_from_int8 (((scm_t_int8*)base)[c_idx]); | |
348 | else if (type == SCM_UVEC_U16) | |
349 | return scm_from_uint16 (((scm_t_uint16*)base)[c_idx]); | |
350 | else if (type == SCM_UVEC_S16) | |
351 | return scm_from_int16 (((scm_t_int16*)base)[c_idx]); | |
352 | else if (type == SCM_UVEC_U32) | |
353 | return scm_from_uint32 (((scm_t_uint32*)base)[c_idx]); | |
354 | else if (type == SCM_UVEC_S32) | |
355 | return scm_from_int32 (((scm_t_int32*)base)[c_idx]); | |
356 | #if SCM_HAVE_T_INT64 | |
357 | else if (type == SCM_UVEC_U64) | |
358 | return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]); | |
359 | else if (type == SCM_UVEC_S64) | |
360 | return scm_from_int64 (((scm_t_int64*)base)[c_idx]); | |
00c17d45 MV |
361 | #else |
362 | else if (type == SCM_UVEC_U64) | |
363 | return ((SCM *)base)[c_idx]; | |
364 | else if (type == SCM_UVEC_S64) | |
365 | return ((SCM *)base)[c_idx]; | |
f8579182 MV |
366 | #endif |
367 | else if (type == SCM_UVEC_F32) | |
368 | return scm_from_double (((float*)base)[c_idx]); | |
369 | else if (type == SCM_UVEC_F64) | |
370 | return scm_from_double (((double*)base)[c_idx]); | |
cbdc8379 MV |
371 | else if (type == SCM_UVEC_C32) |
372 | return scm_c_make_rectangular (((float*)base)[2*c_idx], | |
373 | ((float*)base)[2*c_idx+1]); | |
374 | else if (type == SCM_UVEC_C64) | |
375 | return scm_c_make_rectangular (((double*)base)[2*c_idx], | |
376 | ((double*)base)[2*c_idx+1]); | |
28d4aef1 MV |
377 | else |
378 | return SCM_BOOL_F; | |
f8579182 MV |
379 | } |
380 | ||
00c17d45 MV |
381 | #if SCM_HAVE_T_INT64 == 0 |
382 | static SCM scm_uint64_min, scm_uint64_max; | |
383 | static SCM scm_int64_min, scm_int64_max; | |
384 | ||
385 | static void | |
386 | assert_exact_integer_range (SCM val, SCM min, SCM max) | |
387 | { | |
388 | if (!scm_is_integer (val) | |
389 | || scm_is_false (scm_exact_p (val))) | |
390 | scm_wrong_type_arg_msg (NULL, 0, val, "exact integer"); | |
391 | if (scm_is_true (scm_less_p (val, min)) | |
392 | || scm_is_true (scm_gr_p (val, max))) | |
393 | scm_out_of_range (NULL, val); | |
394 | } | |
395 | #endif | |
396 | ||
b0c0a310 | 397 | static SCM_C_INLINE_KEYWORD void |
f8579182 MV |
398 | uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val) |
399 | { | |
400 | if (type == SCM_UVEC_U8) | |
401 | (((scm_t_uint8*)base)[c_idx]) = scm_to_uint8 (val); | |
402 | else if (type == SCM_UVEC_S8) | |
403 | (((scm_t_int8*)base)[c_idx]) = scm_to_int8 (val); | |
404 | else if (type == SCM_UVEC_U16) | |
405 | (((scm_t_uint16*)base)[c_idx]) = scm_to_uint16 (val); | |
406 | else if (type == SCM_UVEC_S16) | |
407 | (((scm_t_int16*)base)[c_idx]) = scm_to_int16 (val); | |
408 | else if (type == SCM_UVEC_U32) | |
409 | (((scm_t_uint32*)base)[c_idx]) = scm_to_uint32 (val); | |
410 | else if (type == SCM_UVEC_S32) | |
411 | (((scm_t_int32*)base)[c_idx]) = scm_to_int32 (val); | |
412 | #if SCM_HAVE_T_INT64 | |
413 | else if (type == SCM_UVEC_U64) | |
414 | (((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val); | |
415 | else if (type == SCM_UVEC_S64) | |
416 | (((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val); | |
00c17d45 MV |
417 | #else |
418 | else if (type == SCM_UVEC_U64) | |
419 | { | |
420 | assert_exact_integer_range (val, scm_uint64_min, scm_uint64_max); | |
421 | ((SCM *)base)[c_idx] = val; | |
422 | } | |
423 | else if (type == SCM_UVEC_S64) | |
424 | { | |
425 | assert_exact_integer_range (val, scm_int64_min, scm_int64_max); | |
426 | ((SCM *)base)[c_idx] = val; | |
427 | } | |
f8579182 MV |
428 | #endif |
429 | else if (type == SCM_UVEC_F32) | |
430 | (((float*)base)[c_idx]) = scm_to_double (val); | |
431 | else if (type == SCM_UVEC_F64) | |
432 | (((double*)base)[c_idx]) = scm_to_double (val); | |
cbdc8379 MV |
433 | else if (type == SCM_UVEC_C32) |
434 | { | |
435 | (((float*)base)[2*c_idx]) = scm_c_real_part (val); | |
436 | (((float*)base)[2*c_idx+1]) = scm_c_imag_part (val); | |
437 | } | |
438 | else if (type == SCM_UVEC_C64) | |
439 | { | |
440 | (((double*)base)[2*c_idx]) = scm_c_real_part (val); | |
441 | (((double*)base)[2*c_idx+1]) = scm_c_imag_part (val); | |
442 | } | |
f8579182 MV |
443 | } |
444 | ||
b0c0a310 | 445 | static SCM_C_INLINE_KEYWORD SCM |
f8579182 MV |
446 | make_uvec (int type, SCM len, SCM fill) |
447 | { | |
811eb6d0 | 448 | size_t c_len = scm_to_size_t (len); |
f8579182 MV |
449 | SCM uvec = alloc_uvec (type, c_len); |
450 | if (!SCM_UNBNDP (fill)) | |
451 | { | |
452 | size_t idx; | |
453 | void *base = SCM_UVEC_BASE (uvec); | |
454 | for (idx = 0; idx < c_len; idx++) | |
455 | uvec_fast_set_x (type, base, idx, fill); | |
456 | } | |
457 | return uvec; | |
458 | } | |
459 | ||
b0c0a310 | 460 | static SCM_C_INLINE_KEYWORD void * |
4330ee25 MV |
461 | uvec_writable_elements (int type, SCM uvec, scm_t_array_handle *handle, |
462 | size_t *lenp, ssize_t *incp) | |
463 | { | |
464 | if (type >= 0) | |
465 | { | |
466 | SCM v = uvec; | |
04b87de5 MV |
467 | if (SCM_I_ARRAYP (v)) |
468 | v = SCM_I_ARRAY_V (v); | |
4330ee25 MV |
469 | uvec_assert (type, v); |
470 | } | |
471 | ||
472 | return scm_uniform_vector_writable_elements (uvec, handle, lenp, incp); | |
473 | } | |
474 | ||
b0c0a310 | 475 | static SCM_C_INLINE_KEYWORD const void * |
4330ee25 MV |
476 | uvec_elements (int type, SCM uvec, scm_t_array_handle *handle, |
477 | size_t *lenp, ssize_t *incp) | |
478 | { | |
479 | return uvec_writable_elements (type, uvec, handle, lenp, incp); | |
480 | } | |
481 | ||
5e320e59 MV |
482 | static int |
483 | uvec_type (scm_t_array_handle *h) | |
484 | { | |
485 | SCM v = h->array; | |
04b87de5 MV |
486 | if (SCM_I_ARRAYP (v)) |
487 | v = SCM_I_ARRAY_V (v); | |
5e320e59 MV |
488 | return SCM_UVEC_TYPE (v); |
489 | } | |
490 | ||
4330ee25 MV |
491 | static SCM |
492 | uvec_to_list (int type, SCM uvec) | |
493 | { | |
494 | scm_t_array_handle handle; | |
495 | size_t len; | |
496 | ssize_t i, inc; | |
497 | const void *elts; | |
498 | SCM res = SCM_EOL; | |
499 | ||
500 | elts = uvec_elements (type, uvec, &handle, &len, &inc); | |
2a610be5 AW |
501 | for (i = len - 1; i >= 0; i--) |
502 | res = scm_cons (scm_array_handle_ref (&handle, i*inc), res); | |
4330ee25 MV |
503 | scm_array_handle_release (&handle); |
504 | return res; | |
505 | } | |
506 | ||
b0c0a310 | 507 | static SCM_C_INLINE_KEYWORD SCM |
f8579182 MV |
508 | uvec_length (int type, SCM uvec) |
509 | { | |
4330ee25 MV |
510 | scm_t_array_handle handle; |
511 | size_t len; | |
512 | ssize_t inc; | |
513 | uvec_elements (type, uvec, &handle, &len, &inc); | |
514 | scm_array_handle_release (&handle); | |
515 | return scm_from_size_t (len); | |
f8579182 MV |
516 | } |
517 | ||
b0c0a310 | 518 | static SCM_C_INLINE_KEYWORD SCM |
f8579182 MV |
519 | uvec_ref (int type, SCM uvec, SCM idx) |
520 | { | |
4330ee25 MV |
521 | scm_t_array_handle handle; |
522 | size_t i, len; | |
523 | ssize_t inc; | |
524 | const void *elts; | |
f8579182 MV |
525 | SCM res; |
526 | ||
4330ee25 | 527 | elts = uvec_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 | res = uvec_fast_ref (type, elts, i*inc); | |
532 | scm_array_handle_release (&handle); | |
f8579182 MV |
533 | return res; |
534 | } | |
535 | ||
b0c0a310 | 536 | static SCM_C_INLINE_KEYWORD SCM |
f8579182 MV |
537 | uvec_set_x (int type, SCM uvec, SCM idx, SCM val) |
538 | { | |
4330ee25 MV |
539 | scm_t_array_handle handle; |
540 | size_t i, len; | |
541 | ssize_t inc; | |
542 | void *elts; | |
f8579182 | 543 | |
4330ee25 | 544 | elts = uvec_writable_elements (type, uvec, &handle, &len, &inc); |
5e320e59 MV |
545 | if (type < 0) |
546 | type = uvec_type (&handle); | |
4330ee25 MV |
547 | i = scm_to_unsigned_integer (idx, 0, len-1); |
548 | uvec_fast_set_x (type, elts, i*inc, val); | |
549 | scm_array_handle_release (&handle); | |
f8579182 MV |
550 | return SCM_UNSPECIFIED; |
551 | } | |
552 | ||
b0c0a310 | 553 | static SCM_C_INLINE_KEYWORD SCM |
f8579182 MV |
554 | list_to_uvec (int type, SCM list) |
555 | { | |
556 | SCM uvec; | |
557 | void *base; | |
558 | long idx; | |
559 | long len = scm_ilength (list); | |
560 | if (len < 0) | |
561 | scm_wrong_type_arg_msg (NULL, 0, list, "proper list"); | |
562 | ||
563 | uvec = alloc_uvec (type, len); | |
564 | base = SCM_UVEC_BASE (uvec); | |
565 | idx = 0; | |
566 | while (scm_is_pair (list) && idx < len) | |
567 | { | |
568 | uvec_fast_set_x (type, base, idx, SCM_CAR (list)); | |
569 | list = SCM_CDR (list); | |
570 | idx++; | |
571 | } | |
572 | return uvec; | |
573 | } | |
574 | ||
90d4368c MV |
575 | static SCM |
576 | coerce_to_uvec (int type, SCM obj) | |
577 | { | |
578 | if (is_uvec (type, obj)) | |
579 | return obj; | |
580 | else if (scm_is_pair (obj)) | |
581 | return list_to_uvec (type, obj); | |
811eb6d0 | 582 | else if (scm_is_generalized_vector (obj)) |
90d4368c | 583 | { |
4e8ad323 | 584 | scm_t_array_handle handle; |
811eb6d0 MV |
585 | size_t len = scm_c_generalized_vector_length (obj), i; |
586 | SCM uvec = alloc_uvec (type, len); | |
4e8ad323 | 587 | scm_array_get_handle (uvec, &handle); |
811eb6d0 | 588 | for (i = 0; i < len; i++) |
4e8ad323 MV |
589 | scm_array_handle_set (&handle, i, |
590 | scm_c_generalized_vector_ref (obj, i)); | |
591 | scm_array_handle_release (&handle); | |
90d4368c MV |
592 | return uvec; |
593 | } | |
594 | else | |
811eb6d0 | 595 | scm_wrong_type_arg_msg (NULL, 0, obj, "list or generalized vector"); |
90d4368c MV |
596 | } |
597 | ||
f301dbf3 MV |
598 | SCM_SYMBOL (scm_sym_a, "a"); |
599 | SCM_SYMBOL (scm_sym_b, "b"); | |
f8579182 | 600 | |
e0e49670 | 601 | SCM |
f301dbf3 | 602 | scm_i_generalized_vector_type (SCM v) |
e0e49670 | 603 | { |
811eb6d0 | 604 | if (scm_is_vector (v)) |
f301dbf3 | 605 | return SCM_BOOL_T; |
811eb6d0 | 606 | else if (scm_is_string (v)) |
f301dbf3 | 607 | return scm_sym_a; |
811eb6d0 | 608 | else if (scm_is_bitvector (v)) |
f301dbf3 | 609 | return scm_sym_b; |
811eb6d0 | 610 | else if (scm_is_uniform_vector (v)) |
f301dbf3 | 611 | return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]); |
438974d0 LC |
612 | else if (scm_is_bytevector (v)) |
613 | return scm_from_locale_symbol ("vu8"); | |
811eb6d0 MV |
614 | else |
615 | return SCM_BOOL_F; | |
e0e49670 MV |
616 | } |
617 | ||
618 | int | |
619 | scm_is_uniform_vector (SCM obj) | |
620 | { | |
4330ee25 MV |
621 | if (SCM_IS_UVEC (obj)) |
622 | return 1; | |
04b87de5 | 623 | if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1) |
4330ee25 | 624 | { |
04b87de5 | 625 | SCM v = SCM_I_ARRAY_V (obj); |
4330ee25 MV |
626 | return SCM_IS_UVEC (v); |
627 | } | |
628 | return 0; | |
e0e49670 MV |
629 | } |
630 | ||
631 | size_t | |
4330ee25 | 632 | scm_c_uniform_vector_length (SCM uvec) |
e0e49670 | 633 | { |
4330ee25 MV |
634 | /* scm_generalized_vector_get_handle will ultimately call us to get |
635 | the length of uniform vectors, so we can't use uvec_elements for | |
636 | naked vectors. | |
637 | */ | |
638 | ||
639 | if (SCM_IS_UVEC (uvec)) | |
640 | return SCM_UVEC_LENGTH (uvec); | |
e0e49670 | 641 | else |
4330ee25 MV |
642 | { |
643 | scm_t_array_handle handle; | |
644 | size_t len; | |
645 | ssize_t inc; | |
646 | uvec_elements (-1, uvec, &handle, &len, &inc); | |
647 | scm_array_handle_release (&handle); | |
648 | return len; | |
649 | } | |
e0e49670 MV |
650 | } |
651 | ||
e0e49670 MV |
652 | SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0, |
653 | (SCM obj), | |
654 | "Return @code{#t} if @var{obj} is a uniform vector.") | |
655 | #define FUNC_NAME s_scm_uniform_vector_p | |
656 | { | |
657 | return scm_from_bool (scm_is_uniform_vector (obj)); | |
658 | } | |
659 | #undef FUNC_NAME | |
660 | ||
4330ee25 MV |
661 | SCM |
662 | scm_c_uniform_vector_ref (SCM v, size_t idx) | |
663 | { | |
664 | scm_t_array_handle handle; | |
4330ee25 MV |
665 | size_t len; |
666 | ssize_t inc; | |
667 | SCM res; | |
668 | ||
4e8ad323 | 669 | uvec_elements (-1, v, &handle, &len, &inc); |
4330ee25 MV |
670 | if (idx >= len) |
671 | scm_out_of_range (NULL, scm_from_size_t (idx)); | |
4e8ad323 | 672 | res = scm_array_handle_ref (&handle, idx*inc); |
4330ee25 MV |
673 | scm_array_handle_release (&handle); |
674 | return res; | |
675 | } | |
676 | ||
e0e49670 MV |
677 | SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, |
678 | (SCM v, SCM idx), | |
679 | "Return the element at index @var{idx} of the\n" | |
680 | "homogenous numeric vector @var{v}.") | |
681 | #define FUNC_NAME s_scm_uniform_vector_ref | |
682 | { | |
4330ee25 | 683 | #if SCM_ENABLE_DEPRECATED |
e0e49670 MV |
684 | /* Support old argument convention. |
685 | */ | |
686 | if (scm_is_pair (idx)) | |
687 | { | |
4330ee25 MV |
688 | scm_c_issue_deprecation_warning |
689 | ("Using a list as the index to uniform-vector-ref is deprecated."); | |
e0e49670 MV |
690 | if (!scm_is_null (SCM_CDR (idx))) |
691 | scm_wrong_num_args (NULL); | |
692 | idx = SCM_CAR (idx); | |
693 | } | |
4330ee25 | 694 | #endif |
e0e49670 | 695 | |
4330ee25 | 696 | return scm_c_uniform_vector_ref (v, scm_to_size_t (idx)); |
e0e49670 MV |
697 | } |
698 | #undef FUNC_NAME | |
699 | ||
4330ee25 MV |
700 | void |
701 | scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val) | |
811eb6d0 | 702 | { |
4330ee25 | 703 | scm_t_array_handle handle; |
4330ee25 MV |
704 | size_t len; |
705 | ssize_t inc; | |
706 | ||
4e8ad323 | 707 | uvec_writable_elements (-1, v, &handle, &len, &inc); |
4330ee25 MV |
708 | if (idx >= len) |
709 | scm_out_of_range (NULL, scm_from_size_t (idx)); | |
4e8ad323 | 710 | scm_array_handle_set (&handle, idx*inc, val); |
4330ee25 | 711 | scm_array_handle_release (&handle); |
811eb6d0 MV |
712 | } |
713 | ||
e0e49670 MV |
714 | SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0, |
715 | (SCM v, SCM idx, SCM val), | |
716 | "Set the element at index @var{idx} of the\n" | |
717 | "homogenous numeric vector @var{v} to @var{val}.") | |
718 | #define FUNC_NAME s_scm_uniform_vector_set_x | |
719 | { | |
4330ee25 | 720 | #if SCM_ENABLE_DEPRECATED |
e0e49670 MV |
721 | /* Support old argument convention. |
722 | */ | |
723 | if (scm_is_pair (idx)) | |
724 | { | |
4330ee25 MV |
725 | scm_c_issue_deprecation_warning |
726 | ("Using a list as the index to uniform-vector-set! is deprecated."); | |
e0e49670 MV |
727 | if (!scm_is_null (SCM_CDR (idx))) |
728 | scm_wrong_num_args (NULL); | |
729 | idx = SCM_CAR (idx); | |
730 | } | |
4330ee25 | 731 | #endif |
e0e49670 | 732 | |
4330ee25 MV |
733 | scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val); |
734 | return SCM_UNSPECIFIED; | |
e0e49670 MV |
735 | } |
736 | #undef FUNC_NAME | |
737 | ||
738 | SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0, | |
739 | (SCM uvec), | |
69d2000d | 740 | "Convert the uniform numeric vector @var{uvec} to a list.") |
811eb6d0 | 741 | #define FUNC_NAME s_scm_uniform_vector_to_list |
e0e49670 | 742 | { |
4330ee25 | 743 | return uvec_to_list (-1, uvec); |
e0e49670 MV |
744 | } |
745 | #undef FUNC_NAME | |
746 | ||
6e708ef2 | 747 | size_t |
fea99690 | 748 | scm_array_handle_uniform_element_size (scm_t_array_handle *h) |
e0e49670 | 749 | { |
fea99690 | 750 | SCM vec = h->array; |
04b87de5 MV |
751 | if (SCM_I_ARRAYP (vec)) |
752 | vec = SCM_I_ARRAY_V (vec); | |
fea99690 MV |
753 | if (scm_is_uniform_vector (vec)) |
754 | return uvec_sizes[SCM_UVEC_TYPE(vec)]; | |
438974d0 LC |
755 | if (scm_is_bytevector (vec)) |
756 | return 1U; | |
fea99690 | 757 | scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array"); |
e0e49670 | 758 | } |
7c2ef9a8 MV |
759 | |
760 | #if SCM_ENABLE_DEPRECATED | |
fea99690 | 761 | |
6e708ef2 MV |
762 | /* return the size of an element in a uniform array or 0 if type not |
763 | found. */ | |
764 | size_t | |
765 | scm_uniform_element_size (SCM obj) | |
e0e49670 | 766 | { |
7c2ef9a8 MV |
767 | scm_c_issue_deprecation_warning |
768 | ("scm_uniform_element_size is deprecated. " | |
769 | "Use scm_array_handle_uniform_element_size instead."); | |
770 | ||
4330ee25 | 771 | if (SCM_IS_UVEC (obj)) |
fea99690 | 772 | return uvec_sizes[SCM_UVEC_TYPE(obj)]; |
6e708ef2 MV |
773 | else |
774 | return 0; | |
e0e49670 MV |
775 | } |
776 | ||
7c2ef9a8 MV |
777 | #endif |
778 | ||
6e708ef2 MV |
779 | const void * |
780 | scm_array_handle_uniform_elements (scm_t_array_handle *h) | |
d44ff083 | 781 | { |
6e708ef2 | 782 | return scm_array_handle_uniform_writable_elements (h); |
d44ff083 MV |
783 | } |
784 | ||
b590aceb | 785 | void * |
6e708ef2 | 786 | scm_array_handle_uniform_writable_elements (scm_t_array_handle *h) |
b590aceb | 787 | { |
6e708ef2 | 788 | SCM vec = h->array; |
04b87de5 MV |
789 | if (SCM_I_ARRAYP (vec)) |
790 | vec = SCM_I_ARRAY_V (vec); | |
4330ee25 | 791 | if (SCM_IS_UVEC (vec)) |
6e708ef2 MV |
792 | { |
793 | size_t size = uvec_sizes[SCM_UVEC_TYPE(vec)]; | |
794 | char *elts = SCM_UVEC_BASE (vec); | |
795 | return (void *) (elts + size*h->base); | |
796 | } | |
438974d0 LC |
797 | if (scm_is_bytevector (vec)) |
798 | return SCM_BYTEVECTOR_CONTENTS (vec); | |
6e708ef2 | 799 | scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array"); |
b590aceb MV |
800 | } |
801 | ||
6e708ef2 MV |
802 | const void * |
803 | scm_uniform_vector_elements (SCM uvec, | |
804 | scm_t_array_handle *h, | |
805 | size_t *lenp, ssize_t *incp) | |
b590aceb | 806 | { |
6e708ef2 | 807 | return scm_uniform_vector_writable_elements (uvec, h, lenp, incp); |
b590aceb MV |
808 | } |
809 | ||
6e708ef2 MV |
810 | void * |
811 | scm_uniform_vector_writable_elements (SCM uvec, | |
812 | scm_t_array_handle *h, | |
813 | size_t *lenp, ssize_t *incp) | |
e0e49670 | 814 | { |
fea99690 | 815 | scm_generalized_vector_get_handle (uvec, h); |
6e708ef2 MV |
816 | if (lenp) |
817 | { | |
818 | scm_t_array_dim *dim = scm_array_handle_dims (h); | |
819 | *lenp = dim->ubnd - dim->lbnd + 1; | |
820 | *incp = dim->inc; | |
821 | } | |
822 | return scm_array_handle_uniform_writable_elements (h); | |
e0e49670 MV |
823 | } |
824 | ||
825 | SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, | |
826 | (SCM v), | |
811eb6d0 | 827 | "Return the number of elements in the uniform vector @var{v}.") |
e0e49670 MV |
828 | #define FUNC_NAME s_scm_uniform_vector_length |
829 | { | |
4330ee25 | 830 | return uvec_length (-1, v); |
e0e49670 MV |
831 | } |
832 | #undef FUNC_NAME | |
833 | ||
69730f92 MV |
834 | SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0, |
835 | (SCM uvec, SCM port_or_fd, SCM start, SCM end), | |
836 | "Fill the elements of @var{uvec} by reading\n" | |
837 | "raw bytes from @var{port-or-fdes}, using host byte order.\n\n" | |
838 | "The optional arguments @var{start} (inclusive) and @var{end}\n" | |
839 | "(exclusive) allow a specified region to be read,\n" | |
840 | "leaving the remainder of the vector unchanged.\n\n" | |
841 | "When @var{port-or-fdes} is a port, all specified elements\n" | |
842 | "of @var{uvec} are attempted to be read, potentially blocking\n" | |
843 | "while waiting formore input or end-of-file.\n" | |
844 | "When @var{port-or-fd} is an integer, a single call to\n" | |
845 | "read(2) is made.\n\n" | |
846 | "An error is signalled when the last element has only\n" | |
847 | "been partially filled before reaching end-of-file or in\n" | |
848 | "the single call to read(2).\n\n" | |
6e708ef2 MV |
849 | "@code{uniform-vector-read!} returns the number of elements\n" |
850 | "read.\n\n" | |
69730f92 MV |
851 | "@var{port-or-fdes} may be omitted, in which case it defaults\n" |
852 | "to the value returned by @code{(current-input-port)}.") | |
853 | #define FUNC_NAME s_scm_uniform_vector_read_x | |
854 | { | |
6e708ef2 | 855 | scm_t_array_handle handle; |
69730f92 | 856 | size_t vlen, sz, ans; |
6e708ef2 | 857 | ssize_t inc; |
69730f92 MV |
858 | size_t cstart, cend; |
859 | size_t remaining, off; | |
2b829bbb | 860 | char *base; |
69730f92 MV |
861 | |
862 | if (SCM_UNBNDP (port_or_fd)) | |
9de87eea | 863 | port_or_fd = scm_current_input_port (); |
69730f92 MV |
864 | else |
865 | SCM_ASSERT (scm_is_integer (port_or_fd) | |
866 | || (SCM_OPINPORTP (port_or_fd)), | |
867 | port_or_fd, SCM_ARG2, FUNC_NAME); | |
868 | ||
6e708ef2 MV |
869 | if (!scm_is_uniform_vector (uvec)) |
870 | scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector"); | |
69730f92 | 871 | |
6e708ef2 | 872 | base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc); |
fea99690 | 873 | sz = scm_array_handle_uniform_element_size (&handle); |
6e708ef2 MV |
874 | |
875 | if (inc != 1) | |
876 | { | |
877 | /* XXX - we should of course support non contiguous vectors. */ | |
878 | scm_misc_error (NULL, "only contiguous vectors are supported: ~a", | |
879 | scm_list_1 (uvec)); | |
880 | } | |
69730f92 MV |
881 | |
882 | cstart = 0; | |
883 | cend = vlen; | |
884 | if (!SCM_UNBNDP (start)) | |
885 | { | |
886 | cstart = scm_to_unsigned_integer (start, 0, vlen); | |
887 | if (!SCM_UNBNDP (end)) | |
888 | cend = scm_to_unsigned_integer (end, cstart, vlen); | |
889 | } | |
890 | ||
891 | remaining = (cend - cstart) * sz; | |
892 | off = cstart * sz; | |
893 | ||
894 | if (SCM_NIMP (port_or_fd)) | |
895 | { | |
69730f92 | 896 | ans = cend - cstart; |
b5cb4464 NJ |
897 | remaining -= scm_c_read (port_or_fd, base + off, remaining); |
898 | if (remaining % sz != 0) | |
899 | SCM_MISC_ERROR ("unexpected EOF", SCM_EOL); | |
900 | ans -= remaining / sz; | |
69730f92 MV |
901 | } |
902 | else /* file descriptor. */ | |
903 | { | |
904 | int fd = scm_to_int (port_or_fd); | |
905 | int n; | |
906 | ||
907 | SCM_SYSCALL (n = read (fd, base + off, remaining)); | |
908 | if (n == -1) | |
909 | SCM_SYSERROR; | |
910 | if (n % sz != 0) | |
911 | SCM_MISC_ERROR ("unexpected EOF", SCM_EOL); | |
912 | ans = n / sz; | |
913 | } | |
914 | ||
fea99690 MV |
915 | scm_array_handle_release (&handle); |
916 | ||
69730f92 MV |
917 | return scm_from_size_t (ans); |
918 | } | |
919 | #undef FUNC_NAME | |
920 | ||
921 | SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0, | |
922 | (SCM uvec, SCM port_or_fd, SCM start, SCM end), | |
923 | "Write the elements of @var{uvec} as raw bytes to\n" | |
924 | "@var{port-or-fdes}, in the host byte order.\n\n" | |
925 | "The optional arguments @var{start} (inclusive)\n" | |
926 | "and @var{end} (exclusive) allow\n" | |
927 | "a specified region to be written.\n\n" | |
928 | "When @var{port-or-fdes} is a port, all specified elements\n" | |
929 | "of @var{uvec} are attempted to be written, potentially blocking\n" | |
930 | "while waiting for more room.\n" | |
931 | "When @var{port-or-fd} is an integer, a single call to\n" | |
932 | "write(2) is made.\n\n" | |
933 | "An error is signalled when the last element has only\n" | |
934 | "been partially written in the single call to write(2).\n\n" | |
935 | "The number of objects actually written is returned.\n" | |
936 | "@var{port-or-fdes} may be\n" | |
937 | "omitted, in which case it defaults to the value returned by\n" | |
938 | "@code{(current-output-port)}.") | |
939 | #define FUNC_NAME s_scm_uniform_vector_write | |
940 | { | |
6e708ef2 | 941 | scm_t_array_handle handle; |
69730f92 | 942 | size_t vlen, sz, ans; |
6e708ef2 | 943 | ssize_t inc; |
69730f92 MV |
944 | size_t cstart, cend; |
945 | size_t amount, off; | |
2b829bbb | 946 | const char *base; |
69730f92 MV |
947 | |
948 | port_or_fd = SCM_COERCE_OUTPORT (port_or_fd); | |
949 | ||
950 | if (SCM_UNBNDP (port_or_fd)) | |
9de87eea | 951 | port_or_fd = scm_current_output_port (); |
69730f92 MV |
952 | else |
953 | SCM_ASSERT (scm_is_integer (port_or_fd) | |
954 | || (SCM_OPOUTPORTP (port_or_fd)), | |
955 | port_or_fd, SCM_ARG2, FUNC_NAME); | |
956 | ||
6e708ef2 | 957 | base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc); |
fea99690 | 958 | sz = scm_array_handle_uniform_element_size (&handle); |
6e708ef2 MV |
959 | |
960 | if (inc != 1) | |
961 | { | |
962 | /* XXX - we should of course support non contiguous vectors. */ | |
963 | scm_misc_error (NULL, "only contiguous vectors are supported: ~a", | |
964 | scm_list_1 (uvec)); | |
965 | } | |
69730f92 MV |
966 | |
967 | cstart = 0; | |
968 | cend = vlen; | |
969 | if (!SCM_UNBNDP (start)) | |
970 | { | |
971 | cstart = scm_to_unsigned_integer (start, 0, vlen); | |
972 | if (!SCM_UNBNDP (end)) | |
973 | cend = scm_to_unsigned_integer (end, cstart, vlen); | |
974 | } | |
975 | ||
976 | amount = (cend - cstart) * sz; | |
977 | off = cstart * sz; | |
978 | ||
979 | if (SCM_NIMP (port_or_fd)) | |
980 | { | |
981 | scm_lfwrite (base + off, amount, port_or_fd); | |
982 | ans = cend - cstart; | |
983 | } | |
984 | else /* file descriptor. */ | |
985 | { | |
986 | int fd = scm_to_int (port_or_fd), n; | |
987 | SCM_SYSCALL (n = write (fd, base + off, amount)); | |
988 | if (n == -1) | |
989 | SCM_SYSERROR; | |
990 | if (n % sz != 0) | |
991 | SCM_MISC_ERROR ("last element only written partially", SCM_EOL); | |
992 | ans = n / sz; | |
993 | } | |
994 | ||
fea99690 MV |
995 | scm_array_handle_release (&handle); |
996 | ||
69730f92 MV |
997 | return scm_from_size_t (ans); |
998 | } | |
999 | #undef FUNC_NAME | |
1000 | ||
f8579182 MV |
1001 | /* ================================================================ */ |
1002 | /* Exported procedures. */ | |
1003 | /* ================================================================ */ | |
1004 | ||
e0e49670 MV |
1005 | #define TYPE SCM_UVEC_U8 |
1006 | #define TAG u8 | |
1007 | #define CTYPE scm_t_uint8 | |
f8579182 MV |
1008 | #include "libguile/srfi-4.i.c" |
1009 | ||
e0e49670 MV |
1010 | #define TYPE SCM_UVEC_S8 |
1011 | #define TAG s8 | |
1012 | #define CTYPE scm_t_int8 | |
f8579182 MV |
1013 | #include "libguile/srfi-4.i.c" |
1014 | ||
e0e49670 MV |
1015 | #define TYPE SCM_UVEC_U16 |
1016 | #define TAG u16 | |
1017 | #define CTYPE scm_t_uint16 | |
f8579182 MV |
1018 | #include "libguile/srfi-4.i.c" |
1019 | ||
e0e49670 MV |
1020 | #define TYPE SCM_UVEC_S16 |
1021 | #define TAG s16 | |
1022 | #define CTYPE scm_t_int16 | |
f8579182 MV |
1023 | #include "libguile/srfi-4.i.c" |
1024 | ||
e0e49670 MV |
1025 | #define TYPE SCM_UVEC_U32 |
1026 | #define TAG u32 | |
1027 | #define CTYPE scm_t_uint32 | |
f8579182 MV |
1028 | #include "libguile/srfi-4.i.c" |
1029 | ||
e0e49670 MV |
1030 | #define TYPE SCM_UVEC_S32 |
1031 | #define TAG s32 | |
1032 | #define CTYPE scm_t_int32 | |
f8579182 MV |
1033 | #include "libguile/srfi-4.i.c" |
1034 | ||
e0e49670 MV |
1035 | #define TYPE SCM_UVEC_U64 |
1036 | #define TAG u64 | |
00c17d45 | 1037 | #if SCM_HAVE_T_UINT64 |
e0e49670 | 1038 | #define CTYPE scm_t_uint64 |
00c17d45 | 1039 | #endif |
f8579182 MV |
1040 | #include "libguile/srfi-4.i.c" |
1041 | ||
e0e49670 MV |
1042 | #define TYPE SCM_UVEC_S64 |
1043 | #define TAG s64 | |
00c17d45 | 1044 | #if SCM_HAVE_T_INT64 |
e0e49670 | 1045 | #define CTYPE scm_t_int64 |
00c17d45 | 1046 | #endif |
f8579182 MV |
1047 | #include "libguile/srfi-4.i.c" |
1048 | ||
e0e49670 MV |
1049 | #define TYPE SCM_UVEC_F32 |
1050 | #define TAG f32 | |
1051 | #define CTYPE float | |
f8579182 MV |
1052 | #include "libguile/srfi-4.i.c" |
1053 | ||
e0e49670 MV |
1054 | #define TYPE SCM_UVEC_F64 |
1055 | #define TAG f64 | |
1056 | #define CTYPE double | |
f8579182 MV |
1057 | #include "libguile/srfi-4.i.c" |
1058 | ||
cbdc8379 MV |
1059 | #define TYPE SCM_UVEC_C32 |
1060 | #define TAG c32 | |
1061 | #define CTYPE float | |
1062 | #include "libguile/srfi-4.i.c" | |
1063 | ||
1064 | #define TYPE SCM_UVEC_C64 | |
1065 | #define TAG c64 | |
1066 | #define CTYPE double | |
1067 | #include "libguile/srfi-4.i.c" | |
1068 | ||
4ea4bc4c MV |
1069 | static scm_i_t_array_ref uvec_reffers[12] = { |
1070 | u8ref, s8ref, | |
1071 | u16ref, s16ref, | |
1072 | u32ref, s32ref, | |
1073 | u64ref, s64ref, | |
1074 | f32ref, f64ref, | |
1075 | c32ref, c64ref | |
1076 | }; | |
1077 | ||
1078 | static scm_i_t_array_set uvec_setters[12] = { | |
1079 | u8set, s8set, | |
1080 | u16set, s16set, | |
1081 | u32set, s32set, | |
1082 | u64set, s64set, | |
1083 | f32set, f64set, | |
1084 | c32set, c64set | |
1085 | }; | |
1086 | ||
2a610be5 AW |
1087 | static SCM |
1088 | uvec_handle_ref (scm_t_array_handle *h, size_t index) | |
4ea4bc4c | 1089 | { |
2a610be5 | 1090 | return uvec_reffers [SCM_UVEC_TYPE(h->array)] (h, index); |
4ea4bc4c MV |
1091 | } |
1092 | ||
2a610be5 AW |
1093 | static void |
1094 | uvec_handle_set (scm_t_array_handle *h, size_t index, SCM val) | |
4ea4bc4c | 1095 | { |
2a610be5 | 1096 | uvec_setters [SCM_UVEC_TYPE(h->array)] (h, index, val); |
4ea4bc4c MV |
1097 | } |
1098 | ||
2a610be5 AW |
1099 | static void |
1100 | uvec_get_handle (SCM v, scm_t_array_handle *h) | |
1101 | { | |
1102 | h->array = v; | |
1103 | h->ndims = 1; | |
1104 | h->dims = &h->dim0; | |
1105 | h->dim0.lbnd = 0; | |
1106 | h->dim0.ubnd = SCM_UVEC_LENGTH (v) - 1; | |
1107 | h->dim0.inc = 1; | |
1108 | h->element_type = SCM_UVEC_TYPE (v) + SCM_ARRAY_ELEMENT_TYPE_U8; | |
1109 | h->elements = h->writable_elements = SCM_UVEC_BASE (v); | |
1110 | } | |
1111 | ||
1112 | SCM_ARRAY_IMPLEMENTATION (scm_tc16_uvec, 0xffff, | |
1113 | uvec_handle_ref, uvec_handle_set, | |
1114 | uvec_get_handle); | |
1115 | ||
f8579182 MV |
1116 | void |
1117 | scm_init_srfi_4 (void) | |
1118 | { | |
1119 | scm_tc16_uvec = scm_make_smob_type ("uvec", 0); | |
1120 | scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp); | |
00c17d45 MV |
1121 | #if SCM_HAVE_T_INT64 == 0 |
1122 | scm_set_smob_mark (scm_tc16_uvec, uvec_mark); | |
1123 | #endif | |
f8579182 MV |
1124 | scm_set_smob_free (scm_tc16_uvec, uvec_free); |
1125 | scm_set_smob_print (scm_tc16_uvec, uvec_print); | |
f301dbf3 | 1126 | |
00c17d45 MV |
1127 | #if SCM_HAVE_T_INT64 == 0 |
1128 | scm_uint64_min = | |
1129 | scm_permanent_object (scm_from_int (0)); | |
1130 | scm_uint64_max = | |
1131 | scm_permanent_object (scm_c_read_string ("18446744073709551615")); | |
1132 | scm_int64_min = | |
1133 | scm_permanent_object (scm_c_read_string ("-9223372036854775808")); | |
1134 | scm_int64_max = | |
1135 | scm_permanent_object (scm_c_read_string ("9223372036854775807")); | |
1136 | #endif | |
1137 | ||
f8579182 | 1138 | #include "libguile/srfi-4.x" |
cbdc8379 | 1139 | |
f8579182 MV |
1140 | } |
1141 | ||
1142 | /* End of srfi-4.c. */ |