1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006 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
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but 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 02110-1301 USA
21 #include "libguile/_scm.h"
22 #include "libguile/eq.h"
23 #include "libguile/root.h"
24 #include "libguile/strings.h"
25 #include "libguile/lang.h"
27 #include "libguile/validate.h"
28 #include "libguile/vectors.h"
29 #include "libguile/unif.h"
30 #include "libguile/ramap.h"
31 #include "libguile/srfi-4.h"
32 #include "libguile/strings.h"
33 #include "libguile/srfi-13.h"
34 #include "libguile/dynwind.h"
35 #include "libguile/deprecation.h"
37 #include "libguile/boehm-gc.h"
42 #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
45 scm_is_vector (SCM obj
)
47 if (SCM_I_IS_VECTOR (obj
))
49 if (SCM_I_ARRAYP (obj
) && SCM_I_ARRAY_NDIM (obj
) == 1)
51 SCM v
= SCM_I_ARRAY_V (obj
);
52 return SCM_I_IS_VECTOR (v
);
58 scm_is_simple_vector (SCM obj
)
60 return SCM_I_IS_VECTOR (obj
);
64 scm_vector_elements (SCM vec
, scm_t_array_handle
*h
,
65 size_t *lenp
, ssize_t
*incp
)
67 if (SCM_I_WVECTP (vec
))
68 /* FIXME: We should check each (weak) element of the vector for NULL and
69 convert it to SCM_BOOL_F. */
72 scm_generalized_vector_get_handle (vec
, h
);
75 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
76 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
79 return scm_array_handle_elements (h
);
83 scm_vector_writable_elements (SCM vec
, scm_t_array_handle
*h
,
84 size_t *lenp
, ssize_t
*incp
)
86 if (SCM_I_WVECTP (vec
))
87 /* FIXME: We should check each (weak) element of the vector for NULL and
88 convert it to SCM_BOOL_F. */
91 scm_generalized_vector_get_handle (vec
, h
);
94 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
95 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
98 return scm_array_handle_writable_elements (h
);
101 SCM_DEFINE (scm_vector_p
, "vector?", 1, 0, 0,
103 "Return @code{#t} if @var{obj} is a vector, otherwise return\n"
105 #define FUNC_NAME s_scm_vector_p
107 return scm_from_bool (scm_is_vector (obj
));
111 SCM_GPROC (s_vector_length
, "vector-length", 1, 0, 0, scm_vector_length
, g_vector_length
);
112 /* Returns the number of elements in @var{vector} as an exact integer. */
114 scm_vector_length (SCM v
)
116 if (SCM_I_IS_VECTOR (v
))
117 return scm_from_size_t (SCM_I_VECTOR_LENGTH (v
));
118 else if (SCM_I_ARRAYP (v
) && SCM_I_ARRAY_NDIM (v
) == 1)
120 scm_t_array_dim
*dim
= SCM_I_ARRAY_DIMS (v
);
121 return scm_from_size_t (dim
->ubnd
- dim
->lbnd
+ 1);
124 SCM_WTA_DISPATCH_1 (g_vector_length
, v
, 1, NULL
);
128 scm_c_vector_length (SCM v
)
130 if (SCM_I_IS_VECTOR (v
))
131 return SCM_I_VECTOR_LENGTH (v
);
133 return scm_to_size_t (scm_vector_length (v
));
136 SCM_REGISTER_PROC (s_list_to_vector
, "list->vector", 1, 0, 0, scm_vector
);
138 "Return a newly created vector initialized to the elements of"
139 "the list @var{list}.\n\n"
141 "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
142 "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
145 SCM_DEFINE (scm_vector
, "vector", 0, 0, 1,
147 "@deffnx {Scheme Procedure} list->vector l\n"
148 "Return a newly allocated vector composed of the\n"
149 "given arguments. Analogous to @code{list}.\n"
152 "(vector 'a 'b 'c) @result{} #(a b c)\n"
154 #define FUNC_NAME s_scm_vector
159 scm_t_array_handle handle
;
161 SCM_VALIDATE_LIST_COPYLEN (1, l
, len
);
163 res
= scm_c_make_vector (len
, SCM_UNSPECIFIED
);
164 data
= scm_vector_writable_elements (res
, &handle
, NULL
, NULL
);
166 while (scm_is_pair (l
) && i
< len
)
168 data
[i
] = SCM_CAR (l
);
173 scm_array_handle_release (&handle
);
179 SCM_GPROC (s_vector_ref
, "vector-ref", 2, 0, 0, scm_vector_ref
, g_vector_ref
);
182 "@var{k} must be a valid index of @var{vector}.\n"
183 "@samp{Vector-ref} returns the contents of element @var{k} of\n"
186 "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n"
187 "(vector-ref '#(1 1 2 3 5 8 13 21)\n"
188 " (let ((i (round (* 2 (acos -1)))))\n"
189 " (if (inexact? i)\n"
190 " (inexact->exact i)\n"
191 " i))) @result{} 13\n"
196 scm_vector_ref (SCM v
, SCM k
)
197 #define FUNC_NAME s_vector_ref
199 return scm_c_vector_ref (v
, scm_to_size_t (k
));
204 scm_c_vector_ref (SCM v
, size_t k
)
206 if (SCM_I_IS_VECTOR (v
))
210 if (k
>= SCM_I_VECTOR_LENGTH (v
))
211 scm_out_of_range (NULL
, scm_from_size_t (k
));
212 elt
= (SCM_I_VECTOR_ELTS(v
))[k
];
214 if ((elt
== SCM_PACK (NULL
)) && SCM_I_WVECTP (v
))
215 /* ELT was a weak pointer and got nullified by the GC. */
220 else if (SCM_I_ARRAYP (v
) && SCM_I_ARRAY_NDIM (v
) == 1)
222 scm_t_array_dim
*dim
= SCM_I_ARRAY_DIMS (v
);
223 SCM vv
= SCM_I_ARRAY_V (v
);
224 if (SCM_I_IS_VECTOR (vv
))
228 if (k
>= dim
->ubnd
- dim
->lbnd
+ 1)
229 scm_out_of_range (NULL
, scm_from_size_t (k
));
230 k
= SCM_I_ARRAY_BASE (v
) + k
*dim
->inc
;
231 elt
= (SCM_I_VECTOR_ELTS (vv
))[k
];
233 if ((elt
== SCM_PACK (NULL
)) && (SCM_I_WVECTP (vv
)))
234 /* ELT was a weak pointer and got nullified by the GC. */
239 scm_wrong_type_arg_msg (NULL
, 0, v
, "non-uniform vector");
242 SCM_WTA_DISPATCH_2 (g_vector_ref
, v
, scm_from_size_t (k
), 2, NULL
);
245 SCM_GPROC (s_vector_set_x
, "vector-set!", 3, 0, 0, scm_vector_set_x
, g_vector_set_x
);
247 /* "@var{k} must be a valid index of @var{vector}.\n"
248 "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
249 "The value returned by @samp{vector-set!} is unspecified.\n"
251 "(let ((vec (vector 0 '(2 2 2 2) "Anna")))\n"
252 " (vector-set! vec 1 '("Sue" "Sue"))\n"
253 " vec) @result{} #(0 ("Sue" "Sue") "Anna")\n"
254 "(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector\n"
259 scm_vector_set_x (SCM v
, SCM k
, SCM obj
)
260 #define FUNC_NAME s_vector_set_x
262 scm_c_vector_set_x (v
, scm_to_size_t (k
), obj
);
263 return SCM_UNSPECIFIED
;
268 scm_c_vector_set_x (SCM v
, size_t k
, SCM obj
)
270 if (SCM_I_IS_VECTOR (v
))
272 if (k
>= SCM_I_VECTOR_LENGTH (v
))
273 scm_out_of_range (NULL
, scm_from_size_t (k
));
274 (SCM_I_VECTOR_WELTS(v
))[k
] = obj
;
275 if (SCM_I_WVECTP (v
))
277 /* Make it a weak pointer. */
278 GC_PTR link
= (GC_PTR
) & ((SCM_I_VECTOR_WELTS (v
))[k
]);
279 GC_GENERAL_REGISTER_DISAPPEARING_LINK (link
, obj
);
282 else if (SCM_I_ARRAYP (v
) && SCM_I_ARRAY_NDIM (v
) == 1)
284 scm_t_array_dim
*dim
= SCM_I_ARRAY_DIMS (v
);
285 SCM vv
= SCM_I_ARRAY_V (v
);
286 if (SCM_I_IS_VECTOR (vv
))
288 if (k
>= dim
->ubnd
- dim
->lbnd
+ 1)
289 scm_out_of_range (NULL
, scm_from_size_t (k
));
290 k
= SCM_I_ARRAY_BASE (v
) + k
*dim
->inc
;
291 (SCM_I_VECTOR_WELTS (vv
))[k
] = obj
;
293 if (SCM_I_WVECTP (vv
))
295 /* Make it a weak pointer. */
296 GC_PTR link
= (GC_PTR
) & ((SCM_I_VECTOR_WELTS (vv
))[k
]);
297 GC_GENERAL_REGISTER_DISAPPEARING_LINK (link
, obj
);
301 scm_wrong_type_arg_msg (NULL
, 0, v
, "non-uniform vector");
305 if (SCM_UNPACK (g_vector_set_x
))
306 scm_apply_generic (g_vector_set_x
,
307 scm_list_3 (v
, scm_from_size_t (k
), obj
));
309 scm_wrong_type_arg_msg (NULL
, 0, v
, "vector");
313 SCM_DEFINE (scm_make_vector
, "make-vector", 1, 1, 0,
315 "Return a newly allocated vector of @var{k} elements. If a\n"
316 "second argument is given, then each position is initialized to\n"
317 "@var{fill}. Otherwise the initial contents of each position is\n"
319 #define FUNC_NAME s_scm_make_vector
321 size_t l
= scm_to_unsigned_integer (k
, 0, VECTOR_MAX_LENGTH
);
323 if (SCM_UNBNDP (fill
))
324 fill
= SCM_UNSPECIFIED
;
326 return scm_c_make_vector (l
, fill
);
332 scm_c_make_vector (size_t k
, SCM fill
)
333 #define FUNC_NAME s_scm_make_vector
342 SCM_ASSERT_RANGE (1, scm_from_ulong (k
), k
<= VECTOR_MAX_LENGTH
);
344 base
= scm_gc_malloc (k
* sizeof (SCM
), "vector");
345 for (j
= 0; j
!= k
; ++j
)
351 v
= scm_cell ((k
<< 8) | scm_tc7_vector
, (scm_t_bits
) base
);
352 scm_remember_upto_here_1 (fill
);
358 SCM_DEFINE (scm_vector_copy
, "vector-copy", 1, 0, 0,
360 "Return a copy of @var{vec}.")
361 #define FUNC_NAME s_scm_vector_copy
363 scm_t_array_handle handle
;
369 src
= scm_vector_elements (vec
, &handle
, &len
, &inc
);
370 dst
= scm_gc_malloc (len
* sizeof (SCM
), "vector");
371 for (i
= 0; i
< len
; i
++, src
+= inc
)
373 scm_array_handle_release (&handle
);
375 return scm_cell ((len
<< 8) | scm_tc7_vector
, (scm_t_bits
) dst
);
380 scm_i_vector_free (SCM vec
)
382 scm_gc_free (SCM_I_VECTOR_WELTS (vec
),
383 SCM_I_VECTOR_LENGTH (vec
) * sizeof(SCM
),
391 /* Initialize RET as a weak vector of type TYPE of SIZE elements pointed to
393 #define MAKE_WEAK_VECTOR(_ret, _type, _size, _base) \
394 (_ret) = scm_double_cell ((_size << 8) | scm_tc7_wvect, \
395 (scm_t_bits) (_base), \
397 SCM_UNPACK (SCM_EOL));
400 /* Allocate memory for the elements of a weak vector on behalf of the
403 allocate_weak_vector (scm_t_bits type
, size_t c_size
)
408 /* The base itself should not be scanned for pointers otherwise those
409 pointers will always be reachable. */
410 base
= scm_gc_malloc_pointerless (c_size
* sizeof (SCM
), "weak vector");
417 /* Return a new weak vector. The allocated vector will be of the given weak
418 vector subtype. It will contain SIZE elements which are initialized with
419 the FILL object, or, if FILL is undefined, with an unspecified object. */
421 scm_i_make_weak_vector (scm_t_bits type
, SCM size
, SCM fill
)
426 if (SCM_UNBNDP (fill
))
427 fill
= SCM_UNSPECIFIED
;
429 c_size
= scm_to_unsigned_integer (size
, 0, VECTOR_MAX_LENGTH
);
430 base
= allocate_weak_vector (type
, c_size
);
432 for (j
= 0; j
!= c_size
; ++j
)
435 MAKE_WEAK_VECTOR (wv
, type
, c_size
, base
);
440 /* Return a new weak vector with type TYPE and whose content are taken from
443 scm_i_make_weak_vector_from_list (scm_t_bits type
, SCM lst
)
448 c_size
= scm_ilength (lst
);
449 SCM_ASSERT (c_size
>= 0, lst
, SCM_ARG2
, "scm_i_make_weak_vector_from_list");
451 base
= allocate_weak_vector (type
, (size_t)c_size
);
454 lst
= SCM_CDR (lst
), elt
++)
456 *elt
= SCM_CAR (lst
);
459 MAKE_WEAK_VECTOR (wv
, type
, (size_t)c_size
, base
);
466 SCM_DEFINE (scm_vector_to_list
, "vector->list", 1, 0, 0,
468 "Return a newly allocated list composed of the elements of @var{v}.\n"
471 "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
472 "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
474 #define FUNC_NAME s_scm_vector_to_list
478 scm_t_array_handle handle
;
479 size_t i
, count
, len
;
482 data
= scm_vector_elements (v
, &handle
, &len
, &inc
);
483 for (i
= (len
- 1) * inc
, count
= 0;
486 res
= scm_cons (data
[i
], res
);
488 scm_array_handle_release (&handle
);
494 SCM_DEFINE (scm_vector_fill_x
, "vector-fill!", 2, 0, 0,
496 "Store @var{fill} in every position of @var{vector}. The value\n"
497 "returned by @code{vector-fill!} is unspecified.")
498 #define FUNC_NAME s_scm_vector_fill_x
500 scm_t_array_handle handle
;
505 data
= scm_vector_writable_elements (v
, &handle
, &len
, &inc
);
506 for (i
= 0; i
< len
; i
+= inc
)
508 scm_array_handle_release (&handle
);
509 return SCM_UNSPECIFIED
;
515 scm_i_vector_equal_p (SCM x
, SCM y
)
518 for (i
= SCM_I_VECTOR_LENGTH (x
) - 1; i
>= 0; i
--)
519 if (scm_is_false (scm_equal_p (SCM_I_VECTOR_ELTS (x
)[i
],
520 SCM_I_VECTOR_ELTS (y
)[i
])))
526 SCM_DEFINE (scm_vector_move_left_x
, "vector-move-left!", 5, 0, 0,
527 (SCM vec1
, SCM start1
, SCM end1
, SCM vec2
, SCM start2
),
528 "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
529 "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
530 "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
531 "@code{vector-move-left!} copies elements in leftmost order.\n"
532 "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
533 "same vector, @code{vector-move-left!} is usually appropriate when\n"
534 "@var{start1} is greater than @var{start2}.")
535 #define FUNC_NAME s_scm_vector_move_left_x
537 scm_t_array_handle handle1
, handle2
;
544 elts1
= scm_vector_elements (vec1
, &handle1
, &len1
, &inc1
);
545 elts2
= scm_vector_writable_elements (vec2
, &handle2
, &len2
, &inc2
);
547 i
= scm_to_unsigned_integer (start1
, 0, len1
);
548 e
= scm_to_unsigned_integer (end1
, i
, len1
);
549 j
= scm_to_unsigned_integer (start2
, 0, len2
- (i
-e
));
554 for (; i
< e
; i
+= inc1
, j
+= inc2
)
557 scm_array_handle_release (&handle2
);
558 scm_array_handle_release (&handle1
);
560 return SCM_UNSPECIFIED
;
564 SCM_DEFINE (scm_vector_move_right_x
, "vector-move-right!", 5, 0, 0,
565 (SCM vec1
, SCM start1
, SCM end1
, SCM vec2
, SCM start2
),
566 "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
567 "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
568 "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
569 "@code{vector-move-right!} copies elements in rightmost order.\n"
570 "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
571 "same vector, @code{vector-move-right!} is usually appropriate when\n"
572 "@var{start1} is less than @var{start2}.")
573 #define FUNC_NAME s_scm_vector_move_right_x
575 scm_t_array_handle handle1
, handle2
;
582 elts1
= scm_vector_elements (vec1
, &handle1
, &len1
, &inc1
);
583 elts2
= scm_vector_writable_elements (vec2
, &handle2
, &len2
, &inc2
);
585 i
= scm_to_unsigned_integer (start1
, 0, len1
);
586 e
= scm_to_unsigned_integer (end1
, i
, len1
);
587 j
= scm_to_unsigned_integer (start2
, 0, len2
- (i
-e
));
599 scm_array_handle_release (&handle2
);
600 scm_array_handle_release (&handle1
);
602 return SCM_UNSPECIFIED
;
607 /* Generalized vectors. */
610 scm_is_generalized_vector (SCM obj
)
612 return (scm_is_vector (obj
)
613 || scm_is_string (obj
)
614 || scm_is_bitvector (obj
)
615 || scm_is_uniform_vector (obj
));
618 SCM_DEFINE (scm_generalized_vector_p
, "generalized-vector?", 1, 0, 0,
620 "Return @code{#t} if @var{obj} is a vector, string,\n"
621 "bitvector, or uniform numeric vector.")
622 #define FUNC_NAME s_scm_generalized_vector_p
624 return scm_from_bool (scm_is_generalized_vector (obj
));
629 scm_generalized_vector_get_handle (SCM vec
, scm_t_array_handle
*h
)
631 scm_array_get_handle (vec
, h
);
632 if (scm_array_handle_rank (h
) != 1)
633 scm_wrong_type_arg_msg (NULL
, 0, vec
, "vector");
637 scm_c_generalized_vector_length (SCM v
)
639 if (scm_is_vector (v
))
640 return scm_c_vector_length (v
);
641 else if (scm_is_string (v
))
642 return scm_c_string_length (v
);
643 else if (scm_is_bitvector (v
))
644 return scm_c_bitvector_length (v
);
645 else if (scm_is_uniform_vector (v
))
646 return scm_c_uniform_vector_length (v
);
648 scm_wrong_type_arg_msg (NULL
, 0, v
, "generalized vector");
651 SCM_DEFINE (scm_generalized_vector_length
, "generalized-vector-length", 1, 0, 0,
653 "Return the length of the generalized vector @var{v}.")
654 #define FUNC_NAME s_scm_generalized_vector_length
656 return scm_from_size_t (scm_c_generalized_vector_length (v
));
661 scm_c_generalized_vector_ref (SCM v
, size_t idx
)
663 if (scm_is_vector (v
))
664 return scm_c_vector_ref (v
, idx
);
665 else if (scm_is_string (v
))
666 return scm_c_string_ref (v
, idx
);
667 else if (scm_is_bitvector (v
))
668 return scm_c_bitvector_ref (v
, idx
);
669 else if (scm_is_uniform_vector (v
))
670 return scm_c_uniform_vector_ref (v
, idx
);
672 scm_wrong_type_arg_msg (NULL
, 0, v
, "generalized vector");
675 SCM_DEFINE (scm_generalized_vector_ref
, "generalized-vector-ref", 2, 0, 0,
677 "Return the element at index @var{idx} of the\n"
678 "generalized vector @var{v}.")
679 #define FUNC_NAME s_scm_generalized_vector_ref
681 return scm_c_generalized_vector_ref (v
, scm_to_size_t (idx
));
686 scm_c_generalized_vector_set_x (SCM v
, size_t idx
, SCM val
)
688 if (scm_is_vector (v
))
689 scm_c_vector_set_x (v
, idx
, val
);
690 else if (scm_is_string (v
))
691 scm_c_string_set_x (v
, idx
, val
);
692 else if (scm_is_bitvector (v
))
693 scm_c_bitvector_set_x (v
, idx
, val
);
694 else if (scm_is_uniform_vector (v
))
695 scm_c_uniform_vector_set_x (v
, idx
, val
);
697 scm_wrong_type_arg_msg (NULL
, 0, v
, "generalized vector");
700 SCM_DEFINE (scm_generalized_vector_set_x
, "generalized-vector-set!", 3, 0, 0,
701 (SCM v
, SCM idx
, SCM val
),
702 "Set the element at index @var{idx} of the\n"
703 "generalized vector @var{v} to @var{val}.")
704 #define FUNC_NAME s_scm_generalized_vector_set_x
706 scm_c_generalized_vector_set_x (v
, scm_to_size_t (idx
), val
);
707 return SCM_UNSPECIFIED
;
711 SCM_DEFINE (scm_generalized_vector_to_list
, "generalized-vector->list", 1, 0, 0,
713 "Return a new list whose elements are the elements of the\n"
714 "generalized vector @var{v}.")
715 #define FUNC_NAME s_scm_generalized_vector_to_list
717 if (scm_is_vector (v
))
718 return scm_vector_to_list (v
);
719 else if (scm_is_string (v
))
720 return scm_string_to_list (v
);
721 else if (scm_is_bitvector (v
))
722 return scm_bitvector_to_list (v
);
723 else if (scm_is_uniform_vector (v
))
724 return scm_uniform_vector_to_list (v
);
726 scm_wrong_type_arg_msg (NULL
, 0, v
, "generalized vector");
734 scm_nullvect
= scm_c_make_vector (0, SCM_UNDEFINED
);
736 #include "libguile/vectors.x"