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
);
247 /* Mark hook. Only used when U64 and S64 are implemented as SCMs. */
249 #if SCM_HAVE_T_INT64 == 0
253 if (SCM_UVEC_TYPE (uvec
) == SCM_UVEC_U64
254 || SCM_UVEC_TYPE (uvec
) == SCM_UVEC_S64
)
256 SCM
*ptr
= (SCM
*)SCM_UVEC_BASE (uvec
);
257 size_t len
= SCM_UVEC_LENGTH (uvec
), i
;
258 for (i
= 0; i
< len
; i
++)
259 scm_gc_mark (*ptr
++);
265 /* Smob free hook for uniform numeric vectors. */
269 int type
= SCM_UVEC_TYPE (uvec
);
270 scm_gc_free (SCM_UVEC_BASE (uvec
),
271 SCM_UVEC_LENGTH (uvec
) * uvec_sizes
[type
],
276 /* ================================================================ */
277 /* Utility procedures. */
278 /* ================================================================ */
280 static SCM_C_INLINE_KEYWORD
int
281 is_uvec (int type
, SCM obj
)
283 if (SCM_IS_UVEC (obj
))
284 return SCM_UVEC_TYPE (obj
) == type
;
285 if (SCM_I_ARRAYP (obj
) && SCM_I_ARRAY_NDIM (obj
) == 1)
287 SCM v
= SCM_I_ARRAY_V (obj
);
288 return SCM_IS_UVEC (v
) && SCM_UVEC_TYPE (v
) == type
;
293 static SCM_C_INLINE_KEYWORD SCM
294 uvec_p (int type
, SCM obj
)
296 return scm_from_bool (is_uvec (type
, obj
));
299 static SCM_C_INLINE_KEYWORD
void
300 uvec_assert (int type
, SCM obj
)
302 if (!is_uvec (type
, obj
))
303 scm_wrong_type_arg_msg (NULL
, 0, obj
, uvec_names
[type
]);
307 take_uvec (int type
, void *base
, size_t len
)
309 SCM_RETURN_NEWSMOB3 (scm_tc16_uvec
, type
, len
, (scm_t_bits
) base
);
312 /* Create a new, uninitialized uniform numeric vector of type TYPE
313 with space for LEN elements. */
315 alloc_uvec (int type
, size_t len
)
318 if (len
> SCM_I_SIZE_MAX
/ uvec_sizes
[type
])
319 scm_out_of_range (NULL
, scm_from_size_t (len
));
320 base
= scm_gc_malloc (len
* uvec_sizes
[type
], uvec_names
[type
]);
321 #if SCM_HAVE_T_INT64 == 0
322 if (type
== SCM_UVEC_U64
|| type
== SCM_UVEC_S64
)
324 SCM
*ptr
= (SCM
*)base
;
326 for (i
= 0; i
< len
; i
++)
327 *ptr
++ = SCM_UNSPECIFIED
;
330 return take_uvec (type
, base
, len
);
333 /* GCC doesn't seem to want to optimize unused switch clauses away,
334 so we use a big 'if' in the next two functions.
337 static SCM_C_INLINE_KEYWORD SCM
338 uvec_fast_ref (int type
, const void *base
, size_t c_idx
)
340 if (type
== SCM_UVEC_U8
)
341 return scm_from_uint8 (((scm_t_uint8
*)base
)[c_idx
]);
342 else if (type
== SCM_UVEC_S8
)
343 return scm_from_int8 (((scm_t_int8
*)base
)[c_idx
]);
344 else if (type
== SCM_UVEC_U16
)
345 return scm_from_uint16 (((scm_t_uint16
*)base
)[c_idx
]);
346 else if (type
== SCM_UVEC_S16
)
347 return scm_from_int16 (((scm_t_int16
*)base
)[c_idx
]);
348 else if (type
== SCM_UVEC_U32
)
349 return scm_from_uint32 (((scm_t_uint32
*)base
)[c_idx
]);
350 else if (type
== SCM_UVEC_S32
)
351 return scm_from_int32 (((scm_t_int32
*)base
)[c_idx
]);
353 else if (type
== SCM_UVEC_U64
)
354 return scm_from_uint64 (((scm_t_uint64
*)base
)[c_idx
]);
355 else if (type
== SCM_UVEC_S64
)
356 return scm_from_int64 (((scm_t_int64
*)base
)[c_idx
]);
358 else if (type
== SCM_UVEC_U64
)
359 return ((SCM
*)base
)[c_idx
];
360 else if (type
== SCM_UVEC_S64
)
361 return ((SCM
*)base
)[c_idx
];
363 else if (type
== SCM_UVEC_F32
)
364 return scm_from_double (((float*)base
)[c_idx
]);
365 else if (type
== SCM_UVEC_F64
)
366 return scm_from_double (((double*)base
)[c_idx
]);
367 else if (type
== SCM_UVEC_C32
)
368 return scm_c_make_rectangular (((float*)base
)[2*c_idx
],
369 ((float*)base
)[2*c_idx
+1]);
370 else if (type
== SCM_UVEC_C64
)
371 return scm_c_make_rectangular (((double*)base
)[2*c_idx
],
372 ((double*)base
)[2*c_idx
+1]);
377 #if SCM_HAVE_T_INT64 == 0
378 static SCM scm_uint64_min
, scm_uint64_max
;
379 static SCM scm_int64_min
, scm_int64_max
;
382 assert_exact_integer_range (SCM val
, SCM min
, SCM max
)
384 if (!scm_is_integer (val
)
385 || scm_is_false (scm_exact_p (val
)))
386 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
387 if (scm_is_true (scm_less_p (val
, min
))
388 || scm_is_true (scm_gr_p (val
, max
)))
389 scm_out_of_range (NULL
, val
);
393 static SCM_C_INLINE_KEYWORD
void
394 uvec_fast_set_x (int type
, void *base
, size_t c_idx
, SCM val
)
396 if (type
== SCM_UVEC_U8
)
397 (((scm_t_uint8
*)base
)[c_idx
]) = scm_to_uint8 (val
);
398 else if (type
== SCM_UVEC_S8
)
399 (((scm_t_int8
*)base
)[c_idx
]) = scm_to_int8 (val
);
400 else if (type
== SCM_UVEC_U16
)
401 (((scm_t_uint16
*)base
)[c_idx
]) = scm_to_uint16 (val
);
402 else if (type
== SCM_UVEC_S16
)
403 (((scm_t_int16
*)base
)[c_idx
]) = scm_to_int16 (val
);
404 else if (type
== SCM_UVEC_U32
)
405 (((scm_t_uint32
*)base
)[c_idx
]) = scm_to_uint32 (val
);
406 else if (type
== SCM_UVEC_S32
)
407 (((scm_t_int32
*)base
)[c_idx
]) = scm_to_int32 (val
);
409 else if (type
== SCM_UVEC_U64
)
410 (((scm_t_uint64
*)base
)[c_idx
]) = scm_to_uint64 (val
);
411 else if (type
== SCM_UVEC_S64
)
412 (((scm_t_int64
*)base
)[c_idx
]) = scm_to_int64 (val
);
414 else if (type
== SCM_UVEC_U64
)
416 assert_exact_integer_range (val
, scm_uint64_min
, scm_uint64_max
);
417 ((SCM
*)base
)[c_idx
] = val
;
419 else if (type
== SCM_UVEC_S64
)
421 assert_exact_integer_range (val
, scm_int64_min
, scm_int64_max
);
422 ((SCM
*)base
)[c_idx
] = val
;
425 else if (type
== SCM_UVEC_F32
)
426 (((float*)base
)[c_idx
]) = scm_to_double (val
);
427 else if (type
== SCM_UVEC_F64
)
428 (((double*)base
)[c_idx
]) = scm_to_double (val
);
429 else if (type
== SCM_UVEC_C32
)
431 (((float*)base
)[2*c_idx
]) = scm_c_real_part (val
);
432 (((float*)base
)[2*c_idx
+1]) = scm_c_imag_part (val
);
434 else if (type
== SCM_UVEC_C64
)
436 (((double*)base
)[2*c_idx
]) = scm_c_real_part (val
);
437 (((double*)base
)[2*c_idx
+1]) = scm_c_imag_part (val
);
441 static SCM_C_INLINE_KEYWORD SCM
442 make_uvec (int type
, SCM len
, SCM fill
)
444 size_t c_len
= scm_to_size_t (len
);
445 SCM uvec
= alloc_uvec (type
, c_len
);
446 if (!SCM_UNBNDP (fill
))
449 void *base
= SCM_UVEC_BASE (uvec
);
450 for (idx
= 0; idx
< c_len
; idx
++)
451 uvec_fast_set_x (type
, base
, idx
, fill
);
456 static SCM_C_INLINE_KEYWORD
void *
457 uvec_writable_elements (int type
, SCM uvec
, scm_t_array_handle
*handle
,
458 size_t *lenp
, ssize_t
*incp
)
463 if (SCM_I_ARRAYP (v
))
464 v
= SCM_I_ARRAY_V (v
);
465 uvec_assert (type
, v
);
468 return scm_uniform_vector_writable_elements (uvec
, handle
, lenp
, incp
);
471 static SCM_C_INLINE_KEYWORD
const void *
472 uvec_elements (int type
, SCM uvec
, scm_t_array_handle
*handle
,
473 size_t *lenp
, ssize_t
*incp
)
475 return uvec_writable_elements (type
, uvec
, handle
, lenp
, incp
);
479 uvec_type (scm_t_array_handle
*h
)
482 if (SCM_I_ARRAYP (v
))
483 v
= SCM_I_ARRAY_V (v
);
484 return SCM_UVEC_TYPE (v
);
488 uvec_to_list (int type
, SCM uvec
)
490 scm_t_array_handle handle
;
496 elts
= uvec_elements (type
, uvec
, &handle
, &len
, &inc
);
497 for (i
= len
*inc
; i
> 0;)
500 res
= scm_cons (scm_array_handle_ref (&handle
, i
), res
);
502 scm_array_handle_release (&handle
);
506 static SCM_C_INLINE_KEYWORD SCM
507 uvec_length (int type
, SCM uvec
)
509 scm_t_array_handle handle
;
512 uvec_elements (type
, uvec
, &handle
, &len
, &inc
);
513 scm_array_handle_release (&handle
);
514 return scm_from_size_t (len
);
517 static SCM_C_INLINE_KEYWORD SCM
518 uvec_ref (int type
, SCM uvec
, SCM idx
)
520 scm_t_array_handle handle
;
526 elts
= uvec_elements (type
, uvec
, &handle
, &len
, &inc
);
528 type
= uvec_type (&handle
);
529 i
= scm_to_unsigned_integer (idx
, 0, len
-1);
530 res
= uvec_fast_ref (type
, elts
, i
*inc
);
531 scm_array_handle_release (&handle
);
535 static SCM_C_INLINE_KEYWORD SCM
536 uvec_set_x (int type
, SCM uvec
, SCM idx
, SCM val
)
538 scm_t_array_handle handle
;
543 elts
= uvec_writable_elements (type
, uvec
, &handle
, &len
, &inc
);
545 type
= uvec_type (&handle
);
546 i
= scm_to_unsigned_integer (idx
, 0, len
-1);
547 uvec_fast_set_x (type
, elts
, i
*inc
, val
);
548 scm_array_handle_release (&handle
);
549 return SCM_UNSPECIFIED
;
552 static SCM_C_INLINE_KEYWORD SCM
553 list_to_uvec (int type
, SCM list
)
558 long len
= scm_ilength (list
);
560 scm_wrong_type_arg_msg (NULL
, 0, list
, "proper list");
562 uvec
= alloc_uvec (type
, len
);
563 base
= SCM_UVEC_BASE (uvec
);
565 while (scm_is_pair (list
) && idx
< len
)
567 uvec_fast_set_x (type
, base
, idx
, SCM_CAR (list
));
568 list
= SCM_CDR (list
);
575 coerce_to_uvec (int type
, SCM obj
)
577 if (is_uvec (type
, obj
))
579 else if (scm_is_pair (obj
))
580 return list_to_uvec (type
, obj
);
581 else if (scm_is_generalized_vector (obj
))
583 scm_t_array_handle handle
;
584 size_t len
= scm_c_generalized_vector_length (obj
), i
;
585 SCM uvec
= alloc_uvec (type
, len
);
586 scm_array_get_handle (uvec
, &handle
);
587 for (i
= 0; i
< len
; i
++)
588 scm_array_handle_set (&handle
, i
,
589 scm_c_generalized_vector_ref (obj
, i
));
590 scm_array_handle_release (&handle
);
594 scm_wrong_type_arg_msg (NULL
, 0, obj
, "list or generalized vector");
597 SCM_SYMBOL (scm_sym_a
, "a");
598 SCM_SYMBOL (scm_sym_b
, "b");
601 scm_i_generalized_vector_type (SCM v
)
603 if (scm_is_vector (v
))
605 else if (scm_is_string (v
))
607 else if (scm_is_bitvector (v
))
609 else if (scm_is_uniform_vector (v
))
610 return scm_from_locale_symbol (uvec_tags
[SCM_UVEC_TYPE(v
)]);
616 scm_is_uniform_vector (SCM obj
)
618 if (SCM_IS_UVEC (obj
))
620 if (SCM_I_ARRAYP (obj
) && SCM_I_ARRAY_NDIM (obj
) == 1)
622 SCM v
= SCM_I_ARRAY_V (obj
);
623 return SCM_IS_UVEC (v
);
629 scm_c_uniform_vector_length (SCM uvec
)
631 /* scm_generalized_vector_get_handle will ultimately call us to get
632 the length of uniform vectors, so we can't use uvec_elements for
636 if (SCM_IS_UVEC (uvec
))
637 return SCM_UVEC_LENGTH (uvec
);
640 scm_t_array_handle handle
;
643 uvec_elements (-1, uvec
, &handle
, &len
, &inc
);
644 scm_array_handle_release (&handle
);
649 SCM_DEFINE (scm_uniform_vector_p
, "uniform-vector?", 1, 0, 0,
651 "Return @code{#t} if @var{obj} is a uniform vector.")
652 #define FUNC_NAME s_scm_uniform_vector_p
654 return scm_from_bool (scm_is_uniform_vector (obj
));
659 scm_c_uniform_vector_ref (SCM v
, size_t idx
)
661 scm_t_array_handle handle
;
666 uvec_elements (-1, v
, &handle
, &len
, &inc
);
668 scm_out_of_range (NULL
, scm_from_size_t (idx
));
669 res
= scm_array_handle_ref (&handle
, idx
*inc
);
670 scm_array_handle_release (&handle
);
674 SCM_DEFINE (scm_uniform_vector_ref
, "uniform-vector-ref", 2, 0, 0,
676 "Return the element at index @var{idx} of the\n"
677 "homogenous numeric vector @var{v}.")
678 #define FUNC_NAME s_scm_uniform_vector_ref
680 #if SCM_ENABLE_DEPRECATED
681 /* Support old argument convention.
683 if (scm_is_pair (idx
))
685 scm_c_issue_deprecation_warning
686 ("Using a list as the index to uniform-vector-ref is deprecated.");
687 if (!scm_is_null (SCM_CDR (idx
)))
688 scm_wrong_num_args (NULL
);
693 return scm_c_uniform_vector_ref (v
, scm_to_size_t (idx
));
698 scm_c_uniform_vector_set_x (SCM v
, size_t idx
, SCM val
)
700 scm_t_array_handle handle
;
704 uvec_writable_elements (-1, v
, &handle
, &len
, &inc
);
706 scm_out_of_range (NULL
, scm_from_size_t (idx
));
707 scm_array_handle_set (&handle
, idx
*inc
, val
);
708 scm_array_handle_release (&handle
);
711 SCM_DEFINE (scm_uniform_vector_set_x
, "uniform-vector-set!", 3, 0, 0,
712 (SCM v
, SCM idx
, SCM val
),
713 "Set the element at index @var{idx} of the\n"
714 "homogenous numeric vector @var{v} to @var{val}.")
715 #define FUNC_NAME s_scm_uniform_vector_set_x
717 #if SCM_ENABLE_DEPRECATED
718 /* Support old argument convention.
720 if (scm_is_pair (idx
))
722 scm_c_issue_deprecation_warning
723 ("Using a list as the index to uniform-vector-set! is deprecated.");
724 if (!scm_is_null (SCM_CDR (idx
)))
725 scm_wrong_num_args (NULL
);
730 scm_c_uniform_vector_set_x (v
, scm_to_size_t (idx
), val
);
731 return SCM_UNSPECIFIED
;
735 SCM_DEFINE (scm_uniform_vector_to_list
, "uniform-vector->list", 1, 0, 0,
737 "Convert the uniform numeric vector @var{uvec} to a list.")
738 #define FUNC_NAME s_scm_uniform_vector_to_list
740 return uvec_to_list (-1, uvec
);
745 scm_array_handle_uniform_element_size (scm_t_array_handle
*h
)
748 if (SCM_I_ARRAYP (vec
))
749 vec
= SCM_I_ARRAY_V (vec
);
750 if (scm_is_uniform_vector (vec
))
751 return uvec_sizes
[SCM_UVEC_TYPE(vec
)];
752 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "uniform array");
755 #if SCM_ENABLE_DEPRECATED
757 /* return the size of an element in a uniform array or 0 if type not
760 scm_uniform_element_size (SCM obj
)
762 scm_c_issue_deprecation_warning
763 ("scm_uniform_element_size is deprecated. "
764 "Use scm_array_handle_uniform_element_size instead.");
766 if (SCM_IS_UVEC (obj
))
767 return uvec_sizes
[SCM_UVEC_TYPE(obj
)];
775 scm_array_handle_uniform_elements (scm_t_array_handle
*h
)
777 return scm_array_handle_uniform_writable_elements (h
);
781 scm_array_handle_uniform_writable_elements (scm_t_array_handle
*h
)
784 if (SCM_I_ARRAYP (vec
))
785 vec
= SCM_I_ARRAY_V (vec
);
786 if (SCM_IS_UVEC (vec
))
788 size_t size
= uvec_sizes
[SCM_UVEC_TYPE(vec
)];
789 char *elts
= SCM_UVEC_BASE (vec
);
790 return (void *) (elts
+ size
*h
->base
);
792 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "uniform array");
796 scm_uniform_vector_elements (SCM uvec
,
797 scm_t_array_handle
*h
,
798 size_t *lenp
, ssize_t
*incp
)
800 return scm_uniform_vector_writable_elements (uvec
, h
, lenp
, incp
);
804 scm_uniform_vector_writable_elements (SCM uvec
,
805 scm_t_array_handle
*h
,
806 size_t *lenp
, ssize_t
*incp
)
808 scm_generalized_vector_get_handle (uvec
, h
);
811 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
812 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
815 return scm_array_handle_uniform_writable_elements (h
);
818 SCM_DEFINE (scm_uniform_vector_length
, "uniform-vector-length", 1, 0, 0,
820 "Return the number of elements in the uniform vector @var{v}.")
821 #define FUNC_NAME s_scm_uniform_vector_length
823 return uvec_length (-1, v
);
827 SCM_DEFINE (scm_uniform_vector_read_x
, "uniform-vector-read!", 1, 3, 0,
828 (SCM uvec
, SCM port_or_fd
, SCM start
, SCM end
),
829 "Fill the elements of @var{uvec} by reading\n"
830 "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
831 "The optional arguments @var{start} (inclusive) and @var{end}\n"
832 "(exclusive) allow a specified region to be read,\n"
833 "leaving the remainder of the vector unchanged.\n\n"
834 "When @var{port-or-fdes} is a port, all specified elements\n"
835 "of @var{uvec} are attempted to be read, potentially blocking\n"
836 "while waiting formore input or end-of-file.\n"
837 "When @var{port-or-fd} is an integer, a single call to\n"
838 "read(2) is made.\n\n"
839 "An error is signalled when the last element has only\n"
840 "been partially filled before reaching end-of-file or in\n"
841 "the single call to read(2).\n\n"
842 "@code{uniform-vector-read!} returns the number of elements\n"
844 "@var{port-or-fdes} may be omitted, in which case it defaults\n"
845 "to the value returned by @code{(current-input-port)}.")
846 #define FUNC_NAME s_scm_uniform_vector_read_x
848 scm_t_array_handle handle
;
849 size_t vlen
, sz
, ans
;
852 size_t remaining
, off
;
855 if (SCM_UNBNDP (port_or_fd
))
856 port_or_fd
= scm_current_input_port ();
858 SCM_ASSERT (scm_is_integer (port_or_fd
)
859 || (SCM_OPINPORTP (port_or_fd
)),
860 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
862 if (!scm_is_uniform_vector (uvec
))
863 scm_wrong_type_arg_msg (NULL
, 0, uvec
, "uniform vector");
865 base
= scm_uniform_vector_writable_elements (uvec
, &handle
, &vlen
, &inc
);
866 sz
= scm_array_handle_uniform_element_size (&handle
);
870 /* XXX - we should of course support non contiguous vectors. */
871 scm_misc_error (NULL
, "only contiguous vectors are supported: ~a",
877 if (!SCM_UNBNDP (start
))
879 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
880 if (!SCM_UNBNDP (end
))
881 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
884 remaining
= (cend
- cstart
) * sz
;
887 if (SCM_NIMP (port_or_fd
))
889 scm_t_port
*pt
= SCM_PTAB_ENTRY (port_or_fd
);
891 if (pt
->rw_active
== SCM_PORT_WRITE
)
892 scm_flush (port_or_fd
);
895 while (remaining
> 0)
897 if (pt
->read_pos
< pt
->read_end
)
899 size_t to_copy
= min (pt
->read_end
- pt
->read_pos
,
902 memcpy (base
+ off
, pt
->read_pos
, to_copy
);
903 pt
->read_pos
+= to_copy
;
904 remaining
-= to_copy
;
909 if (scm_fill_input (port_or_fd
) == EOF
)
911 if (remaining
% sz
!= 0)
912 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL
);
913 ans
-= remaining
/ sz
;
920 pt
->rw_active
= SCM_PORT_READ
;
922 else /* file descriptor. */
924 int fd
= scm_to_int (port_or_fd
);
927 SCM_SYSCALL (n
= read (fd
, base
+ off
, remaining
));
931 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL
);
935 scm_array_handle_release (&handle
);
937 return scm_from_size_t (ans
);
941 SCM_DEFINE (scm_uniform_vector_write
, "uniform-vector-write", 1, 3, 0,
942 (SCM uvec
, SCM port_or_fd
, SCM start
, SCM end
),
943 "Write the elements of @var{uvec} as raw bytes to\n"
944 "@var{port-or-fdes}, in the host byte order.\n\n"
945 "The optional arguments @var{start} (inclusive)\n"
946 "and @var{end} (exclusive) allow\n"
947 "a specified region to be written.\n\n"
948 "When @var{port-or-fdes} is a port, all specified elements\n"
949 "of @var{uvec} are attempted to be written, potentially blocking\n"
950 "while waiting for more room.\n"
951 "When @var{port-or-fd} is an integer, a single call to\n"
952 "write(2) is made.\n\n"
953 "An error is signalled when the last element has only\n"
954 "been partially written in the single call to write(2).\n\n"
955 "The number of objects actually written is returned.\n"
956 "@var{port-or-fdes} may be\n"
957 "omitted, in which case it defaults to the value returned by\n"
958 "@code{(current-output-port)}.")
959 #define FUNC_NAME s_scm_uniform_vector_write
961 scm_t_array_handle handle
;
962 size_t vlen
, sz
, ans
;
968 port_or_fd
= SCM_COERCE_OUTPORT (port_or_fd
);
970 if (SCM_UNBNDP (port_or_fd
))
971 port_or_fd
= scm_current_output_port ();
973 SCM_ASSERT (scm_is_integer (port_or_fd
)
974 || (SCM_OPOUTPORTP (port_or_fd
)),
975 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
977 base
= scm_uniform_vector_elements (uvec
, &handle
, &vlen
, &inc
);
978 sz
= scm_array_handle_uniform_element_size (&handle
);
982 /* XXX - we should of course support non contiguous vectors. */
983 scm_misc_error (NULL
, "only contiguous vectors are supported: ~a",
989 if (!SCM_UNBNDP (start
))
991 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
992 if (!SCM_UNBNDP (end
))
993 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
996 amount
= (cend
- cstart
) * sz
;
999 if (SCM_NIMP (port_or_fd
))
1001 scm_lfwrite (base
+ off
, amount
, port_or_fd
);
1002 ans
= cend
- cstart
;
1004 else /* file descriptor. */
1006 int fd
= scm_to_int (port_or_fd
), n
;
1007 SCM_SYSCALL (n
= write (fd
, base
+ off
, amount
));
1011 SCM_MISC_ERROR ("last element only written partially", SCM_EOL
);
1015 scm_array_handle_release (&handle
);
1017 return scm_from_size_t (ans
);
1021 /* ================================================================ */
1022 /* Exported procedures. */
1023 /* ================================================================ */
1025 #define TYPE SCM_UVEC_U8
1027 #define CTYPE scm_t_uint8
1028 #include "libguile/srfi-4.i.c"
1030 #define TYPE SCM_UVEC_S8
1032 #define CTYPE scm_t_int8
1033 #include "libguile/srfi-4.i.c"
1035 #define TYPE SCM_UVEC_U16
1037 #define CTYPE scm_t_uint16
1038 #include "libguile/srfi-4.i.c"
1040 #define TYPE SCM_UVEC_S16
1042 #define CTYPE scm_t_int16
1043 #include "libguile/srfi-4.i.c"
1045 #define TYPE SCM_UVEC_U32
1047 #define CTYPE scm_t_uint32
1048 #include "libguile/srfi-4.i.c"
1050 #define TYPE SCM_UVEC_S32
1052 #define CTYPE scm_t_int32
1053 #include "libguile/srfi-4.i.c"
1055 #define TYPE SCM_UVEC_U64
1057 #if SCM_HAVE_T_UINT64
1058 #define CTYPE scm_t_uint64
1060 #include "libguile/srfi-4.i.c"
1062 #define TYPE SCM_UVEC_S64
1064 #if SCM_HAVE_T_INT64
1065 #define CTYPE scm_t_int64
1067 #include "libguile/srfi-4.i.c"
1069 #define TYPE SCM_UVEC_F32
1072 #include "libguile/srfi-4.i.c"
1074 #define TYPE SCM_UVEC_F64
1076 #define CTYPE double
1077 #include "libguile/srfi-4.i.c"
1079 #define TYPE SCM_UVEC_C32
1082 #include "libguile/srfi-4.i.c"
1084 #define TYPE SCM_UVEC_C64
1086 #define CTYPE double
1087 #include "libguile/srfi-4.i.c"
1089 static scm_i_t_array_ref uvec_reffers
[12] = {
1098 static scm_i_t_array_set uvec_setters
[12] = {
1108 scm_i_uniform_vector_ref_proc (SCM uvec
)
1110 return uvec_reffers
[SCM_UVEC_TYPE(uvec
)];
1114 scm_i_uniform_vector_set_proc (SCM uvec
)
1116 return uvec_setters
[SCM_UVEC_TYPE(uvec
)];
1120 scm_init_srfi_4 (void)
1122 scm_tc16_uvec
= scm_make_smob_type ("uvec", 0);
1123 scm_set_smob_equalp (scm_tc16_uvec
, uvec_equalp
);
1124 #if SCM_HAVE_T_INT64 == 0
1125 scm_set_smob_mark (scm_tc16_uvec
, uvec_mark
);
1127 scm_set_smob_free (scm_tc16_uvec
, uvec_free
);
1128 scm_set_smob_print (scm_tc16_uvec
, uvec_print
);
1130 #if SCM_HAVE_T_INT64 == 0
1132 scm_permanent_object (scm_from_int (0));
1134 scm_permanent_object (scm_c_read_string ("18446744073709551615"));
1136 scm_permanent_object (scm_c_read_string ("-9223372036854775808"));
1138 scm_permanent_object (scm_c_read_string ("9223372036854775807"));
1141 #include "libguile/srfi-4.x"
1145 /* End of srfi-4.c. */