1 /* srfi-4.c --- Uniform numeric vector datatypes.
3 * Copyright (C) 2001, 2004, 2006, 2010 Free Software Foundation, Inc.
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.
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.
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
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"
50 /* Smob type code for uniform numeric vectors. */
51 int scm_tc16_uvec = 0;
53 #define SCM_IS_UVEC(obj) SCM_SMOB_PREDICATE (scm_tc16_uvec, (obj))
55 /* Accessor macros for the three components of a uniform numeric
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
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))
66 /* Symbolic constants encoding the various types of uniform
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
82 /* This array maps type tags to the size of the elements. */
83 static const int uvec_sizes[12] = {
88 sizeof(float), sizeof(double),
89 2*sizeof(float), 2*sizeof(double)
92 static const char *uvec_tags[12] = {
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"
110 /* ================================================================ */
111 /* SMOB procedures. */
112 /* ================================================================ */
115 /* Smob print hook for uniform vectors. */
117 uvec_print (SCM uvec, SCM port, scm_print_state *pstate)
134 const size_t uvlen = SCM_UVEC_LENGTH (uvec);
135 void *uptr = SCM_UVEC_BASE (uvec);
137 switch (SCM_UVEC_TYPE (uvec))
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;
152 abort (); /* Sanity check. */
156 scm_putc ('#', port);
157 scm_puts (uvec_tags [SCM_UVEC_TYPE (uvec)], port);
158 scm_putc ('(', port);
162 if (i != 0) scm_puts (" ", port);
163 switch (SCM_UVEC_TYPE (uvec))
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;
176 scm_i_print_complex (np.f32[0], np.f32[1], port);
180 scm_i_print_complex (np.f64[0], np.f64[1], port);
184 abort (); /* Sanity check. */
189 scm_remember_upto_here_1 (uvec);
190 scm_puts (")", port);
195 scm_i_uniform_vector_tag (SCM uvec)
197 return uvec_tags[SCM_UVEC_TYPE (uvec)];
201 uvec_equalp (SCM a, SCM b)
203 SCM result = SCM_BOOL_T;
204 if (SCM_UVEC_TYPE (a) != SCM_UVEC_TYPE (b))
206 else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b))
208 else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b),
209 SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0)
212 scm_remember_upto_here_2 (a, b);
216 /* Smob free hook for uniform numeric vectors. */
220 int type = SCM_UVEC_TYPE (uvec);
221 scm_gc_free (SCM_UVEC_BASE (uvec),
222 SCM_UVEC_LENGTH (uvec) * uvec_sizes[type],
227 /* ================================================================ */
228 /* Utility procedures. */
229 /* ================================================================ */
231 static SCM_C_INLINE_KEYWORD int
232 is_uvec (int type, SCM obj)
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)
238 SCM v = SCM_I_ARRAY_V (obj);
239 return SCM_IS_UVEC (v) && SCM_UVEC_TYPE (v) == type;
244 static SCM_C_INLINE_KEYWORD SCM
245 uvec_p (int type, SCM obj)
247 return scm_from_bool (is_uvec (type, obj));
250 static SCM_C_INLINE_KEYWORD void
251 uvec_assert (int type, SCM obj)
253 if (!is_uvec (type, obj))
254 scm_wrong_type_arg_msg (NULL, 0, obj, uvec_names[type]);
258 take_uvec (int type, void *base, size_t len)
260 SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, (scm_t_bits) base);
263 /* Create a new, uninitialized uniform numeric vector of type TYPE
264 with space for LEN elements. */
266 alloc_uvec (int type, size_t len)
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);
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.
279 static SCM_C_INLINE_KEYWORD SCM
280 uvec_fast_ref (int type, const void *base, size_t c_idx)
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]);
312 static SCM_C_INLINE_KEYWORD void
313 uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val)
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)
337 (((float*)base)[2*c_idx]) = scm_c_real_part (val);
338 (((float*)base)[2*c_idx+1]) = scm_c_imag_part (val);
340 else if (type == SCM_UVEC_C64)
342 (((double*)base)[2*c_idx]) = scm_c_real_part (val);
343 (((double*)base)[2*c_idx+1]) = scm_c_imag_part (val);
347 static SCM_C_INLINE_KEYWORD SCM
348 make_uvec (int type, SCM len, SCM fill)
350 size_t c_len = scm_to_size_t (len);
351 SCM uvec = alloc_uvec (type, c_len);
352 if (!SCM_UNBNDP (fill))
355 void *base = SCM_UVEC_BASE (uvec);
356 for (idx = 0; idx < c_len; idx++)
357 uvec_fast_set_x (type, base, idx, fill);
362 static SCM_C_INLINE_KEYWORD void *
363 uvec_writable_elements (int type, SCM uvec, scm_t_array_handle *handle,
364 size_t *lenp, ssize_t *incp)
369 if (SCM_I_ARRAYP (v))
370 v = SCM_I_ARRAY_V (v);
371 uvec_assert (type, v);
374 return scm_uniform_vector_writable_elements (uvec, handle, lenp, incp);
377 static SCM_C_INLINE_KEYWORD const void *
378 uvec_elements (int type, SCM uvec, scm_t_array_handle *handle,
379 size_t *lenp, ssize_t *incp)
381 return uvec_writable_elements (type, uvec, handle, lenp, incp);
385 uvec_type (scm_t_array_handle *h)
388 if (SCM_I_ARRAYP (v))
389 v = SCM_I_ARRAY_V (v);
390 return SCM_UVEC_TYPE (v);
394 uvec_to_list (int type, SCM uvec)
396 scm_t_array_handle handle;
402 elts = uvec_elements (type, uvec, &handle, &len, &inc);
403 for (i = len*inc; i > 0;)
406 res = scm_cons (scm_array_handle_ref (&handle, i), res);
408 scm_array_handle_release (&handle);
412 static SCM_C_INLINE_KEYWORD SCM
413 uvec_length (int type, SCM uvec)
415 scm_t_array_handle handle;
418 uvec_elements (type, uvec, &handle, &len, &inc);
419 scm_array_handle_release (&handle);
420 return scm_from_size_t (len);
423 static SCM_C_INLINE_KEYWORD SCM
424 uvec_ref (int type, SCM uvec, SCM idx)
426 scm_t_array_handle handle;
432 elts = uvec_elements (type, uvec, &handle, &len, &inc);
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);
441 static SCM_C_INLINE_KEYWORD SCM
442 uvec_set_x (int type, SCM uvec, SCM idx, SCM val)
444 scm_t_array_handle handle;
449 elts = uvec_writable_elements (type, uvec, &handle, &len, &inc);
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;
458 static SCM_C_INLINE_KEYWORD SCM
459 list_to_uvec (int type, SCM list)
464 long len = scm_ilength (list);
466 scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
468 uvec = alloc_uvec (type, len);
469 base = SCM_UVEC_BASE (uvec);
471 while (scm_is_pair (list) && idx < len)
473 uvec_fast_set_x (type, base, idx, SCM_CAR (list));
474 list = SCM_CDR (list);
481 coerce_to_uvec (int type, SCM obj)
483 if (is_uvec (type, obj))
485 else if (scm_is_pair (obj))
486 return list_to_uvec (type, obj);
487 else if (scm_is_generalized_vector (obj))
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);
500 scm_wrong_type_arg_msg (NULL, 0, obj, "list or generalized vector");
503 SCM_SYMBOL (scm_sym_a, "a");
504 SCM_SYMBOL (scm_sym_b, "b");
507 scm_i_generalized_vector_type (SCM v)
509 if (scm_is_vector (v))
511 else if (scm_is_string (v))
513 else if (scm_is_bitvector (v))
515 else if (scm_is_uniform_vector (v))
516 return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]);
522 scm_is_uniform_vector (SCM obj)
524 if (SCM_IS_UVEC (obj))
526 if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
528 SCM v = SCM_I_ARRAY_V (obj);
529 return SCM_IS_UVEC (v);
535 scm_c_uniform_vector_length (SCM uvec)
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
542 if (SCM_IS_UVEC (uvec))
543 return SCM_UVEC_LENGTH (uvec);
546 scm_t_array_handle handle;
549 uvec_elements (-1, uvec, &handle, &len, &inc);
550 scm_array_handle_release (&handle);
555 SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
557 "Return @code{#t} if @var{obj} is a uniform vector.")
558 #define FUNC_NAME s_scm_uniform_vector_p
560 return scm_from_bool (scm_is_uniform_vector (obj));
565 scm_c_uniform_vector_ref (SCM v, size_t idx)
567 scm_t_array_handle handle;
572 uvec_elements (-1, v, &handle, &len, &inc);
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);
580 SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
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
586 #if SCM_ENABLE_DEPRECATED
587 /* Support old argument convention.
589 if (scm_is_pair (idx))
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);
599 return scm_c_uniform_vector_ref (v, scm_to_size_t (idx));
604 scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
606 scm_t_array_handle handle;
610 uvec_writable_elements (-1, v, &handle, &len, &inc);
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);
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
623 #if SCM_ENABLE_DEPRECATED
624 /* Support old argument convention.
626 if (scm_is_pair (idx))
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);
636 scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val);
637 return SCM_UNSPECIFIED;
641 SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
643 "Convert the uniform numeric vector @var{uvec} to a list.")
644 #define FUNC_NAME s_scm_uniform_vector_to_list
646 return uvec_to_list (-1, uvec);
651 scm_array_handle_uniform_element_size (scm_t_array_handle *h)
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");
661 #if SCM_ENABLE_DEPRECATED
663 /* return the size of an element in a uniform array or 0 if type not
666 scm_uniform_element_size (SCM obj)
668 scm_c_issue_deprecation_warning
669 ("scm_uniform_element_size is deprecated. "
670 "Use scm_array_handle_uniform_element_size instead.");
672 if (SCM_IS_UVEC (obj))
673 return uvec_sizes[SCM_UVEC_TYPE(obj)];
681 scm_array_handle_uniform_elements (scm_t_array_handle *h)
683 return scm_array_handle_uniform_writable_elements (h);
687 scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
690 if (SCM_I_ARRAYP (vec))
691 vec = SCM_I_ARRAY_V (vec);
692 if (SCM_IS_UVEC (vec))
694 size_t size = uvec_sizes[SCM_UVEC_TYPE(vec)];
695 char *elts = SCM_UVEC_BASE (vec);
696 return (void *) (elts + size*h->base);
698 scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
702 scm_uniform_vector_elements (SCM uvec,
703 scm_t_array_handle *h,
704 size_t *lenp, ssize_t *incp)
706 return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
710 scm_uniform_vector_writable_elements (SCM uvec,
711 scm_t_array_handle *h,
712 size_t *lenp, ssize_t *incp)
714 scm_generalized_vector_get_handle (uvec, h);
717 scm_t_array_dim *dim = scm_array_handle_dims (h);
718 *lenp = dim->ubnd - dim->lbnd + 1;
721 return scm_array_handle_uniform_writable_elements (h);
724 SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
726 "Return the number of elements in the uniform vector @var{v}.")
727 #define FUNC_NAME s_scm_uniform_vector_length
729 return uvec_length (-1, v);
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"
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
754 scm_t_array_handle handle;
755 size_t vlen, sz, ans;
758 size_t remaining, off;
761 if (SCM_UNBNDP (port_or_fd))
762 port_or_fd = scm_current_input_port ();
764 SCM_ASSERT (scm_is_integer (port_or_fd)
765 || (SCM_OPINPORTP (port_or_fd)),
766 port_or_fd, SCM_ARG2, FUNC_NAME);
768 if (!scm_is_uniform_vector (uvec))
769 scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
771 base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc);
772 sz = scm_array_handle_uniform_element_size (&handle);
776 /* XXX - we should of course support non contiguous vectors. */
777 scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
783 if (!SCM_UNBNDP (start))
785 cstart = scm_to_unsigned_integer (start, 0, vlen);
786 if (!SCM_UNBNDP (end))
787 cend = scm_to_unsigned_integer (end, cstart, vlen);
790 remaining = (cend - cstart) * sz;
793 if (SCM_NIMP (port_or_fd))
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;
801 else /* file descriptor. */
803 int fd = scm_to_int (port_or_fd);
806 SCM_SYSCALL (n = read (fd, base + off, remaining));
810 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
814 scm_array_handle_release (&handle);
816 return scm_from_size_t (ans);
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
840 scm_t_array_handle handle;
841 size_t vlen, sz, ans;
847 port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
849 if (SCM_UNBNDP (port_or_fd))
850 port_or_fd = scm_current_output_port ();
852 SCM_ASSERT (scm_is_integer (port_or_fd)
853 || (SCM_OPOUTPORTP (port_or_fd)),
854 port_or_fd, SCM_ARG2, FUNC_NAME);
856 base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc);
857 sz = scm_array_handle_uniform_element_size (&handle);
861 /* XXX - we should of course support non contiguous vectors. */
862 scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
868 if (!SCM_UNBNDP (start))
870 cstart = scm_to_unsigned_integer (start, 0, vlen);
871 if (!SCM_UNBNDP (end))
872 cend = scm_to_unsigned_integer (end, cstart, vlen);
875 amount = (cend - cstart) * sz;
878 if (SCM_NIMP (port_or_fd))
880 scm_lfwrite (base + off, amount, port_or_fd);
883 else /* file descriptor. */
885 int fd = scm_to_int (port_or_fd), n;
886 SCM_SYSCALL (n = write (fd, base + off, amount));
890 SCM_MISC_ERROR ("last element only written partially", SCM_EOL);
894 scm_array_handle_release (&handle);
896 return scm_from_size_t (ans);
900 /* ================================================================ */
901 /* Exported procedures. */
902 /* ================================================================ */
904 #define TYPE SCM_UVEC_U8
906 #define CTYPE scm_t_uint8
907 #include "libguile/srfi-4.i.c"
909 #define TYPE SCM_UVEC_S8
911 #define CTYPE scm_t_int8
912 #include "libguile/srfi-4.i.c"
914 #define TYPE SCM_UVEC_U16
916 #define CTYPE scm_t_uint16
917 #include "libguile/srfi-4.i.c"
919 #define TYPE SCM_UVEC_S16
921 #define CTYPE scm_t_int16
922 #include "libguile/srfi-4.i.c"
924 #define TYPE SCM_UVEC_U32
926 #define CTYPE scm_t_uint32
927 #include "libguile/srfi-4.i.c"
929 #define TYPE SCM_UVEC_S32
931 #define CTYPE scm_t_int32
932 #include "libguile/srfi-4.i.c"
934 #define TYPE SCM_UVEC_U64
936 #define CTYPE scm_t_uint64
937 #include "libguile/srfi-4.i.c"
939 #define TYPE SCM_UVEC_S64
941 #define CTYPE scm_t_int64
942 #include "libguile/srfi-4.i.c"
944 #define TYPE SCM_UVEC_F32
947 #include "libguile/srfi-4.i.c"
949 #define TYPE SCM_UVEC_F64
952 #include "libguile/srfi-4.i.c"
954 #define TYPE SCM_UVEC_C32
957 #include "libguile/srfi-4.i.c"
959 #define TYPE SCM_UVEC_C64
962 #include "libguile/srfi-4.i.c"
964 static scm_i_t_array_ref uvec_reffers[12] = {
973 static scm_i_t_array_set uvec_setters[12] = {
983 scm_i_uniform_vector_ref_proc (SCM uvec)
985 return uvec_reffers[SCM_UVEC_TYPE(uvec)];
989 scm_i_uniform_vector_set_proc (SCM uvec)
991 return uvec_setters[SCM_UVEC_TYPE(uvec)];
995 scm_init_srfi_4 (void)
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);
1002 #include "libguile/srfi-4.x"
1006 /* End of srfi-4.c. */