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