1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008 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
24 #include "libguile/_scm.h"
25 #include "libguile/eq.h"
26 #include "libguile/root.h"
27 #include "libguile/strings.h"
28 #include "libguile/lang.h"
30 #include "libguile/validate.h"
31 #include "libguile/vectors.h"
32 #include "libguile/unif.h"
33 #include "libguile/ramap.h"
34 #include "libguile/srfi-4.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/boehm-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 /* FIXME: We should check each (weak) element of the vector for NULL and
72 convert it to SCM_BOOL_F. */
75 scm_generalized_vector_get_handle (vec
, h
);
78 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
79 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
82 return scm_array_handle_elements (h
);
86 scm_vector_writable_elements (SCM vec
, scm_t_array_handle
*h
,
87 size_t *lenp
, ssize_t
*incp
)
89 if (SCM_I_WVECTP (vec
))
90 /* FIXME: We should check each (weak) element of the vector for NULL and
91 convert it to SCM_BOOL_F. */
94 scm_generalized_vector_get_handle (vec
, h
);
97 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
98 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
101 return scm_array_handle_writable_elements (h
);
104 SCM_DEFINE (scm_vector_p
, "vector?", 1, 0, 0,
106 "Return @code{#t} if @var{obj} is a vector, otherwise return\n"
108 #define FUNC_NAME s_scm_vector_p
110 return scm_from_bool (scm_is_vector (obj
));
114 SCM_GPROC (s_vector_length
, "vector-length", 1, 0, 0, scm_vector_length
, g_vector_length
);
115 /* Returns the number of elements in @var{vector} as an exact integer. */
117 scm_vector_length (SCM v
)
119 if (SCM_I_IS_VECTOR (v
))
120 return scm_from_size_t (SCM_I_VECTOR_LENGTH (v
));
121 else if (SCM_I_ARRAYP (v
) && SCM_I_ARRAY_NDIM (v
) == 1)
123 scm_t_array_dim
*dim
= SCM_I_ARRAY_DIMS (v
);
124 return scm_from_size_t (dim
->ubnd
- dim
->lbnd
+ 1);
127 SCM_WTA_DISPATCH_1 (g_vector_length
, v
, 1, NULL
);
131 scm_c_vector_length (SCM v
)
133 if (SCM_I_IS_VECTOR (v
))
134 return SCM_I_VECTOR_LENGTH (v
);
136 return scm_to_size_t (scm_vector_length (v
));
139 SCM_REGISTER_PROC (s_list_to_vector
, "list->vector", 1, 0, 0, scm_vector
);
141 "Return a newly created vector initialized to the elements of"
142 "the list @var{list}.\n\n"
144 "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
145 "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
148 SCM_DEFINE (scm_vector
, "vector", 0, 0, 1,
150 "@deffnx {Scheme Procedure} list->vector l\n"
151 "Return a newly allocated vector composed of the\n"
152 "given arguments. Analogous to @code{list}.\n"
155 "(vector 'a 'b 'c) @result{} #(a b c)\n"
157 #define FUNC_NAME s_scm_vector
162 scm_t_array_handle handle
;
164 SCM_VALIDATE_LIST_COPYLEN (1, l
, len
);
166 res
= scm_c_make_vector (len
, SCM_UNSPECIFIED
);
167 data
= scm_vector_writable_elements (res
, &handle
, NULL
, NULL
);
169 while (scm_is_pair (l
) && i
< len
)
171 data
[i
] = SCM_CAR (l
);
176 scm_array_handle_release (&handle
);
182 SCM_GPROC (s_vector_ref
, "vector-ref", 2, 0, 0, scm_vector_ref
, g_vector_ref
);
185 "@var{k} must be a valid index of @var{vector}.\n"
186 "@samp{Vector-ref} returns the contents of element @var{k} of\n"
189 "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n"
190 "(vector-ref '#(1 1 2 3 5 8 13 21)\n"
191 " (let ((i (round (* 2 (acos -1)))))\n"
192 " (if (inexact? i)\n"
193 " (inexact->exact i)\n"
194 " i))) @result{} 13\n"
199 scm_vector_ref (SCM v
, SCM k
)
200 #define FUNC_NAME s_vector_ref
202 return scm_c_vector_ref (v
, scm_to_size_t (k
));
207 scm_c_vector_ref (SCM v
, size_t k
)
209 if (SCM_I_IS_VECTOR (v
))
213 if (k
>= SCM_I_VECTOR_LENGTH (v
))
214 scm_out_of_range (NULL
, scm_from_size_t (k
));
215 elt
= (SCM_I_VECTOR_ELTS(v
))[k
];
217 if ((elt
== SCM_PACK (NULL
)) && SCM_I_WVECTP (v
))
218 /* ELT was a weak pointer and got nullified by the GC. */
223 else if (SCM_I_ARRAYP (v
) && SCM_I_ARRAY_NDIM (v
) == 1)
225 scm_t_array_dim
*dim
= SCM_I_ARRAY_DIMS (v
);
226 SCM vv
= SCM_I_ARRAY_V (v
);
227 if (SCM_I_IS_VECTOR (vv
))
231 if (k
>= dim
->ubnd
- dim
->lbnd
+ 1)
232 scm_out_of_range (NULL
, scm_from_size_t (k
));
233 k
= SCM_I_ARRAY_BASE (v
) + k
*dim
->inc
;
234 elt
= (SCM_I_VECTOR_ELTS (vv
))[k
];
236 if ((elt
== SCM_PACK (NULL
)) && (SCM_I_WVECTP (vv
)))
237 /* ELT was a weak pointer and got nullified by the GC. */
242 scm_wrong_type_arg_msg (NULL
, 0, v
, "non-uniform vector");
245 SCM_WTA_DISPATCH_2 (g_vector_ref
, v
, scm_from_size_t (k
), 2, NULL
);
248 SCM_GPROC (s_vector_set_x
, "vector-set!", 3, 0, 0, scm_vector_set_x
, g_vector_set_x
);
250 /* "@var{k} must be a valid index of @var{vector}.\n"
251 "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
252 "The value returned by @samp{vector-set!} is unspecified.\n"
254 "(let ((vec (vector 0 '(2 2 2 2) "Anna")))\n"
255 " (vector-set! vec 1 '("Sue" "Sue"))\n"
256 " vec) @result{} #(0 ("Sue" "Sue") "Anna")\n"
257 "(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector\n"
262 scm_vector_set_x (SCM v
, SCM k
, SCM obj
)
263 #define FUNC_NAME s_vector_set_x
265 scm_c_vector_set_x (v
, scm_to_size_t (k
), obj
);
266 return SCM_UNSPECIFIED
;
271 scm_c_vector_set_x (SCM v
, size_t k
, SCM obj
)
273 if (SCM_I_IS_VECTOR (v
))
275 if (k
>= SCM_I_VECTOR_LENGTH (v
))
276 scm_out_of_range (NULL
, scm_from_size_t (k
));
277 (SCM_I_VECTOR_WELTS(v
))[k
] = obj
;
278 if (SCM_I_WVECTP (v
))
280 /* Make it a weak pointer. */
281 GC_PTR link
= (GC_PTR
) & ((SCM_I_VECTOR_WELTS (v
))[k
]);
282 GC_GENERAL_REGISTER_DISAPPEARING_LINK (link
, obj
);
285 else if (SCM_I_ARRAYP (v
) && SCM_I_ARRAY_NDIM (v
) == 1)
287 scm_t_array_dim
*dim
= SCM_I_ARRAY_DIMS (v
);
288 SCM vv
= SCM_I_ARRAY_V (v
);
289 if (SCM_I_IS_VECTOR (vv
))
291 if (k
>= dim
->ubnd
- dim
->lbnd
+ 1)
292 scm_out_of_range (NULL
, scm_from_size_t (k
));
293 k
= SCM_I_ARRAY_BASE (v
) + k
*dim
->inc
;
294 (SCM_I_VECTOR_WELTS (vv
))[k
] = obj
;
296 if (SCM_I_WVECTP (vv
))
298 /* Make it a weak pointer. */
299 GC_PTR link
= (GC_PTR
) & ((SCM_I_VECTOR_WELTS (vv
))[k
]);
300 GC_GENERAL_REGISTER_DISAPPEARING_LINK (link
, obj
);
304 scm_wrong_type_arg_msg (NULL
, 0, v
, "non-uniform vector");
308 if (SCM_UNPACK (g_vector_set_x
))
309 scm_apply_generic (g_vector_set_x
,
310 scm_list_3 (v
, scm_from_size_t (k
), obj
));
312 scm_wrong_type_arg_msg (NULL
, 0, v
, "vector");
316 SCM_DEFINE (scm_make_vector
, "make-vector", 1, 1, 0,
318 "Return a newly allocated vector of @var{k} elements. If a\n"
319 "second argument is given, then each position is initialized to\n"
320 "@var{fill}. Otherwise the initial contents of each position is\n"
322 #define FUNC_NAME s_scm_make_vector
324 size_t l
= scm_to_unsigned_integer (k
, 0, VECTOR_MAX_LENGTH
);
326 if (SCM_UNBNDP (fill
))
327 fill
= SCM_UNSPECIFIED
;
329 return scm_c_make_vector (l
, fill
);
335 scm_c_make_vector (size_t k
, SCM fill
)
336 #define FUNC_NAME s_scm_make_vector
345 SCM_ASSERT_RANGE (1, scm_from_ulong (k
), k
<= VECTOR_MAX_LENGTH
);
347 base
= scm_gc_malloc (k
* sizeof (SCM
), "vector");
348 for (j
= 0; j
!= k
; ++j
)
354 v
= scm_cell ((k
<< 8) | scm_tc7_vector
, (scm_t_bits
) base
);
355 scm_remember_upto_here_1 (fill
);
361 SCM_DEFINE (scm_vector_copy
, "vector-copy", 1, 0, 0,
363 "Return a copy of @var{vec}.")
364 #define FUNC_NAME s_scm_vector_copy
366 scm_t_array_handle handle
;
372 src
= scm_vector_elements (vec
, &handle
, &len
, &inc
);
373 dst
= scm_gc_malloc (len
* sizeof (SCM
), "vector");
374 for (i
= 0; i
< len
; i
++, src
+= inc
)
376 scm_array_handle_release (&handle
);
378 return scm_cell ((len
<< 8) | scm_tc7_vector
, (scm_t_bits
) dst
);
383 scm_i_vector_free (SCM vec
)
385 scm_gc_free (SCM_I_VECTOR_WELTS (vec
),
386 SCM_I_VECTOR_LENGTH (vec
) * sizeof(SCM
),
394 /* Initialize RET as a weak vector of type TYPE of SIZE elements pointed to
396 #define MAKE_WEAK_VECTOR(_ret, _type, _size, _base) \
397 (_ret) = scm_double_cell ((_size << 8) | scm_tc7_wvect, \
398 (scm_t_bits) (_base), \
400 SCM_UNPACK (SCM_EOL));
403 /* Allocate memory for the elements of a weak vector on behalf of the
406 allocate_weak_vector (scm_t_bits type
, size_t c_size
)
411 /* The base itself should not be scanned for pointers otherwise those
412 pointers will always be reachable. */
413 base
= scm_gc_malloc_pointerless (c_size
* sizeof (SCM
), "weak vector");
420 /* Return a new weak vector. The allocated vector will be of the given weak
421 vector subtype. It will contain SIZE elements which are initialized with
422 the FILL object, or, if FILL is undefined, with an unspecified object. */
424 scm_i_make_weak_vector (scm_t_bits type
, SCM size
, SCM fill
)
429 if (SCM_UNBNDP (fill
))
430 fill
= SCM_UNSPECIFIED
;
432 c_size
= scm_to_unsigned_integer (size
, 0, VECTOR_MAX_LENGTH
);
433 base
= allocate_weak_vector (type
, c_size
);
435 for (j
= 0; j
!= c_size
; ++j
)
438 MAKE_WEAK_VECTOR (wv
, type
, c_size
, base
);
443 /* Return a new weak vector with type TYPE and whose content are taken from
446 scm_i_make_weak_vector_from_list (scm_t_bits type
, SCM lst
)
451 c_size
= scm_ilength (lst
);
452 SCM_ASSERT (c_size
>= 0, lst
, SCM_ARG2
, "scm_i_make_weak_vector_from_list");
454 base
= allocate_weak_vector (type
, (size_t)c_size
);
457 lst
= SCM_CDR (lst
), elt
++)
459 *elt
= SCM_CAR (lst
);
462 MAKE_WEAK_VECTOR (wv
, type
, (size_t)c_size
, base
);
469 SCM_DEFINE (scm_vector_to_list
, "vector->list", 1, 0, 0,
471 "Return a newly allocated list composed of the elements of @var{v}.\n"
474 "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
475 "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
477 #define FUNC_NAME s_scm_vector_to_list
481 scm_t_array_handle handle
;
482 size_t i
, count
, len
;
485 data
= scm_vector_elements (v
, &handle
, &len
, &inc
);
486 for (i
= (len
- 1) * inc
, count
= 0;
489 res
= scm_cons (data
[i
], res
);
491 scm_array_handle_release (&handle
);
497 SCM_DEFINE (scm_vector_fill_x
, "vector-fill!", 2, 0, 0,
499 "Store @var{fill} in every position of @var{vector}. The value\n"
500 "returned by @code{vector-fill!} is unspecified.")
501 #define FUNC_NAME s_scm_vector_fill_x
503 scm_t_array_handle handle
;
508 data
= scm_vector_writable_elements (v
, &handle
, &len
, &inc
);
509 for (i
= 0; i
< len
; i
+= inc
)
511 scm_array_handle_release (&handle
);
512 return SCM_UNSPECIFIED
;
518 scm_i_vector_equal_p (SCM x
, SCM y
)
521 for (i
= SCM_I_VECTOR_LENGTH (x
) - 1; i
>= 0; i
--)
522 if (scm_is_false (scm_equal_p (SCM_I_VECTOR_ELTS (x
)[i
],
523 SCM_I_VECTOR_ELTS (y
)[i
])))
529 SCM_DEFINE (scm_vector_move_left_x
, "vector-move-left!", 5, 0, 0,
530 (SCM vec1
, SCM start1
, SCM end1
, SCM vec2
, SCM start2
),
531 "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
532 "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
533 "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
534 "@code{vector-move-left!} copies elements in leftmost order.\n"
535 "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
536 "same vector, @code{vector-move-left!} is usually appropriate when\n"
537 "@var{start1} is greater than @var{start2}.")
538 #define FUNC_NAME s_scm_vector_move_left_x
540 scm_t_array_handle handle1
, handle2
;
547 elts1
= scm_vector_elements (vec1
, &handle1
, &len1
, &inc1
);
548 elts2
= scm_vector_writable_elements (vec2
, &handle2
, &len2
, &inc2
);
550 i
= scm_to_unsigned_integer (start1
, 0, len1
);
551 e
= scm_to_unsigned_integer (end1
, i
, len1
);
552 j
= scm_to_unsigned_integer (start2
, 0, len2
- (i
-e
));
557 for (; i
< e
; i
+= inc1
, j
+= inc2
)
560 scm_array_handle_release (&handle2
);
561 scm_array_handle_release (&handle1
);
563 return SCM_UNSPECIFIED
;
567 SCM_DEFINE (scm_vector_move_right_x
, "vector-move-right!", 5, 0, 0,
568 (SCM vec1
, SCM start1
, SCM end1
, SCM vec2
, SCM start2
),
569 "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
570 "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
571 "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
572 "@code{vector-move-right!} copies elements in rightmost order.\n"
573 "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
574 "same vector, @code{vector-move-right!} is usually appropriate when\n"
575 "@var{start1} is less than @var{start2}.")
576 #define FUNC_NAME s_scm_vector_move_right_x
578 scm_t_array_handle handle1
, handle2
;
585 elts1
= scm_vector_elements (vec1
, &handle1
, &len1
, &inc1
);
586 elts2
= scm_vector_writable_elements (vec2
, &handle2
, &len2
, &inc2
);
588 i
= scm_to_unsigned_integer (start1
, 0, len1
);
589 e
= scm_to_unsigned_integer (end1
, i
, len1
);
590 j
= scm_to_unsigned_integer (start2
, 0, len2
- (i
-e
));
602 scm_array_handle_release (&handle2
);
603 scm_array_handle_release (&handle1
);
605 return SCM_UNSPECIFIED
;
610 /* Generalized vectors. */
613 scm_is_generalized_vector (SCM obj
)
615 return (scm_is_vector (obj
)
616 || scm_is_string (obj
)
617 || scm_is_bitvector (obj
)
618 || scm_is_uniform_vector (obj
));
621 SCM_DEFINE (scm_generalized_vector_p
, "generalized-vector?", 1, 0, 0,
623 "Return @code{#t} if @var{obj} is a vector, string,\n"
624 "bitvector, or uniform numeric vector.")
625 #define FUNC_NAME s_scm_generalized_vector_p
627 return scm_from_bool (scm_is_generalized_vector (obj
));
632 scm_generalized_vector_get_handle (SCM vec
, scm_t_array_handle
*h
)
634 scm_array_get_handle (vec
, h
);
635 if (scm_array_handle_rank (h
) != 1)
636 scm_wrong_type_arg_msg (NULL
, 0, vec
, "vector");
640 scm_c_generalized_vector_length (SCM v
)
642 if (scm_is_vector (v
))
643 return scm_c_vector_length (v
);
644 else if (scm_is_string (v
))
645 return scm_c_string_length (v
);
646 else if (scm_is_bitvector (v
))
647 return scm_c_bitvector_length (v
);
648 else if (scm_is_uniform_vector (v
))
649 return scm_c_uniform_vector_length (v
);
651 scm_wrong_type_arg_msg (NULL
, 0, v
, "generalized vector");
654 SCM_DEFINE (scm_generalized_vector_length
, "generalized-vector-length", 1, 0, 0,
656 "Return the length of the generalized vector @var{v}.")
657 #define FUNC_NAME s_scm_generalized_vector_length
659 return scm_from_size_t (scm_c_generalized_vector_length (v
));
664 scm_c_generalized_vector_ref (SCM v
, size_t idx
)
666 if (scm_is_vector (v
))
667 return scm_c_vector_ref (v
, idx
);
668 else if (scm_is_string (v
))
669 return scm_c_string_ref (v
, idx
);
670 else if (scm_is_bitvector (v
))
671 return scm_c_bitvector_ref (v
, idx
);
672 else if (scm_is_uniform_vector (v
))
673 return scm_c_uniform_vector_ref (v
, idx
);
675 scm_wrong_type_arg_msg (NULL
, 0, v
, "generalized vector");
678 SCM_DEFINE (scm_generalized_vector_ref
, "generalized-vector-ref", 2, 0, 0,
680 "Return the element at index @var{idx} of the\n"
681 "generalized vector @var{v}.")
682 #define FUNC_NAME s_scm_generalized_vector_ref
684 return scm_c_generalized_vector_ref (v
, scm_to_size_t (idx
));
689 scm_c_generalized_vector_set_x (SCM v
, size_t idx
, SCM val
)
691 if (scm_is_vector (v
))
692 scm_c_vector_set_x (v
, idx
, val
);
693 else if (scm_is_string (v
))
694 scm_c_string_set_x (v
, idx
, val
);
695 else if (scm_is_bitvector (v
))
696 scm_c_bitvector_set_x (v
, idx
, val
);
697 else if (scm_is_uniform_vector (v
))
698 scm_c_uniform_vector_set_x (v
, idx
, val
);
700 scm_wrong_type_arg_msg (NULL
, 0, v
, "generalized vector");
703 SCM_DEFINE (scm_generalized_vector_set_x
, "generalized-vector-set!", 3, 0, 0,
704 (SCM v
, SCM idx
, SCM val
),
705 "Set the element at index @var{idx} of the\n"
706 "generalized vector @var{v} to @var{val}.")
707 #define FUNC_NAME s_scm_generalized_vector_set_x
709 scm_c_generalized_vector_set_x (v
, scm_to_size_t (idx
), val
);
710 return SCM_UNSPECIFIED
;
714 SCM_DEFINE (scm_generalized_vector_to_list
, "generalized-vector->list", 1, 0, 0,
716 "Return a new list whose elements are the elements of the\n"
717 "generalized vector @var{v}.")
718 #define FUNC_NAME s_scm_generalized_vector_to_list
720 if (scm_is_vector (v
))
721 return scm_vector_to_list (v
);
722 else if (scm_is_string (v
))
723 return scm_string_to_list (v
);
724 else if (scm_is_bitvector (v
))
725 return scm_bitvector_to_list (v
);
726 else if (scm_is_uniform_vector (v
))
727 return scm_uniform_vector_to_list (v
);
729 scm_wrong_type_arg_msg (NULL
, 0, v
, "generalized vector");
737 scm_nullvect
= scm_c_make_vector (0, SCM_UNDEFINED
);
739 #include "libguile/vectors.x"