1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
25 #include "libguile/_scm.h"
26 #include "libguile/eq.h"
27 #include "libguile/root.h"
28 #include "libguile/strings.h"
30 #include "libguile/validate.h"
31 #include "libguile/vectors.h"
32 #include "libguile/arrays.h" /* Hit me with the ugly stick */
33 #include "libguile/generalized-vectors.h"
34 #include "libguile/strings.h"
35 #include "libguile/srfi-13.h"
36 #include "libguile/dynwind.h"
37 #include "libguile/deprecation.h"
39 #include "libguile/bdw-gc.h"
44 #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
47 scm_is_vector (SCM obj
)
49 if (SCM_I_IS_VECTOR (obj
))
51 if (SCM_I_ARRAYP (obj
) && SCM_I_ARRAY_NDIM (obj
) == 1)
53 SCM v
= SCM_I_ARRAY_V (obj
);
54 return SCM_I_IS_VECTOR (v
);
60 scm_is_simple_vector (SCM obj
)
62 return SCM_I_IS_VECTOR (obj
);
66 scm_vector_elements (SCM vec
, scm_t_array_handle
*h
,
67 size_t *lenp
, ssize_t
*incp
)
69 if (SCM_I_WVECTP (vec
))
70 /* FIXME: We should check each (weak) element of the vector for NULL and
71 convert it to SCM_BOOL_F. */
74 scm_generalized_vector_get_handle (vec
, h
);
77 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
78 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
81 return scm_array_handle_elements (h
);
85 scm_vector_writable_elements (SCM vec
, scm_t_array_handle
*h
,
86 size_t *lenp
, ssize_t
*incp
)
88 if (SCM_I_WVECTP (vec
))
89 /* FIXME: We should check each (weak) element of the vector for NULL and
90 convert it to SCM_BOOL_F. */
93 scm_generalized_vector_get_handle (vec
, h
);
96 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
97 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
100 return scm_array_handle_writable_elements (h
);
103 SCM_DEFINE (scm_vector_p
, "vector?", 1, 0, 0,
105 "Return @code{#t} if @var{obj} is a vector, otherwise return\n"
107 #define FUNC_NAME s_scm_vector_p
109 return scm_from_bool (scm_is_vector (obj
));
113 SCM_GPROC (s_vector_length
, "vector-length", 1, 0, 0, scm_vector_length
, g_vector_length
);
114 /* Returns the number of elements in @var{vector} as an exact integer. */
116 scm_vector_length (SCM v
)
118 if (SCM_I_IS_VECTOR (v
))
119 return scm_from_size_t (SCM_I_VECTOR_LENGTH (v
));
120 else if (SCM_I_ARRAYP (v
) && SCM_I_ARRAY_NDIM (v
) == 1)
122 scm_t_array_dim
*dim
= SCM_I_ARRAY_DIMS (v
);
123 return scm_from_size_t (dim
->ubnd
- dim
->lbnd
+ 1);
126 SCM_WTA_DISPATCH_1 (g_vector_length
, v
, 1, NULL
);
130 scm_c_vector_length (SCM v
)
132 if (SCM_I_IS_VECTOR (v
))
133 return SCM_I_VECTOR_LENGTH (v
);
135 return scm_to_size_t (scm_vector_length (v
));
138 SCM_REGISTER_PROC (s_list_to_vector
, "list->vector", 1, 0, 0, scm_vector
);
140 "Return a newly created vector initialized to the elements of"
141 "the list @var{list}.\n\n"
143 "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
144 "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
147 SCM_DEFINE (scm_vector
, "vector", 0, 0, 1,
149 "@deffnx {Scheme Procedure} list->vector l\n"
150 "Return a newly allocated vector composed of the\n"
151 "given arguments. Analogous to @code{list}.\n"
154 "(vector 'a 'b 'c) @result{} #(a b c)\n"
156 #define FUNC_NAME s_scm_vector
161 scm_t_array_handle handle
;
163 SCM_VALIDATE_LIST_COPYLEN (1, l
, len
);
165 res
= scm_c_make_vector (len
, SCM_UNSPECIFIED
);
166 data
= scm_vector_writable_elements (res
, &handle
, NULL
, NULL
);
168 while (scm_is_pair (l
) && i
< len
)
170 data
[i
] = SCM_CAR (l
);
175 scm_array_handle_release (&handle
);
181 SCM_GPROC (s_vector_ref
, "vector-ref", 2, 0, 0, scm_vector_ref
, g_vector_ref
);
184 "@var{k} must be a valid index of @var{vector}.\n"
185 "@samp{Vector-ref} returns the contents of element @var{k} of\n"
188 "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n"
189 "(vector-ref '#(1 1 2 3 5 8 13 21)\n"
190 " (let ((i (round (* 2 (acos -1)))))\n"
191 " (if (inexact? i)\n"
192 " (inexact->exact i)\n"
193 " i))) @result{} 13\n"
198 scm_vector_ref (SCM v
, SCM k
)
199 #define FUNC_NAME s_vector_ref
201 return scm_c_vector_ref (v
, scm_to_size_t (k
));
206 scm_c_vector_ref (SCM v
, size_t k
)
208 if (SCM_I_IS_VECTOR (v
))
212 if (k
>= SCM_I_VECTOR_LENGTH (v
))
213 scm_out_of_range (NULL
, scm_from_size_t (k
));
214 elt
= (SCM_I_VECTOR_ELTS(v
))[k
];
216 if ((elt
== SCM_PACK (NULL
)) && SCM_I_WVECTP (v
))
217 /* ELT was a weak pointer and got nullified by the GC. */
222 else if (SCM_I_ARRAYP (v
) && SCM_I_ARRAY_NDIM (v
) == 1)
224 scm_t_array_dim
*dim
= SCM_I_ARRAY_DIMS (v
);
225 SCM vv
= SCM_I_ARRAY_V (v
);
226 if (SCM_I_IS_VECTOR (vv
))
230 if (k
>= dim
->ubnd
- dim
->lbnd
+ 1)
231 scm_out_of_range (NULL
, scm_from_size_t (k
));
232 k
= SCM_I_ARRAY_BASE (v
) + k
*dim
->inc
;
233 elt
= (SCM_I_VECTOR_ELTS (vv
))[k
];
235 if ((elt
== SCM_PACK (NULL
)) && (SCM_I_WVECTP (vv
)))
236 /* ELT was a weak pointer and got nullified by the GC. */
241 scm_wrong_type_arg_msg (NULL
, 0, v
, "non-uniform vector");
244 SCM_WTA_DISPATCH_2 (g_vector_ref
, v
, scm_from_size_t (k
), 2, NULL
);
247 SCM_GPROC (s_vector_set_x
, "vector-set!", 3, 0, 0, scm_vector_set_x
, g_vector_set_x
);
249 /* "@var{k} must be a valid index of @var{vector}.\n"
250 "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
251 "The value returned by @samp{vector-set!} is unspecified.\n"
253 "(let ((vec (vector 0 '(2 2 2 2) "Anna")))\n"
254 " (vector-set! vec 1 '("Sue" "Sue"))\n"
255 " vec) @result{} #(0 ("Sue" "Sue") "Anna")\n"
256 "(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector\n"
261 scm_vector_set_x (SCM v
, SCM k
, SCM obj
)
262 #define FUNC_NAME s_vector_set_x
264 scm_c_vector_set_x (v
, scm_to_size_t (k
), obj
);
265 return SCM_UNSPECIFIED
;
270 scm_c_vector_set_x (SCM v
, size_t k
, SCM obj
)
272 if (SCM_I_IS_VECTOR (v
))
274 if (k
>= SCM_I_VECTOR_LENGTH (v
))
275 scm_out_of_range (NULL
, scm_from_size_t (k
));
276 (SCM_I_VECTOR_WELTS(v
))[k
] = obj
;
277 if (SCM_I_WVECTP (v
))
279 /* Make it a weak pointer. */
280 GC_PTR link
= (GC_PTR
) & ((SCM_I_VECTOR_WELTS (v
))[k
]);
281 SCM_I_REGISTER_DISAPPEARING_LINK (link
, obj
);
284 else if (SCM_I_ARRAYP (v
) && SCM_I_ARRAY_NDIM (v
) == 1)
286 scm_t_array_dim
*dim
= SCM_I_ARRAY_DIMS (v
);
287 SCM vv
= SCM_I_ARRAY_V (v
);
288 if (SCM_I_IS_VECTOR (vv
))
290 if (k
>= dim
->ubnd
- dim
->lbnd
+ 1)
291 scm_out_of_range (NULL
, scm_from_size_t (k
));
292 k
= SCM_I_ARRAY_BASE (v
) + k
*dim
->inc
;
293 (SCM_I_VECTOR_WELTS (vv
))[k
] = obj
;
295 if (SCM_I_WVECTP (vv
))
297 /* Make it a weak pointer. */
298 GC_PTR link
= (GC_PTR
) & ((SCM_I_VECTOR_WELTS (vv
))[k
]);
299 SCM_I_REGISTER_DISAPPEARING_LINK (link
, obj
);
303 scm_wrong_type_arg_msg (NULL
, 0, v
, "non-uniform vector");
307 if (SCM_UNPACK (g_vector_set_x
))
308 scm_apply_generic (g_vector_set_x
,
309 scm_list_3 (v
, scm_from_size_t (k
), obj
));
311 scm_wrong_type_arg_msg (NULL
, 0, v
, "vector");
315 SCM_DEFINE (scm_make_vector
, "make-vector", 1, 1, 0,
317 "Return a newly allocated vector of @var{k} elements. If a\n"
318 "second argument is given, then each position is initialized to\n"
319 "@var{fill}. Otherwise the initial contents of each position is\n"
321 #define FUNC_NAME s_scm_make_vector
323 size_t l
= scm_to_unsigned_integer (k
, 0, VECTOR_MAX_LENGTH
);
325 if (SCM_UNBNDP (fill
))
326 fill
= SCM_UNSPECIFIED
;
328 return scm_c_make_vector (l
, fill
);
334 scm_c_make_vector (size_t k
, SCM fill
)
335 #define FUNC_NAME s_scm_make_vector
340 scm_gc_malloc ((k
+ SCM_I_VECTOR_HEADER_SIZE
) * sizeof (SCM
),
348 SCM_ASSERT_RANGE (1, scm_from_ulong (k
), k
<= VECTOR_MAX_LENGTH
);
350 base
= vector
+ SCM_I_VECTOR_HEADER_SIZE
;
351 for (j
= 0; j
!= k
; ++j
)
355 ((scm_t_bits
*) vector
)[0] = (k
<< 8) | scm_tc7_vector
;
356 ((scm_t_bits
*) vector
)[1] = 0;
358 return PTR2SCM (vector
);
362 SCM_DEFINE (scm_vector_copy
, "vector-copy", 1, 0, 0,
364 "Return a copy of @var{vec}.")
365 #define FUNC_NAME s_scm_vector_copy
367 scm_t_array_handle handle
;
373 src
= scm_vector_elements (vec
, &handle
, &len
, &inc
);
375 result
= scm_c_make_vector (len
, SCM_UNDEFINED
);
376 dst
= SCM_I_VECTOR_WELTS (result
);
377 for (i
= 0; i
< len
; i
++, src
+= inc
)
380 scm_array_handle_release (&handle
);
389 /* Allocate memory for the elements of a weak vector on behalf of the
392 make_weak_vector (scm_t_bits type
, size_t c_size
)
397 total_size
= (c_size
+ SCM_I_VECTOR_HEADER_SIZE
) * sizeof (SCM
);
398 vector
= (SCM
*) scm_gc_malloc_pointerless (total_size
, "weak vector");
400 ((scm_t_bits
*) vector
)[0] = (c_size
<< 8) | scm_tc7_wvect
;
401 ((scm_t_bits
*) vector
)[1] = type
;
403 return PTR2SCM (vector
);
406 /* Return a new weak vector. The allocated vector will be of the given weak
407 vector subtype. It will contain SIZE elements which are initialized with
408 the FILL object, or, if FILL is undefined, with an unspecified object. */
410 scm_i_make_weak_vector (scm_t_bits type
, SCM size
, SCM fill
)
415 if (SCM_UNBNDP (fill
))
416 fill
= SCM_UNSPECIFIED
;
418 c_size
= scm_to_unsigned_integer (size
, 0, VECTOR_MAX_LENGTH
);
419 wv
= make_weak_vector (type
, c_size
);
420 base
= SCM_I_WVECT_GC_WVELTS (wv
);
422 for (j
= 0; j
!= c_size
; ++j
)
428 /* Return a new weak vector with type TYPE and whose content are taken from
431 scm_i_make_weak_vector_from_list (scm_t_bits type
, SCM lst
)
436 c_size
= scm_ilength (lst
);
437 SCM_ASSERT (c_size
>= 0, lst
, SCM_ARG2
, "scm_i_make_weak_vector_from_list");
439 wv
= make_weak_vector(type
, (size_t) c_size
);
441 for (elt
= SCM_I_WVECT_GC_WVELTS (wv
);
443 lst
= SCM_CDR (lst
), elt
++)
445 *elt
= SCM_CAR (lst
);
453 SCM_DEFINE (scm_vector_to_list
, "vector->list", 1, 0, 0,
455 "Return a newly allocated list composed of the elements of @var{v}.\n"
458 "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
459 "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
461 #define FUNC_NAME s_scm_vector_to_list
465 scm_t_array_handle handle
;
466 size_t i
, count
, len
;
469 data
= scm_vector_elements (v
, &handle
, &len
, &inc
);
470 for (i
= (len
- 1) * inc
, count
= 0;
473 res
= scm_cons (data
[i
], res
);
475 scm_array_handle_release (&handle
);
481 SCM_DEFINE (scm_vector_fill_x
, "vector-fill!", 2, 0, 0,
483 "Store @var{fill} in every position of @var{vector}. The value\n"
484 "returned by @code{vector-fill!} is unspecified.")
485 #define FUNC_NAME s_scm_vector_fill_x
487 scm_t_array_handle handle
;
492 data
= scm_vector_writable_elements (v
, &handle
, &len
, &inc
);
493 for (i
= 0; i
< len
; i
+= inc
)
495 scm_array_handle_release (&handle
);
496 return SCM_UNSPECIFIED
;
502 scm_i_vector_equal_p (SCM x
, SCM y
)
505 for (i
= SCM_I_VECTOR_LENGTH (x
) - 1; i
>= 0; i
--)
506 if (scm_is_false (scm_equal_p (SCM_I_VECTOR_ELTS (x
)[i
],
507 SCM_I_VECTOR_ELTS (y
)[i
])))
513 SCM_DEFINE (scm_vector_move_left_x
, "vector-move-left!", 5, 0, 0,
514 (SCM vec1
, SCM start1
, SCM end1
, SCM vec2
, SCM start2
),
515 "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
516 "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
517 "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
518 "@code{vector-move-left!} copies elements in leftmost order.\n"
519 "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
520 "same vector, @code{vector-move-left!} is usually appropriate when\n"
521 "@var{start1} is greater than @var{start2}.")
522 #define FUNC_NAME s_scm_vector_move_left_x
524 scm_t_array_handle handle1
, handle2
;
531 elts1
= scm_vector_elements (vec1
, &handle1
, &len1
, &inc1
);
532 elts2
= scm_vector_writable_elements (vec2
, &handle2
, &len2
, &inc2
);
534 i
= scm_to_unsigned_integer (start1
, 0, len1
);
535 e
= scm_to_unsigned_integer (end1
, i
, len1
);
536 j
= scm_to_unsigned_integer (start2
, 0, len2
- (i
-e
));
541 for (; i
< e
; i
+= inc1
, j
+= inc2
)
544 scm_array_handle_release (&handle2
);
545 scm_array_handle_release (&handle1
);
547 return SCM_UNSPECIFIED
;
551 SCM_DEFINE (scm_vector_move_right_x
, "vector-move-right!", 5, 0, 0,
552 (SCM vec1
, SCM start1
, SCM end1
, SCM vec2
, SCM start2
),
553 "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
554 "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
555 "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
556 "@code{vector-move-right!} copies elements in rightmost order.\n"
557 "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
558 "same vector, @code{vector-move-right!} is usually appropriate when\n"
559 "@var{start1} is less than @var{start2}.")
560 #define FUNC_NAME s_scm_vector_move_right_x
562 scm_t_array_handle handle1
, handle2
;
569 elts1
= scm_vector_elements (vec1
, &handle1
, &len1
, &inc1
);
570 elts2
= scm_vector_writable_elements (vec2
, &handle2
, &len2
, &inc2
);
572 i
= scm_to_unsigned_integer (start1
, 0, len1
);
573 e
= scm_to_unsigned_integer (end1
, i
, len1
);
574 j
= scm_to_unsigned_integer (start2
, 0, len2
- (i
-e
));
586 scm_array_handle_release (&handle2
);
587 scm_array_handle_release (&handle1
);
589 return SCM_UNSPECIFIED
;
595 vector_handle_ref (scm_t_array_handle
*h
, size_t idx
)
597 if (idx
> h
->dims
[0].ubnd
)
598 scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx
));
599 return ((SCM
*)h
->elements
)[idx
];
603 vector_handle_set (scm_t_array_handle
*h
, size_t idx
, SCM val
)
605 if (idx
> h
->dims
[0].ubnd
)
606 scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx
));
607 ((SCM
*)h
->writable_elements
)[idx
] = val
;
611 vector_get_handle (SCM v
, scm_t_array_handle
*h
)
617 h
->dim0
.ubnd
= SCM_I_VECTOR_LENGTH (v
) - 1;
619 h
->element_type
= SCM_ARRAY_ELEMENT_TYPE_SCM
;
620 h
->elements
= h
->writable_elements
= SCM_I_VECTOR_WELTS (v
);
623 /* the & ~2 allows catching scm_tc7_wvect as well. needs changing if you change
625 SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector
, 0x7f & ~2,
626 vector_handle_ref
, vector_handle_set
,
628 SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM
, scm_make_vector
)
634 #include "libguile/vectors.x"