1 /* srfi-4.c --- Homogeneous numeric vector datatypes.
3 * Copyright (C) 2001, 2004 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24 #include "libguile/srfi-4.h"
25 #include "libguile/error.h"
26 #include "libguile/read.h"
27 #include "libguile/ports.h"
28 #include "libguile/chars.h"
30 /* Smob type code for homogeneous numeric vectors. */
31 int scm_tc16_uvec
= 0;
34 /* Accessor macros for the three components of a homogeneous numeric
36 - The type tag (one of the symbolic constants below).
37 - The vector's length (counted in elements).
38 - The address of the data area (holding the elements of the
40 #define SCM_UVEC_TYPE(u) (SCM_CELL_WORD_1(u))
41 #define SCM_UVEC_LENGTH(u) ((size_t)SCM_CELL_WORD_2(u))
42 #define SCM_UVEC_BASE(u) ((void *)SCM_CELL_WORD_3(u))
45 /* Symbolic constants encoding the various types of homogeneous
49 #define SCM_UVEC_U16 2
50 #define SCM_UVEC_S16 3
51 #define SCM_UVEC_U32 4
52 #define SCM_UVEC_S32 5
53 #define SCM_UVEC_U64 6
54 #define SCM_UVEC_S64 7
55 #define SCM_UVEC_F32 8
56 #define SCM_UVEC_F64 9
59 /* This array maps type tags to the size of the elements. */
60 static const int uvec_sizes
[10] = {
65 sizeof(float), sizeof(double)
68 static const char *uvec_tags
[10] = {
76 static const char *uvec_names
[10] = {
77 "u8vector", "s8vector",
78 "u16vector", "s16vector",
79 "u32vector", "s32vector",
80 "u64vector", "s64vector",
81 "f32vector", "f64vector"
84 /* ================================================================ */
85 /* SMOB procedures. */
86 /* ================================================================ */
89 /* Smob print hook for homogeneous vectors. */
91 uvec_print (SCM uvec
, SCM port
, scm_print_state
*pstate
)
109 const size_t uvlen
= SCM_UVEC_LENGTH (uvec
);
110 void *uptr
= SCM_UVEC_BASE (uvec
);
112 switch (SCM_UVEC_TYPE (uvec
))
114 case SCM_UVEC_U8
: np
.u8
= (scm_t_uint8
*) uptr
; break;
115 case SCM_UVEC_S8
: np
.s8
= (scm_t_int8
*) uptr
; break;
116 case SCM_UVEC_U16
: np
.u16
= (scm_t_uint16
*) uptr
; break;
117 case SCM_UVEC_S16
: np
.s16
= (scm_t_int16
*) uptr
; break;
118 case SCM_UVEC_U32
: np
.u32
= (scm_t_uint32
*) uptr
; break;
119 case SCM_UVEC_S32
: np
.s32
= (scm_t_int32
*) uptr
; break;
121 case SCM_UVEC_U64
: np
.u64
= (scm_t_uint64
*) uptr
; break;
122 case SCM_UVEC_S64
: np
.s64
= (scm_t_int64
*) uptr
; break;
124 case SCM_UVEC_F32
: np
.f32
= (float *) uptr
; break;
125 case SCM_UVEC_F64
: np
.f64
= (double *) uptr
; break;
127 abort (); /* Sanity check. */
131 scm_putc ('#', port
);
132 scm_puts (uvec_tags
[SCM_UVEC_TYPE (uvec
)], port
);
133 scm_putc ('(', port
);
137 if (i
!= 0) scm_puts (" ", port
);
138 switch (SCM_UVEC_TYPE (uvec
))
140 case SCM_UVEC_U8
: scm_uintprint (*np
.u8
, 10, port
); np
.u8
++; break;
141 case SCM_UVEC_S8
: scm_intprint (*np
.s8
, 10, port
); np
.s8
++; break;
142 case SCM_UVEC_U16
: scm_uintprint (*np
.u16
, 10, port
); np
.u16
++; break;
143 case SCM_UVEC_S16
: scm_intprint (*np
.s16
, 10, port
); np
.s16
++; break;
144 case SCM_UVEC_U32
: scm_uintprint (*np
.u32
, 10, port
); np
.u32
++; break;
145 case SCM_UVEC_S32
: scm_intprint (*np
.s32
, 10, port
); np
.s32
++; break;
147 case SCM_UVEC_U64
: scm_uintprint (*np
.u64
, 10, port
); np
.u64
++; break;
148 case SCM_UVEC_S64
: scm_intprint (*np
.s64
, 10, port
); np
.s64
++; break;
150 case SCM_UVEC_F32
: scm_i_print_double (*np
.f32
, port
); np
.f32
++; break;
151 case SCM_UVEC_F64
: scm_i_print_double (*np
.f64
, port
); np
.f64
++; break;
153 abort (); /* Sanity check. */
158 scm_remember_upto_here_1 (uvec
);
159 scm_puts (")", port
);
164 scm_i_uniform_vector_tag (SCM uvec
)
166 return uvec_tags
[SCM_UVEC_TYPE (uvec
)];
170 uvec_equalp (SCM a
, SCM b
)
172 SCM result
= SCM_BOOL_T
;
173 if (SCM_UVEC_TYPE (a
) != SCM_UVEC_TYPE (b
))
175 else if (SCM_UVEC_LENGTH (a
) != SCM_UVEC_LENGTH (b
))
177 else if (memcmp (SCM_UVEC_BASE (a
), SCM_UVEC_BASE (b
),
178 SCM_UVEC_LENGTH (a
) * uvec_sizes
[SCM_UVEC_TYPE(a
)]) != 0)
181 scm_remember_upto_here_2 (a
, b
);
185 /* Smob free hook for homogeneous numeric vectors. */
189 int type
= SCM_UVEC_TYPE (uvec
);
190 scm_gc_free (SCM_UVEC_BASE (uvec
),
191 SCM_UVEC_LENGTH (uvec
) * uvec_sizes
[type
],
196 /* ================================================================ */
197 /* Utility procedures. */
198 /* ================================================================ */
200 static SCM_C_INLINE
int
201 is_uvec (int type
, SCM obj
)
203 return (SCM_SMOB_PREDICATE (scm_tc16_uvec
, obj
)
204 && SCM_UVEC_TYPE (obj
) == type
);
207 static SCM_C_INLINE SCM
208 uvec_p (int type
, SCM obj
)
210 return scm_from_bool (is_uvec (type
, obj
));
213 static SCM_C_INLINE
void
214 uvec_assert (int type
, SCM obj
)
216 if (!is_uvec (type
, obj
))
217 scm_wrong_type_arg_msg (NULL
, 0, obj
, uvec_names
[type
]);
221 take_uvec (int type
, const void *base
, size_t len
)
223 SCM_RETURN_NEWSMOB3 (scm_tc16_uvec
, type
, len
, (scm_t_bits
) base
);
226 /* Create a new, uninitialized homogeneous numeric vector of type TYPE
227 with space for LEN elements. */
229 alloc_uvec (int type
, size_t len
)
231 void *base
= scm_gc_malloc (len
* uvec_sizes
[type
], uvec_names
[type
]);
232 return take_uvec (type
, base
, len
);
235 /* GCC doesn't seem to want to optimize unused switch clauses away,
236 so we use a big 'if' in the next two functions.
239 static SCM_C_INLINE SCM
240 uvec_fast_ref (int type
, void *base
, size_t c_idx
)
242 if (type
== SCM_UVEC_U8
)
243 return scm_from_uint8 (((scm_t_uint8
*)base
)[c_idx
]);
244 else if (type
== SCM_UVEC_S8
)
245 return scm_from_int8 (((scm_t_int8
*)base
)[c_idx
]);
246 else if (type
== SCM_UVEC_U16
)
247 return scm_from_uint16 (((scm_t_uint16
*)base
)[c_idx
]);
248 else if (type
== SCM_UVEC_S16
)
249 return scm_from_int16 (((scm_t_int16
*)base
)[c_idx
]);
250 else if (type
== SCM_UVEC_U32
)
251 return scm_from_uint32 (((scm_t_uint32
*)base
)[c_idx
]);
252 else if (type
== SCM_UVEC_S32
)
253 return scm_from_int32 (((scm_t_int32
*)base
)[c_idx
]);
255 else if (type
== SCM_UVEC_U64
)
256 return scm_from_uint64 (((scm_t_uint64
*)base
)[c_idx
]);
257 else if (type
== SCM_UVEC_S64
)
258 return scm_from_int64 (((scm_t_int64
*)base
)[c_idx
]);
260 else if (type
== SCM_UVEC_F32
)
261 return scm_from_double (((float*)base
)[c_idx
]);
262 else if (type
== SCM_UVEC_F64
)
263 return scm_from_double (((double*)base
)[c_idx
]);
266 static SCM_C_INLINE
void
267 uvec_fast_set_x (int type
, void *base
, size_t c_idx
, SCM val
)
269 if (type
== SCM_UVEC_U8
)
270 (((scm_t_uint8
*)base
)[c_idx
]) = scm_to_uint8 (val
);
271 else if (type
== SCM_UVEC_S8
)
272 (((scm_t_int8
*)base
)[c_idx
]) = scm_to_int8 (val
);
273 else if (type
== SCM_UVEC_U16
)
274 (((scm_t_uint16
*)base
)[c_idx
]) = scm_to_uint16 (val
);
275 else if (type
== SCM_UVEC_S16
)
276 (((scm_t_int16
*)base
)[c_idx
]) = scm_to_int16 (val
);
277 else if (type
== SCM_UVEC_U32
)
278 (((scm_t_uint32
*)base
)[c_idx
]) = scm_to_uint32 (val
);
279 else if (type
== SCM_UVEC_S32
)
280 (((scm_t_int32
*)base
)[c_idx
]) = scm_to_int32 (val
);
282 else if (type
== SCM_UVEC_U64
)
283 (((scm_t_uint64
*)base
)[c_idx
]) = scm_to_uint64 (val
);
284 else if (type
== SCM_UVEC_S64
)
285 (((scm_t_int64
*)base
)[c_idx
]) = scm_to_int64 (val
);
287 else if (type
== SCM_UVEC_F32
)
288 (((float*)base
)[c_idx
]) = scm_to_double (val
);
289 else if (type
== SCM_UVEC_F64
)
290 (((double*)base
)[c_idx
]) = scm_to_double (val
);
293 static SCM_C_INLINE SCM
294 make_uvec (int type
, SCM len
, SCM fill
)
296 size_t c_len
= scm_to_unsigned_integer (len
, 0, SIZE_MAX
/ uvec_sizes
[type
]);
297 SCM uvec
= alloc_uvec (type
, c_len
);
298 if (!SCM_UNBNDP (fill
))
301 void *base
= SCM_UVEC_BASE (uvec
);
302 for (idx
= 0; idx
< c_len
; idx
++)
303 uvec_fast_set_x (type
, base
, idx
, fill
);
308 static SCM_C_INLINE SCM
309 uvec_length (int type
, SCM uvec
)
311 uvec_assert (type
, uvec
);
312 return scm_from_size_t (SCM_UVEC_LENGTH (uvec
));
315 static SCM_C_INLINE SCM
316 uvec_ref (int type
, SCM uvec
, SCM idx
)
321 uvec_assert (type
, uvec
);
322 c_idx
= scm_to_unsigned_integer (idx
, 0, SCM_UVEC_LENGTH (uvec
)-1);
323 res
= uvec_fast_ref (type
, SCM_UVEC_BASE(uvec
), c_idx
);
324 scm_remember_upto_here_1 (uvec
);
328 static SCM_C_INLINE SCM
329 uvec_set_x (int type
, SCM uvec
, SCM idx
, SCM val
)
333 uvec_assert (type
, uvec
);
334 c_idx
= scm_to_unsigned_integer (idx
, 0, SCM_UVEC_LENGTH (uvec
)-1);
335 uvec_fast_set_x (type
, SCM_UVEC_BASE(uvec
), c_idx
, val
);
336 scm_remember_upto_here_1 (uvec
);
337 return SCM_UNSPECIFIED
;
340 static SCM_C_INLINE SCM
341 uvec_to_list (int type
, SCM uvec
)
347 uvec_assert (type
, uvec
);
348 c_idx
= SCM_UVEC_LENGTH (uvec
);
349 base
= SCM_UVEC_BASE (uvec
);
351 res
= scm_cons (uvec_fast_ref (type
, base
, c_idx
), res
);
352 scm_remember_upto_here_1 (uvec
);
356 static SCM_C_INLINE SCM
357 list_to_uvec (int type
, SCM list
)
362 long len
= scm_ilength (list
);
364 scm_wrong_type_arg_msg (NULL
, 0, list
, "proper list");
366 uvec
= alloc_uvec (type
, len
);
367 base
= SCM_UVEC_BASE (uvec
);
369 while (scm_is_pair (list
) && idx
< len
)
371 uvec_fast_set_x (type
, base
, idx
, SCM_CAR (list
));
372 list
= SCM_CDR (list
);
379 scm_i_read_homogenous_vector (SCM port
, char pfx
)
381 /* We have read '#f', '#u', or '#s'. Next must be a decimal integer
382 followed immediately by a list.
391 while ((c
= scm_getc (port
)) != EOF
&& '0' <= c
&& c
<= '9' && n_digs
< 80)
395 scm_ungetc (c
, port
);
397 if (n_digs
== 0 && pfx
== 'f')
401 scm_i_input_error (NULL
, port
,
402 "#~a~a must be followed immediately by a '('",
403 scm_list_2 (SCM_MAKE_CHAR (pfx
),
404 scm_from_locale_stringn (tok
, n_digs
)));
406 list
= scm_read (port
);
408 if (n_digs
== 1 && strncmp (tok
, "8", n_digs
) == 0)
411 return scm_list_to_u8vector (list
);
413 return scm_list_to_s8vector (list
);
415 else if (n_digs
== 2 && strncmp (tok
, "16", n_digs
) == 0)
418 return scm_list_to_u16vector (list
);
420 return scm_list_to_s16vector (list
);
422 else if (n_digs
== 2 && strncmp (tok
, "32", n_digs
) == 0)
425 return scm_list_to_u32vector (list
);
427 return scm_list_to_s32vector (list
);
429 return scm_list_to_f32vector (list
);
431 else if (n_digs
== 2 && strncmp (tok
, "64", n_digs
) == 0)
434 return scm_list_to_u64vector (list
);
436 return scm_list_to_s64vector (list
);
438 return scm_list_to_f64vector (list
);
441 scm_i_input_error (NULL
, port
,
442 "unrecognized homogenous vector prefix #~a~a",
443 scm_list_2 (SCM_MAKE_CHAR (pfx
),
444 scm_from_locale_stringn (tok
, n_digs
)));
449 scm_i_uniform_vector_prototype (SCM uvec
)
451 switch (SCM_UVEC_TYPE (uvec
))
456 return SCM_MAKE_CHAR ('\0');
479 scm_is_uniform_vector (SCM obj
)
481 return SCM_SMOB_PREDICATE (scm_tc16_uvec
, obj
);
485 scm_c_uniform_vector_length (SCM v
)
487 if (scm_is_uniform_vector (v
))
488 return SCM_UVEC_LENGTH (v
);
490 scm_wrong_type_arg_msg (NULL
, 0, v
, "uniform vector");
494 scm_c_uniform_vector_size (SCM v
)
496 if (scm_is_uniform_vector (v
))
497 return SCM_UVEC_LENGTH (v
) * uvec_sizes
[SCM_UVEC_TYPE (v
)];
499 scm_wrong_type_arg_msg (NULL
, 0, v
, "uniform vector");
502 SCM_DEFINE (scm_uniform_vector_p
, "uniform-vector?", 1, 0, 0,
504 "Return @code{#t} if @var{obj} is a uniform vector.")
505 #define FUNC_NAME s_scm_uniform_vector_p
507 return scm_from_bool (scm_is_uniform_vector (obj
));
511 SCM_DEFINE (scm_uniform_vector_ref
, "uniform-vector-ref", 2, 0, 0,
513 "Return the element at index @var{idx} of the\n"
514 "homogenous numeric vector @var{v}.")
515 #define FUNC_NAME s_scm_uniform_vector_ref
517 /* Support old argument convention.
519 if (scm_is_pair (idx
))
521 if (!scm_is_null (SCM_CDR (idx
)))
522 scm_wrong_num_args (NULL
);
526 if (scm_is_uniform_vector (v
))
527 return uvec_ref (SCM_UVEC_TYPE (v
), v
, idx
);
529 scm_wrong_type_arg_msg (NULL
, 0, v
, "uniform vector");
533 SCM_DEFINE (scm_uniform_vector_set_x
, "uniform-vector-set!", 3, 0, 0,
534 (SCM v
, SCM idx
, SCM val
),
535 "Set the element at index @var{idx} of the\n"
536 "homogenous numeric vector @var{v} to @var{val}.")
537 #define FUNC_NAME s_scm_uniform_vector_set_x
539 /* Support old argument convention.
541 if (scm_is_pair (idx
))
543 if (!scm_is_null (SCM_CDR (idx
)))
544 scm_wrong_num_args (NULL
);
548 if (scm_is_uniform_vector (v
))
549 return uvec_set_x (SCM_UVEC_TYPE (v
), v
, idx
, val
);
551 scm_wrong_type_arg_msg (NULL
, 0, v
, "uniform vector");
555 SCM_DEFINE (scm_uniform_vector_to_list
, "uniform-vector->list", 1, 0, 0,
557 "Convert the homogeneous numeric vector @var{uvec} to a list.")
558 #define FUNC_NAME s_uniform_vector_to_list
560 if (scm_is_uniform_vector (uvec
))
561 return uvec_to_list (SCM_UVEC_TYPE (uvec
), uvec
);
563 scm_wrong_type_arg_msg (NULL
, 0, uvec
, "uniform vector");
568 scm_uniform_vector_elements (SCM uvec
)
570 if (scm_is_uniform_vector (uvec
))
571 return SCM_UVEC_BASE (uvec
);
573 scm_wrong_type_arg_msg (NULL
, 0, uvec
, "uniform vector");
577 scm_uniform_vector_release (SCM uvec
)
579 /* Nothing to do right now, but this function might come in handy
580 when uniform vectors need to be locked when giving away a pointer
583 Also, a call to scm_uniform_vector acts like
584 scm_remember_upto_here, which is needed in any case.
589 scm_uniform_vector_element_size (SCM uvec
)
591 if (scm_is_uniform_vector (uvec
))
592 return uvec_sizes
[SCM_UVEC_TYPE (uvec
)];
594 scm_wrong_type_arg_msg (NULL
, 0, uvec
, "uniform vector");
597 /* return the size of an element in a uniform array or 0 if type not
600 scm_uniform_element_size (SCM obj
)
604 if (scm_is_uniform_vector (obj
))
605 return scm_uniform_vector_element_size (obj
);
607 switch (SCM_TYP7 (obj
))
612 result
= sizeof (long);
616 result
= sizeof (short);
619 #if SCM_SIZEOF_LONG_LONG != 0
621 result
= sizeof (long long);
626 result
= sizeof (float);
630 result
= sizeof (double);
634 result
= 2 * sizeof (double);
643 SCM_DEFINE (scm_uniform_vector_length
, "uniform-vector-length", 1, 0, 0,
645 "Return the number of elements in @var{uve}.")
646 #define FUNC_NAME s_scm_uniform_vector_length
648 if (scm_is_uniform_vector (v
))
649 return scm_from_size_t (SCM_UVEC_LENGTH (v
));
651 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
655 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
658 return scm_from_size_t (SCM_VECTOR_LENGTH (v
));
660 return scm_from_size_t (scm_i_string_length (v
));
662 return scm_from_size_t (SCM_BITVECTOR_LENGTH (v
));
669 #if SCM_SIZEOF_LONG_LONG != 0
672 return scm_from_size_t (SCM_UVECTOR_LENGTH (v
));
677 /* ================================================================ */
678 /* Exported procedures. */
679 /* ================================================================ */
681 #define TYPE SCM_UVEC_U8
683 #define CTYPE scm_t_uint8
684 #include "libguile/srfi-4.i.c"
686 #define TYPE SCM_UVEC_S8
688 #define CTYPE scm_t_int8
689 #include "libguile/srfi-4.i.c"
691 #define TYPE SCM_UVEC_U16
693 #define CTYPE scm_t_uint16
694 #include "libguile/srfi-4.i.c"
696 #define TYPE SCM_UVEC_S16
698 #define CTYPE scm_t_int16
699 #include "libguile/srfi-4.i.c"
701 #define TYPE SCM_UVEC_U32
703 #define CTYPE scm_t_uint32
704 #include "libguile/srfi-4.i.c"
706 #define TYPE SCM_UVEC_S32
708 #define CTYPE scm_t_int32
709 #include "libguile/srfi-4.i.c"
711 #define TYPE SCM_UVEC_U64
713 #define CTYPE scm_t_uint64
714 #include "libguile/srfi-4.i.c"
716 #define TYPE SCM_UVEC_S64
718 #define CTYPE scm_t_int64
719 #include "libguile/srfi-4.i.c"
721 #define TYPE SCM_UVEC_F32
724 #include "libguile/srfi-4.i.c"
726 #define TYPE SCM_UVEC_F64
729 #include "libguile/srfi-4.i.c"
732 /* Create the smob type for homogeneous numeric vectors and install
735 scm_init_srfi_4 (void)
737 scm_tc16_uvec
= scm_make_smob_type ("uvec", 0);
738 scm_set_smob_equalp (scm_tc16_uvec
, uvec_equalp
);
739 scm_set_smob_free (scm_tc16_uvec
, uvec_free
);
740 scm_set_smob_print (scm_tc16_uvec
, uvec_print
);
741 #include "libguile/srfi-4.x"
744 /* End of srfi-4.c. */