1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009, 2010,
2 * 2011, 2012 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 #include "libguile/_scm.h"
27 #include "libguile/eq.h"
28 #include "libguile/root.h"
29 #include "libguile/strings.h"
31 #include "libguile/validate.h"
32 #include "libguile/vectors.h"
33 #include "libguile/arrays.h" /* Hit me with the ugly stick */
34 #include "libguile/generalized-vectors.h"
35 #include "libguile/strings.h"
36 #include "libguile/srfi-13.h"
37 #include "libguile/dynwind.h"
38 #include "libguile/deprecation.h"
40 #include "libguile/bdw-gc.h"
45 #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
48 scm_is_vector (SCM obj
)
50 if (SCM_I_IS_VECTOR (obj
))
52 if (SCM_I_ARRAYP (obj
) && SCM_I_ARRAY_NDIM (obj
) == 1)
54 SCM v
= SCM_I_ARRAY_V (obj
);
55 return SCM_I_IS_VECTOR (v
);
61 scm_is_simple_vector (SCM obj
)
63 return SCM_I_IS_VECTOR (obj
);
67 scm_vector_elements (SCM vec
, scm_t_array_handle
*h
,
68 size_t *lenp
, ssize_t
*incp
)
70 if (SCM_I_WVECTP (vec
))
71 scm_wrong_type_arg_msg (NULL
, 0, vec
, "non-weak vector");
73 scm_generalized_vector_get_handle (vec
, h
);
76 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
77 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
80 return scm_array_handle_elements (h
);
84 scm_vector_writable_elements (SCM vec
, scm_t_array_handle
*h
,
85 size_t *lenp
, ssize_t
*incp
)
87 if (SCM_I_WVECTP (vec
))
88 scm_wrong_type_arg_msg (NULL
, 0, vec
, "non-weak vector");
90 scm_generalized_vector_get_handle (vec
, h
);
93 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
94 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
97 return scm_array_handle_writable_elements (h
);
100 SCM_DEFINE (scm_vector_p
, "vector?", 1, 0, 0,
102 "Return @code{#t} if @var{obj} is a vector, otherwise return\n"
104 #define FUNC_NAME s_scm_vector_p
106 return scm_from_bool (scm_is_vector (obj
));
110 SCM_GPROC (s_vector_length
, "vector-length", 1, 0, 0, scm_vector_length
, g_vector_length
);
111 /* Returns the number of elements in @var{vector} as an exact integer. */
113 scm_vector_length (SCM v
)
115 if (SCM_I_IS_VECTOR (v
))
116 return scm_from_size_t (SCM_I_VECTOR_LENGTH (v
));
117 else if (SCM_I_ARRAYP (v
) && SCM_I_ARRAY_NDIM (v
) == 1)
119 scm_t_array_dim
*dim
= SCM_I_ARRAY_DIMS (v
);
120 return scm_from_size_t (dim
->ubnd
- dim
->lbnd
+ 1);
123 return scm_wta_dispatch_1 (g_vector_length
, v
, 1, "vector-length");
127 scm_c_vector_length (SCM v
)
129 if (SCM_I_IS_VECTOR (v
))
130 return SCM_I_VECTOR_LENGTH (v
);
132 return scm_to_size_t (scm_vector_length (v
));
135 SCM_REGISTER_PROC (s_list_to_vector
, "list->vector", 1, 0, 0, scm_vector
);
137 "Return a newly created vector initialized to the elements of"
138 "the list @var{list}.\n\n"
140 "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
141 "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
144 SCM_DEFINE (scm_vector
, "vector", 0, 0, 1,
146 "@deffnx {Scheme Procedure} list->vector l\n"
147 "Return a newly allocated vector composed of the\n"
148 "given arguments. Analogous to @code{list}.\n"
151 "(vector 'a 'b 'c) @result{} #(a b c)\n"
153 #define FUNC_NAME s_scm_vector
158 scm_t_array_handle handle
;
160 SCM_VALIDATE_LIST_COPYLEN (1, l
, len
);
162 res
= scm_c_make_vector (len
, SCM_UNSPECIFIED
);
163 data
= scm_vector_writable_elements (res
, &handle
, NULL
, NULL
);
165 while (scm_is_pair (l
) && i
< len
)
167 data
[i
] = SCM_CAR (l
);
172 scm_array_handle_release (&handle
);
178 SCM_GPROC (s_vector_ref
, "vector-ref", 2, 0, 0, scm_vector_ref
, g_vector_ref
);
181 "@var{k} must be a valid index of @var{vector}.\n"
182 "@samp{Vector-ref} returns the contents of element @var{k} of\n"
185 "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n"
186 "(vector-ref '#(1 1 2 3 5 8 13 21)\n"
187 " (let ((i (round (* 2 (acos -1)))))\n"
188 " (if (inexact? i)\n"
189 " (inexact->exact i)\n"
190 " i))) @result{} 13\n"
195 scm_vector_ref (SCM v
, SCM k
)
196 #define FUNC_NAME s_vector_ref
198 return scm_c_vector_ref (v
, scm_to_size_t (k
));
203 scm_c_vector_ref (SCM v
, size_t k
)
205 if (SCM_I_IS_NONWEAK_VECTOR (v
))
207 if (k
>= SCM_I_VECTOR_LENGTH (v
))
208 scm_out_of_range (NULL
, scm_from_size_t (k
));
209 return SCM_SIMPLE_VECTOR_REF (v
, k
);
211 else if (SCM_I_WVECTP (v
))
212 return scm_c_weak_vector_ref (v
, k
);
213 else if (SCM_I_ARRAYP (v
) && SCM_I_ARRAY_NDIM (v
) == 1)
215 scm_t_array_dim
*dim
= SCM_I_ARRAY_DIMS (v
);
216 SCM vv
= SCM_I_ARRAY_V (v
);
218 k
= SCM_I_ARRAY_BASE (v
) + k
*dim
->inc
;
219 if (k
>= dim
->ubnd
- dim
->lbnd
+ 1)
220 scm_out_of_range (NULL
, scm_from_size_t (k
));
222 if (SCM_I_IS_NONWEAK_VECTOR (vv
))
223 return SCM_SIMPLE_VECTOR_REF (vv
, k
);
224 else if (SCM_I_WVECTP (vv
))
225 return scm_c_weak_vector_ref (vv
, k
);
227 scm_wrong_type_arg_msg (NULL
, 0, v
, "non-uniform vector");
230 return scm_wta_dispatch_2 (g_vector_ref
, v
, scm_from_size_t (k
), 2,
234 SCM_GPROC (s_vector_set_x
, "vector-set!", 3, 0, 0, scm_vector_set_x
, g_vector_set_x
);
236 /* "@var{k} must be a valid index of @var{vector}.\n"
237 "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
238 "The value returned by @samp{vector-set!} is unspecified.\n"
240 "(let ((vec (vector 0 '(2 2 2 2) "Anna")))\n"
241 " (vector-set! vec 1 '("Sue" "Sue"))\n"
242 " vec) @result{} #(0 ("Sue" "Sue") "Anna")\n"
243 "(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector\n"
248 scm_vector_set_x (SCM v
, SCM k
, SCM obj
)
249 #define FUNC_NAME s_vector_set_x
251 scm_c_vector_set_x (v
, scm_to_size_t (k
), obj
);
252 return SCM_UNSPECIFIED
;
257 scm_c_vector_set_x (SCM v
, size_t k
, SCM obj
)
259 if (SCM_I_IS_NONWEAK_VECTOR (v
))
261 if (k
>= SCM_I_VECTOR_LENGTH (v
))
262 scm_out_of_range (NULL
, scm_from_size_t (k
));
263 SCM_SIMPLE_VECTOR_SET (v
, k
, obj
);
265 else if (SCM_I_WVECTP (v
))
266 scm_c_weak_vector_set_x (v
, k
, obj
);
267 else if (SCM_I_ARRAYP (v
) && SCM_I_ARRAY_NDIM (v
) == 1)
269 scm_t_array_dim
*dim
= SCM_I_ARRAY_DIMS (v
);
270 SCM vv
= SCM_I_ARRAY_V (v
);
272 k
= SCM_I_ARRAY_BASE (v
) + k
*dim
->inc
;
273 if (k
>= dim
->ubnd
- dim
->lbnd
+ 1)
274 scm_out_of_range (NULL
, scm_from_size_t (k
));
276 if (SCM_I_IS_NONWEAK_VECTOR (vv
))
277 SCM_SIMPLE_VECTOR_SET (vv
, k
, obj
);
278 else if (SCM_I_WVECTP (vv
))
279 scm_c_weak_vector_set_x (vv
, k
, obj
);
281 scm_wrong_type_arg_msg (NULL
, 0, v
, "non-uniform vector");
285 if (SCM_UNPACK (g_vector_set_x
))
286 scm_wta_dispatch_n (g_vector_set_x
,
287 scm_list_3 (v
, scm_from_size_t (k
), obj
),
291 scm_wrong_type_arg_msg (NULL
, 0, v
, "vector");
295 SCM_DEFINE (scm_make_vector
, "make-vector", 1, 1, 0,
297 "Return a newly allocated vector of @var{k} elements. If a\n"
298 "second argument is given, then each position is initialized to\n"
299 "@var{fill}. Otherwise the initial contents of each position is\n"
301 #define FUNC_NAME s_scm_make_vector
303 size_t l
= scm_to_unsigned_integer (k
, 0, VECTOR_MAX_LENGTH
);
305 if (SCM_UNBNDP (fill
))
306 fill
= SCM_UNSPECIFIED
;
308 return scm_c_make_vector (l
, fill
);
314 scm_c_make_vector (size_t k
, SCM fill
)
315 #define FUNC_NAME s_scm_make_vector
320 SCM_ASSERT_RANGE (1, scm_from_size_t (k
), k
<= VECTOR_MAX_LENGTH
);
322 vector
= scm_words ((k
<< 8) | scm_tc7_vector
, k
+ 1);
324 for (j
= 0; j
< k
; ++j
)
325 SCM_SIMPLE_VECTOR_SET (vector
, j
, fill
);
331 SCM_DEFINE (scm_vector_copy
, "vector-copy", 1, 0, 0,
333 "Return a copy of @var{vec}.")
334 #define FUNC_NAME s_scm_vector_copy
336 scm_t_array_handle handle
;
342 src
= scm_vector_elements (vec
, &handle
, &len
, &inc
);
344 result
= scm_c_make_vector (len
, SCM_UNDEFINED
);
345 dst
= SCM_I_VECTOR_WELTS (result
);
346 for (i
= 0; i
< len
; i
++, src
+= inc
)
349 scm_array_handle_release (&handle
);
356 SCM_DEFINE (scm_vector_to_list
, "vector->list", 1, 0, 0,
358 "Return a newly allocated list composed of the elements of @var{v}.\n"
361 "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
362 "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
364 #define FUNC_NAME s_scm_vector_to_list
368 scm_t_array_handle handle
;
369 size_t i
, count
, len
;
372 data
= scm_vector_elements (v
, &handle
, &len
, &inc
);
373 for (i
= (len
- 1) * inc
, count
= 0;
376 res
= scm_cons (data
[i
], res
);
378 scm_array_handle_release (&handle
);
384 SCM_DEFINE (scm_vector_fill_x
, "vector-fill!", 2, 0, 0,
386 "Store @var{fill} in every position of @var{vector}. The value\n"
387 "returned by @code{vector-fill!} is unspecified.")
388 #define FUNC_NAME s_scm_vector_fill_x
390 scm_t_array_handle handle
;
395 data
= scm_vector_writable_elements (v
, &handle
, &len
, &inc
);
396 for (i
= 0; i
< len
; i
+= inc
)
398 scm_array_handle_release (&handle
);
399 return SCM_UNSPECIFIED
;
405 scm_i_vector_equal_p (SCM x
, SCM y
)
408 for (i
= SCM_I_VECTOR_LENGTH (x
) - 1; i
>= 0; i
--)
409 if (scm_is_false (scm_equal_p (SCM_I_VECTOR_ELTS (x
)[i
],
410 SCM_I_VECTOR_ELTS (y
)[i
])))
416 SCM_DEFINE (scm_vector_move_left_x
, "vector-move-left!", 5, 0, 0,
417 (SCM vec1
, SCM start1
, SCM end1
, SCM vec2
, SCM start2
),
418 "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
419 "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
420 "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
421 "@code{vector-move-left!} copies elements in leftmost order.\n"
422 "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
423 "same vector, @code{vector-move-left!} is usually appropriate when\n"
424 "@var{start1} is greater than @var{start2}.")
425 #define FUNC_NAME s_scm_vector_move_left_x
427 scm_t_array_handle handle1
, handle2
;
434 elts1
= scm_vector_elements (vec1
, &handle1
, &len1
, &inc1
);
435 elts2
= scm_vector_writable_elements (vec2
, &handle2
, &len2
, &inc2
);
437 i
= scm_to_unsigned_integer (start1
, 0, len1
);
438 e
= scm_to_unsigned_integer (end1
, i
, len1
);
439 SCM_ASSERT_RANGE (SCM_ARG3
, end1
, (e
-i
) <= len2
);
440 j
= scm_to_unsigned_integer (start2
, 0, len2
);
441 SCM_ASSERT_RANGE (SCM_ARG5
, start2
, j
<= len2
- (e
- i
));
446 for (; i
< e
; i
+= inc1
, j
+= inc2
)
449 scm_array_handle_release (&handle2
);
450 scm_array_handle_release (&handle1
);
452 return SCM_UNSPECIFIED
;
456 SCM_DEFINE (scm_vector_move_right_x
, "vector-move-right!", 5, 0, 0,
457 (SCM vec1
, SCM start1
, SCM end1
, SCM vec2
, SCM start2
),
458 "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
459 "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
460 "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
461 "@code{vector-move-right!} copies elements in rightmost order.\n"
462 "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
463 "same vector, @code{vector-move-right!} is usually appropriate when\n"
464 "@var{start1} is less than @var{start2}.")
465 #define FUNC_NAME s_scm_vector_move_right_x
467 scm_t_array_handle handle1
, handle2
;
474 elts1
= scm_vector_elements (vec1
, &handle1
, &len1
, &inc1
);
475 elts2
= scm_vector_writable_elements (vec2
, &handle2
, &len2
, &inc2
);
477 i
= scm_to_unsigned_integer (start1
, 0, len1
);
478 e
= scm_to_unsigned_integer (end1
, i
, len1
);
479 SCM_ASSERT_RANGE (SCM_ARG3
, end1
, (e
-i
) <= len2
);
480 j
= scm_to_unsigned_integer (start2
, 0, len2
);
481 SCM_ASSERT_RANGE (SCM_ARG5
, start2
, j
<= len2
- (e
- i
));
495 scm_array_handle_release (&handle2
);
496 scm_array_handle_release (&handle1
);
498 return SCM_UNSPECIFIED
;
504 vector_handle_ref (scm_t_array_handle
*h
, size_t idx
)
506 if (idx
> h
->dims
[0].ubnd
)
507 scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx
));
508 return ((SCM
*)h
->elements
)[idx
];
512 vector_handle_set (scm_t_array_handle
*h
, size_t idx
, SCM val
)
514 if (idx
> h
->dims
[0].ubnd
)
515 scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx
));
516 ((SCM
*)h
->writable_elements
)[idx
] = val
;
520 vector_get_handle (SCM v
, scm_t_array_handle
*h
)
526 h
->dim0
.ubnd
= SCM_I_VECTOR_LENGTH (v
) - 1;
528 h
->element_type
= SCM_ARRAY_ELEMENT_TYPE_SCM
;
529 h
->elements
= h
->writable_elements
= SCM_I_VECTOR_WELTS (v
);
532 /* the & ~2 allows catching scm_tc7_wvect as well. needs changing if you change
534 SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector
, 0x7f & ~2,
535 vector_handle_ref
, vector_handle_set
,
537 SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM
, scm_make_vector
)
543 #include "libguile/vectors.x"