1 /* srfi-4.c --- Uniform numeric vector datatypes.
3 * Copyright (C) 2001, 2004, 2006 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] = {
90 sizeof (SCM
), sizeof (SCM
),
92 sizeof(float), sizeof(double),
93 2*sizeof(float), 2*sizeof(double)
96 static const char *uvec_tags
[12] = {
105 static const char *uvec_names
[12] = {
106 "u8vector", "s8vector",
107 "u16vector", "s16vector",
108 "u32vector", "s32vector",
109 "u64vector", "s64vector",
110 "f32vector", "f64vector",
111 "c32vector", "c64vector"
114 /* ================================================================ */
115 /* SMOB procedures. */
116 /* ================================================================ */
119 /* Smob print hook for uniform vectors. */
121 uvec_print (SCM uvec
, SCM port
, scm_print_state
*pstate
)
140 const size_t uvlen
= SCM_UVEC_LENGTH (uvec
);
141 void *uptr
= SCM_UVEC_BASE (uvec
);
143 switch (SCM_UVEC_TYPE (uvec
))
145 case SCM_UVEC_U8
: np
.u8
= (scm_t_uint8
*) uptr
; break;
146 case SCM_UVEC_S8
: np
.s8
= (scm_t_int8
*) uptr
; break;
147 case SCM_UVEC_U16
: np
.u16
= (scm_t_uint16
*) uptr
; break;
148 case SCM_UVEC_S16
: np
.s16
= (scm_t_int16
*) uptr
; break;
149 case SCM_UVEC_U32
: np
.u32
= (scm_t_uint32
*) uptr
; break;
150 case SCM_UVEC_S32
: np
.s32
= (scm_t_int32
*) uptr
; break;
152 case SCM_UVEC_U64
: np
.u64
= (scm_t_uint64
*) uptr
; break;
153 case SCM_UVEC_S64
: np
.s64
= (scm_t_int64
*) uptr
; break;
156 case SCM_UVEC_S64
: np
.fake_64
= (SCM
*) uptr
; break;
158 case SCM_UVEC_F32
: np
.f32
= (float *) uptr
; break;
159 case SCM_UVEC_F64
: np
.f64
= (double *) uptr
; break;
160 case SCM_UVEC_C32
: np
.f32
= (float *) uptr
; break;
161 case SCM_UVEC_C64
: np
.f64
= (double *) uptr
; break;
163 abort (); /* Sanity check. */
167 scm_putc ('#', port
);
168 scm_puts (uvec_tags
[SCM_UVEC_TYPE (uvec
)], port
);
169 scm_putc ('(', port
);
173 if (i
!= 0) scm_puts (" ", port
);
174 switch (SCM_UVEC_TYPE (uvec
))
176 case SCM_UVEC_U8
: scm_uintprint (*np
.u8
, 10, port
); np
.u8
++; break;
177 case SCM_UVEC_S8
: scm_intprint (*np
.s8
, 10, port
); np
.s8
++; break;
178 case SCM_UVEC_U16
: scm_uintprint (*np
.u16
, 10, port
); np
.u16
++; break;
179 case SCM_UVEC_S16
: scm_intprint (*np
.s16
, 10, port
); np
.s16
++; break;
180 case SCM_UVEC_U32
: scm_uintprint (*np
.u32
, 10, port
); np
.u32
++; break;
181 case SCM_UVEC_S32
: scm_intprint (*np
.s32
, 10, port
); np
.s32
++; break;
183 case SCM_UVEC_U64
: scm_uintprint (*np
.u64
, 10, port
); np
.u64
++; break;
184 case SCM_UVEC_S64
: scm_intprint (*np
.s64
, 10, port
); np
.s64
++; break;
187 case SCM_UVEC_S64
: scm_iprin1 (*np
.fake_64
, port
, pstate
);
190 case SCM_UVEC_F32
: scm_i_print_double (*np
.f32
, port
); np
.f32
++; break;
191 case SCM_UVEC_F64
: scm_i_print_double (*np
.f64
, port
); np
.f64
++; break;
193 scm_i_print_complex (np
.f32
[0], np
.f32
[1], port
);
197 scm_i_print_complex (np
.f64
[0], np
.f64
[1], port
);
201 abort (); /* Sanity check. */
206 scm_remember_upto_here_1 (uvec
);
207 scm_puts (")", port
);
212 scm_i_uniform_vector_tag (SCM uvec
)
214 return uvec_tags
[SCM_UVEC_TYPE (uvec
)];
218 uvec_equalp (SCM a
, SCM b
)
220 SCM result
= SCM_BOOL_T
;
221 if (SCM_UVEC_TYPE (a
) != SCM_UVEC_TYPE (b
))
223 else if (SCM_UVEC_LENGTH (a
) != SCM_UVEC_LENGTH (b
))
225 #if SCM_HAVE_T_INT64 == 0
226 else if (SCM_UVEC_TYPE (a
) == SCM_UVEC_U64
227 || SCM_UVEC_TYPE (a
) == SCM_UVEC_S64
)
229 SCM
*aptr
= (SCM
*)SCM_UVEC_BASE (a
), *bptr
= (SCM
*)SCM_UVEC_BASE (b
);
230 size_t len
= SCM_UVEC_LENGTH (a
), i
;
231 for (i
= 0; i
< len
; i
++)
232 if (scm_is_false (scm_num_eq_p (*aptr
++, *bptr
++)))
239 else if (memcmp (SCM_UVEC_BASE (a
), SCM_UVEC_BASE (b
),
240 SCM_UVEC_LENGTH (a
) * uvec_sizes
[SCM_UVEC_TYPE(a
)]) != 0)
243 scm_remember_upto_here_2 (a
, b
);
248 /* ================================================================ */
249 /* Utility procedures. */
250 /* ================================================================ */
252 static SCM_C_INLINE_KEYWORD
int
253 is_uvec (int type
, SCM obj
)
255 if (SCM_IS_UVEC (obj
))
256 return SCM_UVEC_TYPE (obj
) == type
;
257 if (SCM_I_ARRAYP (obj
) && SCM_I_ARRAY_NDIM (obj
) == 1)
259 SCM v
= SCM_I_ARRAY_V (obj
);
260 return SCM_IS_UVEC (v
) && SCM_UVEC_TYPE (v
) == type
;
265 static SCM_C_INLINE_KEYWORD SCM
266 uvec_p (int type
, SCM obj
)
268 return scm_from_bool (is_uvec (type
, obj
));
271 static SCM_C_INLINE_KEYWORD
void
272 uvec_assert (int type
, SCM obj
)
274 if (!is_uvec (type
, obj
))
275 scm_wrong_type_arg_msg (NULL
, 0, obj
, uvec_names
[type
]);
279 take_uvec (int type
, void *base
, size_t len
)
281 SCM_RETURN_NEWSMOB3 (scm_tc16_uvec
, type
, len
, (scm_t_bits
) base
);
284 /* Create a new, uninitialized uniform numeric vector of type TYPE
285 with space for LEN elements. */
287 alloc_uvec (int type
, size_t len
)
290 if (len
> SCM_I_SIZE_MAX
/ uvec_sizes
[type
])
291 scm_out_of_range (NULL
, scm_from_size_t (len
));
292 base
= scm_gc_malloc (len
* uvec_sizes
[type
], uvec_names
[type
]);
293 #if SCM_HAVE_T_INT64 == 0
294 if (type
== SCM_UVEC_U64
|| type
== SCM_UVEC_S64
)
296 SCM
*ptr
= (SCM
*)base
;
298 for (i
= 0; i
< len
; i
++)
299 *ptr
++ = SCM_UNSPECIFIED
;
302 return take_uvec (type
, base
, len
);
305 /* GCC doesn't seem to want to optimize unused switch clauses away,
306 so we use a big 'if' in the next two functions.
309 static SCM_C_INLINE_KEYWORD SCM
310 uvec_fast_ref (int type
, const void *base
, size_t c_idx
)
312 if (type
== SCM_UVEC_U8
)
313 return scm_from_uint8 (((scm_t_uint8
*)base
)[c_idx
]);
314 else if (type
== SCM_UVEC_S8
)
315 return scm_from_int8 (((scm_t_int8
*)base
)[c_idx
]);
316 else if (type
== SCM_UVEC_U16
)
317 return scm_from_uint16 (((scm_t_uint16
*)base
)[c_idx
]);
318 else if (type
== SCM_UVEC_S16
)
319 return scm_from_int16 (((scm_t_int16
*)base
)[c_idx
]);
320 else if (type
== SCM_UVEC_U32
)
321 return scm_from_uint32 (((scm_t_uint32
*)base
)[c_idx
]);
322 else if (type
== SCM_UVEC_S32
)
323 return scm_from_int32 (((scm_t_int32
*)base
)[c_idx
]);
325 else if (type
== SCM_UVEC_U64
)
326 return scm_from_uint64 (((scm_t_uint64
*)base
)[c_idx
]);
327 else if (type
== SCM_UVEC_S64
)
328 return scm_from_int64 (((scm_t_int64
*)base
)[c_idx
]);
330 else if (type
== SCM_UVEC_U64
)
331 return ((SCM
*)base
)[c_idx
];
332 else if (type
== SCM_UVEC_S64
)
333 return ((SCM
*)base
)[c_idx
];
335 else if (type
== SCM_UVEC_F32
)
336 return scm_from_double (((float*)base
)[c_idx
]);
337 else if (type
== SCM_UVEC_F64
)
338 return scm_from_double (((double*)base
)[c_idx
]);
339 else if (type
== SCM_UVEC_C32
)
340 return scm_c_make_rectangular (((float*)base
)[2*c_idx
],
341 ((float*)base
)[2*c_idx
+1]);
342 else if (type
== SCM_UVEC_C64
)
343 return scm_c_make_rectangular (((double*)base
)[2*c_idx
],
344 ((double*)base
)[2*c_idx
+1]);
349 #if SCM_HAVE_T_INT64 == 0
350 static SCM scm_uint64_min
, scm_uint64_max
;
351 static SCM scm_int64_min
, scm_int64_max
;
354 assert_exact_integer_range (SCM val
, SCM min
, SCM max
)
356 if (!scm_is_integer (val
)
357 || scm_is_false (scm_exact_p (val
)))
358 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
359 if (scm_is_true (scm_less_p (val
, min
))
360 || scm_is_true (scm_gr_p (val
, max
)))
361 scm_out_of_range (NULL
, val
);
365 static SCM_C_INLINE_KEYWORD
void
366 uvec_fast_set_x (int type
, void *base
, size_t c_idx
, SCM val
)
368 if (type
== SCM_UVEC_U8
)
369 (((scm_t_uint8
*)base
)[c_idx
]) = scm_to_uint8 (val
);
370 else if (type
== SCM_UVEC_S8
)
371 (((scm_t_int8
*)base
)[c_idx
]) = scm_to_int8 (val
);
372 else if (type
== SCM_UVEC_U16
)
373 (((scm_t_uint16
*)base
)[c_idx
]) = scm_to_uint16 (val
);
374 else if (type
== SCM_UVEC_S16
)
375 (((scm_t_int16
*)base
)[c_idx
]) = scm_to_int16 (val
);
376 else if (type
== SCM_UVEC_U32
)
377 (((scm_t_uint32
*)base
)[c_idx
]) = scm_to_uint32 (val
);
378 else if (type
== SCM_UVEC_S32
)
379 (((scm_t_int32
*)base
)[c_idx
]) = scm_to_int32 (val
);
381 else if (type
== SCM_UVEC_U64
)
382 (((scm_t_uint64
*)base
)[c_idx
]) = scm_to_uint64 (val
);
383 else if (type
== SCM_UVEC_S64
)
384 (((scm_t_int64
*)base
)[c_idx
]) = scm_to_int64 (val
);
386 else if (type
== SCM_UVEC_U64
)
388 assert_exact_integer_range (val
, scm_uint64_min
, scm_uint64_max
);
389 ((SCM
*)base
)[c_idx
] = val
;
391 else if (type
== SCM_UVEC_S64
)
393 assert_exact_integer_range (val
, scm_int64_min
, scm_int64_max
);
394 ((SCM
*)base
)[c_idx
] = val
;
397 else if (type
== SCM_UVEC_F32
)
398 (((float*)base
)[c_idx
]) = scm_to_double (val
);
399 else if (type
== SCM_UVEC_F64
)
400 (((double*)base
)[c_idx
]) = scm_to_double (val
);
401 else if (type
== SCM_UVEC_C32
)
403 (((float*)base
)[2*c_idx
]) = scm_c_real_part (val
);
404 (((float*)base
)[2*c_idx
+1]) = scm_c_imag_part (val
);
406 else if (type
== SCM_UVEC_C64
)
408 (((double*)base
)[2*c_idx
]) = scm_c_real_part (val
);
409 (((double*)base
)[2*c_idx
+1]) = scm_c_imag_part (val
);
413 static SCM_C_INLINE_KEYWORD SCM
414 make_uvec (int type
, SCM len
, SCM fill
)
416 size_t c_len
= scm_to_size_t (len
);
417 SCM uvec
= alloc_uvec (type
, c_len
);
418 if (!SCM_UNBNDP (fill
))
421 void *base
= SCM_UVEC_BASE (uvec
);
422 for (idx
= 0; idx
< c_len
; idx
++)
423 uvec_fast_set_x (type
, base
, idx
, fill
);
428 static SCM_C_INLINE_KEYWORD
void *
429 uvec_writable_elements (int type
, SCM uvec
, scm_t_array_handle
*handle
,
430 size_t *lenp
, ssize_t
*incp
)
435 if (SCM_I_ARRAYP (v
))
436 v
= SCM_I_ARRAY_V (v
);
437 uvec_assert (type
, v
);
440 return scm_uniform_vector_writable_elements (uvec
, handle
, lenp
, incp
);
443 static SCM_C_INLINE_KEYWORD
const void *
444 uvec_elements (int type
, SCM uvec
, scm_t_array_handle
*handle
,
445 size_t *lenp
, ssize_t
*incp
)
447 return uvec_writable_elements (type
, uvec
, handle
, lenp
, incp
);
451 uvec_type (scm_t_array_handle
*h
)
454 if (SCM_I_ARRAYP (v
))
455 v
= SCM_I_ARRAY_V (v
);
456 return SCM_UVEC_TYPE (v
);
460 uvec_to_list (int type
, SCM uvec
)
462 scm_t_array_handle handle
;
468 elts
= uvec_elements (type
, uvec
, &handle
, &len
, &inc
);
469 for (i
= len
*inc
; i
> 0;)
472 res
= scm_cons (scm_array_handle_ref (&handle
, i
), res
);
474 scm_array_handle_release (&handle
);
478 static SCM_C_INLINE_KEYWORD SCM
479 uvec_length (int type
, SCM uvec
)
481 scm_t_array_handle handle
;
484 uvec_elements (type
, uvec
, &handle
, &len
, &inc
);
485 scm_array_handle_release (&handle
);
486 return scm_from_size_t (len
);
489 static SCM_C_INLINE_KEYWORD SCM
490 uvec_ref (int type
, SCM uvec
, SCM idx
)
492 scm_t_array_handle handle
;
498 elts
= uvec_elements (type
, uvec
, &handle
, &len
, &inc
);
500 type
= uvec_type (&handle
);
501 i
= scm_to_unsigned_integer (idx
, 0, len
-1);
502 res
= uvec_fast_ref (type
, elts
, i
*inc
);
503 scm_array_handle_release (&handle
);
507 static SCM_C_INLINE_KEYWORD SCM
508 uvec_set_x (int type
, SCM uvec
, SCM idx
, SCM val
)
510 scm_t_array_handle handle
;
515 elts
= uvec_writable_elements (type
, uvec
, &handle
, &len
, &inc
);
517 type
= uvec_type (&handle
);
518 i
= scm_to_unsigned_integer (idx
, 0, len
-1);
519 uvec_fast_set_x (type
, elts
, i
*inc
, val
);
520 scm_array_handle_release (&handle
);
521 return SCM_UNSPECIFIED
;
524 static SCM_C_INLINE_KEYWORD SCM
525 list_to_uvec (int type
, SCM list
)
530 long len
= scm_ilength (list
);
532 scm_wrong_type_arg_msg (NULL
, 0, list
, "proper list");
534 uvec
= alloc_uvec (type
, len
);
535 base
= SCM_UVEC_BASE (uvec
);
537 while (scm_is_pair (list
) && idx
< len
)
539 uvec_fast_set_x (type
, base
, idx
, SCM_CAR (list
));
540 list
= SCM_CDR (list
);
547 coerce_to_uvec (int type
, SCM obj
)
549 if (is_uvec (type
, obj
))
551 else if (scm_is_pair (obj
))
552 return list_to_uvec (type
, obj
);
553 else if (scm_is_generalized_vector (obj
))
555 scm_t_array_handle handle
;
556 size_t len
= scm_c_generalized_vector_length (obj
), i
;
557 SCM uvec
= alloc_uvec (type
, len
);
558 scm_array_get_handle (uvec
, &handle
);
559 for (i
= 0; i
< len
; i
++)
560 scm_array_handle_set (&handle
, i
,
561 scm_c_generalized_vector_ref (obj
, i
));
562 scm_array_handle_release (&handle
);
566 scm_wrong_type_arg_msg (NULL
, 0, obj
, "list or generalized vector");
569 SCM_SYMBOL (scm_sym_a
, "a");
570 SCM_SYMBOL (scm_sym_b
, "b");
573 scm_i_generalized_vector_type (SCM v
)
575 if (scm_is_vector (v
))
577 else if (scm_is_string (v
))
579 else if (scm_is_bitvector (v
))
581 else if (scm_is_uniform_vector (v
))
582 return scm_from_locale_symbol (uvec_tags
[SCM_UVEC_TYPE(v
)]);
588 scm_is_uniform_vector (SCM obj
)
590 if (SCM_IS_UVEC (obj
))
592 if (SCM_I_ARRAYP (obj
) && SCM_I_ARRAY_NDIM (obj
) == 1)
594 SCM v
= SCM_I_ARRAY_V (obj
);
595 return SCM_IS_UVEC (v
);
601 scm_c_uniform_vector_length (SCM uvec
)
603 /* scm_generalized_vector_get_handle will ultimately call us to get
604 the length of uniform vectors, so we can't use uvec_elements for
608 if (SCM_IS_UVEC (uvec
))
609 return SCM_UVEC_LENGTH (uvec
);
612 scm_t_array_handle handle
;
615 uvec_elements (-1, uvec
, &handle
, &len
, &inc
);
616 scm_array_handle_release (&handle
);
621 SCM_DEFINE (scm_uniform_vector_p
, "uniform-vector?", 1, 0, 0,
623 "Return @code{#t} if @var{obj} is a uniform vector.")
624 #define FUNC_NAME s_scm_uniform_vector_p
626 return scm_from_bool (scm_is_uniform_vector (obj
));
631 scm_c_uniform_vector_ref (SCM v
, size_t idx
)
633 scm_t_array_handle handle
;
638 uvec_elements (-1, v
, &handle
, &len
, &inc
);
640 scm_out_of_range (NULL
, scm_from_size_t (idx
));
641 res
= scm_array_handle_ref (&handle
, idx
*inc
);
642 scm_array_handle_release (&handle
);
646 SCM_DEFINE (scm_uniform_vector_ref
, "uniform-vector-ref", 2, 0, 0,
648 "Return the element at index @var{idx} of the\n"
649 "homogenous numeric vector @var{v}.")
650 #define FUNC_NAME s_scm_uniform_vector_ref
652 #if SCM_ENABLE_DEPRECATED
653 /* Support old argument convention.
655 if (scm_is_pair (idx
))
657 scm_c_issue_deprecation_warning
658 ("Using a list as the index to uniform-vector-ref is deprecated.");
659 if (!scm_is_null (SCM_CDR (idx
)))
660 scm_wrong_num_args (NULL
);
665 return scm_c_uniform_vector_ref (v
, scm_to_size_t (idx
));
670 scm_c_uniform_vector_set_x (SCM v
, size_t idx
, SCM val
)
672 scm_t_array_handle handle
;
676 uvec_writable_elements (-1, v
, &handle
, &len
, &inc
);
678 scm_out_of_range (NULL
, scm_from_size_t (idx
));
679 scm_array_handle_set (&handle
, idx
*inc
, val
);
680 scm_array_handle_release (&handle
);
683 SCM_DEFINE (scm_uniform_vector_set_x
, "uniform-vector-set!", 3, 0, 0,
684 (SCM v
, SCM idx
, SCM val
),
685 "Set the element at index @var{idx} of the\n"
686 "homogenous numeric vector @var{v} to @var{val}.")
687 #define FUNC_NAME s_scm_uniform_vector_set_x
689 #if SCM_ENABLE_DEPRECATED
690 /* Support old argument convention.
692 if (scm_is_pair (idx
))
694 scm_c_issue_deprecation_warning
695 ("Using a list as the index to uniform-vector-set! is deprecated.");
696 if (!scm_is_null (SCM_CDR (idx
)))
697 scm_wrong_num_args (NULL
);
702 scm_c_uniform_vector_set_x (v
, scm_to_size_t (idx
), val
);
703 return SCM_UNSPECIFIED
;
707 SCM_DEFINE (scm_uniform_vector_to_list
, "uniform-vector->list", 1, 0, 0,
709 "Convert the uniform numeric vector @var{uvec} to a list.")
710 #define FUNC_NAME s_scm_uniform_vector_to_list
712 return uvec_to_list (-1, uvec
);
717 scm_array_handle_uniform_element_size (scm_t_array_handle
*h
)
720 if (SCM_I_ARRAYP (vec
))
721 vec
= SCM_I_ARRAY_V (vec
);
722 if (scm_is_uniform_vector (vec
))
723 return uvec_sizes
[SCM_UVEC_TYPE(vec
)];
724 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "uniform array");
727 #if SCM_ENABLE_DEPRECATED
729 /* return the size of an element in a uniform array or 0 if type not
732 scm_uniform_element_size (SCM obj
)
734 scm_c_issue_deprecation_warning
735 ("scm_uniform_element_size is deprecated. "
736 "Use scm_array_handle_uniform_element_size instead.");
738 if (SCM_IS_UVEC (obj
))
739 return uvec_sizes
[SCM_UVEC_TYPE(obj
)];
747 scm_array_handle_uniform_elements (scm_t_array_handle
*h
)
749 return scm_array_handle_uniform_writable_elements (h
);
753 scm_array_handle_uniform_writable_elements (scm_t_array_handle
*h
)
756 if (SCM_I_ARRAYP (vec
))
757 vec
= SCM_I_ARRAY_V (vec
);
758 if (SCM_IS_UVEC (vec
))
760 size_t size
= uvec_sizes
[SCM_UVEC_TYPE(vec
)];
761 char *elts
= SCM_UVEC_BASE (vec
);
762 return (void *) (elts
+ size
*h
->base
);
764 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "uniform array");
768 scm_uniform_vector_elements (SCM uvec
,
769 scm_t_array_handle
*h
,
770 size_t *lenp
, ssize_t
*incp
)
772 return scm_uniform_vector_writable_elements (uvec
, h
, lenp
, incp
);
776 scm_uniform_vector_writable_elements (SCM uvec
,
777 scm_t_array_handle
*h
,
778 size_t *lenp
, ssize_t
*incp
)
780 scm_generalized_vector_get_handle (uvec
, h
);
783 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
784 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
787 return scm_array_handle_uniform_writable_elements (h
);
790 SCM_DEFINE (scm_uniform_vector_length
, "uniform-vector-length", 1, 0, 0,
792 "Return the number of elements in the uniform vector @var{v}.")
793 #define FUNC_NAME s_scm_uniform_vector_length
795 return uvec_length (-1, v
);
799 SCM_DEFINE (scm_uniform_vector_read_x
, "uniform-vector-read!", 1, 3, 0,
800 (SCM uvec
, SCM port_or_fd
, SCM start
, SCM end
),
801 "Fill the elements of @var{uvec} by reading\n"
802 "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
803 "The optional arguments @var{start} (inclusive) and @var{end}\n"
804 "(exclusive) allow a specified region to be read,\n"
805 "leaving the remainder of the vector unchanged.\n\n"
806 "When @var{port-or-fdes} is a port, all specified elements\n"
807 "of @var{uvec} are attempted to be read, potentially blocking\n"
808 "while waiting formore input or end-of-file.\n"
809 "When @var{port-or-fd} is an integer, a single call to\n"
810 "read(2) is made.\n\n"
811 "An error is signalled when the last element has only\n"
812 "been partially filled before reaching end-of-file or in\n"
813 "the single call to read(2).\n\n"
814 "@code{uniform-vector-read!} returns the number of elements\n"
816 "@var{port-or-fdes} may be omitted, in which case it defaults\n"
817 "to the value returned by @code{(current-input-port)}.")
818 #define FUNC_NAME s_scm_uniform_vector_read_x
820 scm_t_array_handle handle
;
821 size_t vlen
, sz
, ans
;
824 size_t remaining
, off
;
827 if (SCM_UNBNDP (port_or_fd
))
828 port_or_fd
= scm_current_input_port ();
830 SCM_ASSERT (scm_is_integer (port_or_fd
)
831 || (SCM_OPINPORTP (port_or_fd
)),
832 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
834 if (!scm_is_uniform_vector (uvec
))
835 scm_wrong_type_arg_msg (NULL
, 0, uvec
, "uniform vector");
837 base
= scm_uniform_vector_writable_elements (uvec
, &handle
, &vlen
, &inc
);
838 sz
= scm_array_handle_uniform_element_size (&handle
);
842 /* XXX - we should of course support non contiguous vectors. */
843 scm_misc_error (NULL
, "only contiguous vectors are supported: ~a",
849 if (!SCM_UNBNDP (start
))
851 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
852 if (!SCM_UNBNDP (end
))
853 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
856 remaining
= (cend
- cstart
) * sz
;
859 if (SCM_NIMP (port_or_fd
))
862 remaining
-= scm_c_read (port_or_fd
, base
+ off
, remaining
);
863 if (remaining
% sz
!= 0)
864 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL
);
865 ans
-= remaining
/ sz
;
867 else /* file descriptor. */
869 int fd
= scm_to_int (port_or_fd
);
872 SCM_SYSCALL (n
= read (fd
, base
+ off
, remaining
));
876 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL
);
880 scm_array_handle_release (&handle
);
882 return scm_from_size_t (ans
);
886 SCM_DEFINE (scm_uniform_vector_write
, "uniform-vector-write", 1, 3, 0,
887 (SCM uvec
, SCM port_or_fd
, SCM start
, SCM end
),
888 "Write the elements of @var{uvec} as raw bytes to\n"
889 "@var{port-or-fdes}, in the host byte order.\n\n"
890 "The optional arguments @var{start} (inclusive)\n"
891 "and @var{end} (exclusive) allow\n"
892 "a specified region to be written.\n\n"
893 "When @var{port-or-fdes} is a port, all specified elements\n"
894 "of @var{uvec} are attempted to be written, potentially blocking\n"
895 "while waiting for more room.\n"
896 "When @var{port-or-fd} is an integer, a single call to\n"
897 "write(2) is made.\n\n"
898 "An error is signalled when the last element has only\n"
899 "been partially written in the single call to write(2).\n\n"
900 "The number of objects actually written is returned.\n"
901 "@var{port-or-fdes} may be\n"
902 "omitted, in which case it defaults to the value returned by\n"
903 "@code{(current-output-port)}.")
904 #define FUNC_NAME s_scm_uniform_vector_write
906 scm_t_array_handle handle
;
907 size_t vlen
, sz
, ans
;
913 port_or_fd
= SCM_COERCE_OUTPORT (port_or_fd
);
915 if (SCM_UNBNDP (port_or_fd
))
916 port_or_fd
= scm_current_output_port ();
918 SCM_ASSERT (scm_is_integer (port_or_fd
)
919 || (SCM_OPOUTPORTP (port_or_fd
)),
920 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
922 base
= scm_uniform_vector_elements (uvec
, &handle
, &vlen
, &inc
);
923 sz
= scm_array_handle_uniform_element_size (&handle
);
927 /* XXX - we should of course support non contiguous vectors. */
928 scm_misc_error (NULL
, "only contiguous vectors are supported: ~a",
934 if (!SCM_UNBNDP (start
))
936 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
937 if (!SCM_UNBNDP (end
))
938 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
941 amount
= (cend
- cstart
) * sz
;
944 if (SCM_NIMP (port_or_fd
))
946 scm_lfwrite (base
+ off
, amount
, port_or_fd
);
949 else /* file descriptor. */
951 int fd
= scm_to_int (port_or_fd
), n
;
952 SCM_SYSCALL (n
= write (fd
, base
+ off
, amount
));
956 SCM_MISC_ERROR ("last element only written partially", SCM_EOL
);
960 scm_array_handle_release (&handle
);
962 return scm_from_size_t (ans
);
966 /* ================================================================ */
967 /* Exported procedures. */
968 /* ================================================================ */
970 #define TYPE SCM_UVEC_U8
972 #define CTYPE scm_t_uint8
973 #include "libguile/srfi-4.i.c"
975 #define TYPE SCM_UVEC_S8
977 #define CTYPE scm_t_int8
978 #include "libguile/srfi-4.i.c"
980 #define TYPE SCM_UVEC_U16
982 #define CTYPE scm_t_uint16
983 #include "libguile/srfi-4.i.c"
985 #define TYPE SCM_UVEC_S16
987 #define CTYPE scm_t_int16
988 #include "libguile/srfi-4.i.c"
990 #define TYPE SCM_UVEC_U32
992 #define CTYPE scm_t_uint32
993 #include "libguile/srfi-4.i.c"
995 #define TYPE SCM_UVEC_S32
997 #define CTYPE scm_t_int32
998 #include "libguile/srfi-4.i.c"
1000 #define TYPE SCM_UVEC_U64
1002 #if SCM_HAVE_T_UINT64
1003 #define CTYPE scm_t_uint64
1005 #include "libguile/srfi-4.i.c"
1007 #define TYPE SCM_UVEC_S64
1009 #if SCM_HAVE_T_INT64
1010 #define CTYPE scm_t_int64
1012 #include "libguile/srfi-4.i.c"
1014 #define TYPE SCM_UVEC_F32
1017 #include "libguile/srfi-4.i.c"
1019 #define TYPE SCM_UVEC_F64
1021 #define CTYPE double
1022 #include "libguile/srfi-4.i.c"
1024 #define TYPE SCM_UVEC_C32
1027 #include "libguile/srfi-4.i.c"
1029 #define TYPE SCM_UVEC_C64
1031 #define CTYPE double
1032 #include "libguile/srfi-4.i.c"
1034 static scm_i_t_array_ref uvec_reffers
[12] = {
1043 static scm_i_t_array_set uvec_setters
[12] = {
1053 scm_i_uniform_vector_ref_proc (SCM uvec
)
1055 return uvec_reffers
[SCM_UVEC_TYPE(uvec
)];
1059 scm_i_uniform_vector_set_proc (SCM uvec
)
1061 return uvec_setters
[SCM_UVEC_TYPE(uvec
)];
1065 scm_init_srfi_4 (void)
1067 scm_tc16_uvec
= scm_make_smob_type ("uvec", 0);
1068 scm_set_smob_equalp (scm_tc16_uvec
, uvec_equalp
);
1069 scm_set_smob_print (scm_tc16_uvec
, uvec_print
);
1071 #if SCM_HAVE_T_INT64 == 0
1073 scm_permanent_object (scm_from_int (0));
1075 scm_permanent_object (scm_c_read_string ("18446744073709551615"));
1077 scm_permanent_object (scm_c_read_string ("-9223372036854775808"));
1079 scm_permanent_object (scm_c_read_string ("9223372036854775807"));
1082 #include "libguile/srfi-4.x"
1086 /* End of srfi-4.c. */