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