1 /* Copyright (C) 1995,1996,1998,1999,2000,2001 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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"
39 #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
41 #if SCM_ENABLE_DEPRECATED
46 scm_c_issue_deprecation_warning
47 ("SCM_VECTORP is deprecated. Use scm_is_vector instead.");
48 return SCM_I_IS_VECTOR (x
);
52 SCM_VECTOR_LENGTH (SCM x
)
54 scm_c_issue_deprecation_warning
55 ("SCM_VECTOR_LENGTH is deprecated. Use scm_c_vector_length instead.");
56 return SCM_I_VECTOR_LENGTH (x
);
62 scm_c_issue_deprecation_warning
63 ("SCM_VELTS is deprecated. Use scm_vector_elements instead.");
64 return SCM_I_VECTOR_ELTS (x
);
68 SCM_WRITABLE_VELTS (SCM x
)
70 scm_c_issue_deprecation_warning
71 ("SCM_WRITABLE_VELTS is deprecated. "
72 "Use scm_vector_writable_elements instead.");
73 return SCM_I_VECTOR_WELTS (x
);
77 SCM_VECTOR_REF (SCM x
, size_t idx
)
79 scm_c_issue_deprecation_warning
80 ("SCM_VECTOR_REF is deprecated. "
81 "Use scm_c_vector_ref or scm_vector_elements instead.");
82 return scm_c_vector_ref (x
, idx
);
86 SCM_VECTOR_SET (SCM x
, size_t idx
, SCM val
)
88 scm_c_issue_deprecation_warning
89 ("SCM_VECTOR_SET is deprecated. "
90 "Use scm_c_vector_set_x or scm_vector_writable_elements instead.");
91 scm_c_vector_set_x (x
, idx
, val
);
97 scm_is_vector (SCM obj
)
99 if (SCM_I_IS_VECTOR (obj
))
101 if (SCM_ARRAYP (obj
) && SCM_ARRAY_NDIM (obj
) == 1)
103 SCM v
= SCM_ARRAY_V (obj
);
104 return SCM_I_IS_VECTOR (v
);
110 scm_is_simple_vector (SCM obj
)
112 return SCM_I_IS_VECTOR (obj
);
115 SCM_DEFINE (scm_vector_p
, "vector?", 1, 0, 0,
117 "Return @code{#t} if @var{obj} is a vector, otherwise return\n"
119 #define FUNC_NAME s_scm_vector_p
121 return scm_from_bool (scm_is_vector (obj
));
125 SCM_GPROC (s_vector_length
, "vector-length", 1, 0, 0, scm_vector_length
, g_vector_length
);
126 /* Returns the number of elements in @var{vector} as an exact integer. */
128 scm_vector_length (SCM v
)
130 if (SCM_I_IS_VECTOR (v
))
131 return scm_from_size_t (SCM_I_VECTOR_LENGTH (v
));
132 else if (SCM_ARRAYP (v
) && SCM_ARRAY_NDIM (v
) == 1)
134 scm_t_array_dim
*dim
= SCM_ARRAY_DIMS (v
);
135 return scm_from_size_t (dim
->ubnd
- dim
->lbnd
+ 1);
138 SCM_WTA_DISPATCH_1 (g_vector_length
, v
, 1, NULL
);
142 scm_c_vector_length (SCM v
)
144 if (SCM_I_IS_VECTOR (v
))
145 return SCM_I_VECTOR_LENGTH (v
);
147 return scm_to_size_t (scm_vector_length (v
));
150 SCM_REGISTER_PROC (s_list_to_vector
, "list->vector", 1, 0, 0, scm_vector
);
152 "Return a newly created vector initialized to the elements of"
153 "the list @var{list}.\n\n"
155 "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
156 "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
159 SCM_DEFINE (scm_vector
, "vector", 0, 0, 1,
161 "@deffnx {Scheme Procedure} list->vector l\n"
162 "Return a newly allocated vector composed of the\n"
163 "given arguments. Analogous to @code{list}.\n"
166 "(vector 'a 'b 'c) @result{} #(a b c)\n"
168 #define FUNC_NAME s_scm_vector
173 scm_t_array_handle handle
;
175 SCM_VALIDATE_LIST_COPYLEN (1, l
, len
);
177 res
= scm_c_make_vector (len
, SCM_UNSPECIFIED
);
178 data
= scm_vector_writable_elements (res
, &handle
, NULL
, NULL
);
180 while (!SCM_NULL_OR_NIL_P (l
) && i
< len
)
182 data
[i
] = SCM_CAR (l
);
191 SCM_GPROC (s_vector_ref
, "vector-ref", 2, 0, 0, scm_vector_ref
, g_vector_ref
);
194 "@var{k} must be a valid index of @var{vector}.\n"
195 "@samp{Vector-ref} returns the contents of element @var{k} of\n"
198 "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n"
199 "(vector-ref '#(1 1 2 3 5 8 13 21)\n"
200 " (let ((i (round (* 2 (acos -1)))))\n"
201 " (if (inexact? i)\n"
202 " (inexact->exact i)\n"
203 " i))) @result{} 13\n"
208 scm_vector_ref (SCM v
, SCM k
)
209 #define FUNC_NAME s_vector_ref
211 return scm_c_vector_ref (v
, scm_to_size_t (k
));
216 scm_c_vector_ref (SCM v
, size_t k
)
218 if (SCM_I_IS_VECTOR (v
))
220 if (k
>= SCM_I_VECTOR_LENGTH (v
))
221 scm_out_of_range (NULL
, scm_from_size_t (k
));
222 return (SCM_I_VECTOR_ELTS(v
))[k
];
224 else if (SCM_ARRAYP (v
) && SCM_ARRAY_NDIM (v
) == 1)
226 scm_t_array_dim
*dim
= SCM_ARRAY_DIMS (v
);
227 SCM vv
= SCM_ARRAY_V (v
);
228 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_ARRAY_BASE (v
) + k
*dim
->inc
;
233 return (SCM_I_VECTOR_ELTS (vv
))[k
];
235 scm_wrong_type_arg_msg (NULL
, 0, v
, "non-uniform vector");
238 SCM_WTA_DISPATCH_2 (g_vector_ref
, v
, scm_from_size_t (k
), 2, NULL
);
241 SCM_GPROC (s_vector_set_x
, "vector-set!", 3, 0, 0, scm_vector_set_x
, g_vector_set_x
);
243 /* "@var{k} must be a valid index of @var{vector}.\n"
244 "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
245 "The value returned by @samp{vector-set!} is unspecified.\n"
247 "(let ((vec (vector 0 '(2 2 2 2) "Anna")))\n"
248 " (vector-set! vec 1 '("Sue" "Sue"))\n"
249 " vec) @result{} #(0 ("Sue" "Sue") "Anna")\n"
250 "(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector\n"
255 scm_vector_set_x (SCM v
, SCM k
, SCM obj
)
256 #define FUNC_NAME s_vector_set_x
258 scm_c_vector_set_x (v
, scm_to_size_t (k
), obj
);
259 return SCM_UNSPECIFIED
;
264 scm_c_vector_set_x (SCM v
, size_t k
, SCM obj
)
266 if (SCM_I_IS_VECTOR (v
))
268 if (k
>= SCM_I_VECTOR_LENGTH (v
))
269 scm_out_of_range (NULL
, scm_from_size_t (k
));
270 (SCM_I_VECTOR_WELTS(v
))[k
] = obj
;
272 else if (SCM_ARRAYP (v
) && SCM_ARRAY_NDIM (v
) == 1)
274 scm_t_array_dim
*dim
= SCM_ARRAY_DIMS (v
);
275 SCM vv
= SCM_ARRAY_V (v
);
276 if (SCM_I_IS_VECTOR (vv
))
278 if (k
>= dim
->ubnd
- dim
->lbnd
+ 1)
279 scm_out_of_range (NULL
, scm_from_size_t (k
));
280 k
= SCM_ARRAY_BASE (v
) + k
*dim
->inc
;
281 (SCM_I_VECTOR_WELTS (vv
))[k
] = obj
;
284 scm_wrong_type_arg_msg (NULL
, 0, v
, "non-uniform vector");
288 if (SCM_UNPACK (g_vector_set_x
))
289 scm_apply_generic (g_vector_set_x
,
290 scm_list_3 (v
, scm_from_size_t (k
), obj
));
292 scm_wrong_type_arg_msg (NULL
, 0, v
, "vector");
296 SCM_DEFINE (scm_make_vector
, "make-vector", 1, 1, 0,
298 "Return a newly allocated vector of @var{k} elements. If a\n"
299 "second argument is given, then each position is initialized to\n"
300 "@var{fill}. Otherwise the initial contents of each position is\n"
302 #define FUNC_NAME s_scm_make_vector
304 size_t l
= scm_to_unsigned_integer (k
, 0, VECTOR_MAX_LENGTH
);
306 if (SCM_UNBNDP (fill
))
307 fill
= SCM_UNSPECIFIED
;
309 return scm_c_make_vector (l
, fill
);
315 scm_c_make_vector (size_t k
, SCM fill
)
316 #define FUNC_NAME s_scm_make_vector
325 SCM_ASSERT_RANGE (1, scm_from_ulong (k
), k
<= VECTOR_MAX_LENGTH
);
327 base
= scm_gc_malloc (k
* sizeof (SCM
), "vector");
328 for (j
= 0; j
!= k
; ++j
)
334 v
= scm_cell ((k
<< 8) | scm_tc7_vector
, (scm_t_bits
) base
);
335 scm_remember_upto_here_1 (fill
);
341 SCM_DEFINE (scm_vector_copy
, "vector-copy", 1, 0, 0,
343 "Return a copy of @var{vec}.")
344 #define FUNC_NAME s_scm_vector_copy
346 scm_t_array_handle handle
;
352 src
= scm_vector_elements (vec
, &handle
, &len
, &inc
);
353 dst
= scm_gc_malloc (len
* sizeof (SCM
), "vector");
354 for (i
= 0; i
< len
; i
++, src
+= inc
)
357 return scm_cell ((len
<< 8) | scm_tc7_vector
, (scm_t_bits
) dst
);
362 scm_i_vector_free (SCM vec
)
364 scm_gc_free (SCM_I_VECTOR_WELTS (vec
),
365 SCM_I_VECTOR_LENGTH (vec
) * sizeof(SCM
),
369 /* Allocate memory for a weak vector on behalf of the caller. The allocated
370 * vector will be of the given weak vector subtype. It will contain size
371 * elements which are initialized with the 'fill' object, or, if 'fill' is
372 * undefined, with an unspecified object.
375 scm_i_allocate_weak_vector (scm_t_bits type
, SCM size
, SCM fill
)
381 c_size
= scm_to_unsigned_integer (size
, 0, VECTOR_MAX_LENGTH
);
387 if (SCM_UNBNDP (fill
))
388 fill
= SCM_UNSPECIFIED
;
390 base
= scm_gc_malloc (c_size
* sizeof (SCM
), "weak vector");
391 for (j
= 0; j
!= c_size
; ++j
)
397 v
= scm_double_cell ((c_size
<< 8) | scm_tc7_wvect
,
400 SCM_UNPACK (SCM_EOL
));
401 scm_remember_upto_here_1 (fill
);
406 SCM_DEFINE (scm_vector_to_list
, "vector->list", 1, 0, 0,
408 "Return a newly allocated list composed of the elements of @var{v}.\n"
411 "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
412 "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
414 #define FUNC_NAME s_scm_vector_to_list
418 scm_t_array_handle handle
;
422 data
= scm_vector_elements (v
, &handle
, &len
, &inc
);
423 for (i
= len
*inc
; i
> 0;)
426 res
= scm_cons (data
[i
], res
);
433 SCM_DEFINE (scm_vector_fill_x
, "vector-fill!", 2, 0, 0,
435 "Store @var{fill} in every position of @var{vector}. The value\n"
436 "returned by @code{vector-fill!} is unspecified.")
437 #define FUNC_NAME s_scm_vector_fill_x
439 scm_t_array_handle handle
;
444 data
= scm_vector_writable_elements (v
, &handle
, &len
, &inc
);
445 for (i
= 0; i
< len
; i
+= inc
)
447 return SCM_UNSPECIFIED
;
453 scm_vector_equal_p (SCM x
, SCM y
)
456 for (i
= SCM_I_VECTOR_LENGTH (x
) - 1; i
>= 0; i
--)
457 if (scm_is_false (scm_equal_p (SCM_I_VECTOR_ELTS (x
)[i
],
458 SCM_I_VECTOR_ELTS (y
)[i
])))
464 SCM_DEFINE (scm_vector_move_left_x
, "vector-move-left!", 5, 0, 0,
465 (SCM vec1
, SCM start1
, SCM end1
, SCM vec2
, SCM start2
),
466 "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
467 "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
468 "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
469 "@code{vector-move-left!} copies elements in leftmost order.\n"
470 "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
471 "same vector, @code{vector-move-left!} is usually appropriate when\n"
472 "@var{start1} is greater than @var{start2}.")
473 #define FUNC_NAME s_scm_vector_move_left_x
475 scm_t_array_handle handle1
, handle2
;
482 elts1
= scm_vector_elements (vec1
, &handle1
, &len1
, &inc1
);
483 elts2
= scm_vector_writable_elements (vec2
, &handle2
, &len2
, &inc2
);
485 i
= scm_to_unsigned_integer (start1
, 0, len1
);
486 e
= scm_to_unsigned_integer (end1
, i
, len1
);
487 j
= scm_to_unsigned_integer (start2
, 0, len2
- (i
-e
));
492 for (; i
< e
; i
+= inc1
, j
+= inc2
)
495 return SCM_UNSPECIFIED
;
499 SCM_DEFINE (scm_vector_move_right_x
, "vector-move-right!", 5, 0, 0,
500 (SCM vec1
, SCM start1
, SCM end1
, SCM vec2
, SCM start2
),
501 "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
502 "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
503 "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
504 "@code{vector-move-right!} copies elements in rightmost order.\n"
505 "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
506 "same vector, @code{vector-move-right!} is usually appropriate when\n"
507 "@var{start1} is less than @var{start2}.")
508 #define FUNC_NAME s_scm_vector_move_right_x
510 scm_t_array_handle handle1
, handle2
;
517 elts1
= scm_vector_elements (vec1
, &handle1
, &len1
, &inc1
);
518 elts2
= scm_vector_writable_elements (vec2
, &handle2
, &len2
, &inc2
);
520 i
= scm_to_unsigned_integer (start1
, 0, len1
);
521 e
= scm_to_unsigned_integer (end1
, i
, len1
);
522 j
= scm_to_unsigned_integer (start2
, 0, len2
- (i
-e
));
534 return SCM_UNSPECIFIED
;
539 /* Generalized vectors. */
542 scm_is_generalized_vector (SCM obj
)
544 return (scm_is_vector (obj
)
545 || scm_is_string (obj
)
546 || scm_is_bitvector (obj
)
547 || scm_is_uniform_vector (obj
));
550 SCM_DEFINE (scm_generalized_vector_p
, "generalized-vector?", 1, 0, 0,
552 "Return @code{#t} if @var{obj} is a vector, string,\n"
553 "bitvector, or uniform numeric vector.")
554 #define FUNC_NAME s_scm_generalized_vector_p
556 return scm_from_bool (scm_is_generalized_vector (obj
));
561 scm_c_generalized_vector_length (SCM v
)
563 if (scm_is_vector (v
))
564 return scm_c_vector_length (v
);
565 else if (scm_is_string (v
))
566 return scm_c_string_length (v
);
567 else if (scm_is_bitvector (v
))
568 return scm_c_bitvector_length (v
);
569 else if (scm_is_uniform_vector (v
))
570 return scm_c_uniform_vector_length (v
);
572 scm_wrong_type_arg_msg (NULL
, 0, v
, "generalized vector");
575 SCM_DEFINE (scm_generalized_vector_length
, "generalized-vector-length", 1, 0, 0,
577 "Return the length of the generalized vector @var{v}.")
578 #define FUNC_NAME s_scm_generalized_vector_length
580 return scm_from_size_t (scm_c_generalized_vector_length (v
));
585 scm_c_generalized_vector_ref (SCM v
, size_t idx
)
587 if (scm_is_vector (v
))
588 return scm_c_vector_ref (v
, idx
);
589 else if (scm_is_string (v
))
590 return scm_c_string_ref (v
, idx
);
591 else if (scm_is_bitvector (v
))
592 return scm_c_bitvector_ref (v
, idx
);
593 else if (scm_is_uniform_vector (v
))
594 return scm_c_uniform_vector_ref (v
, idx
);
596 scm_wrong_type_arg_msg (NULL
, 0, v
, "generalized vector");
599 SCM_DEFINE (scm_generalized_vector_ref
, "generalized-vector-ref", 2, 0, 0,
601 "Return the element at index @var{idx} of the\n"
602 "generalized vector @var{v}.")
603 #define FUNC_NAME s_scm_generalized_vector_ref
605 return scm_c_generalized_vector_ref (v
, scm_to_size_t (idx
));
610 scm_c_generalized_vector_set_x (SCM v
, size_t idx
, SCM val
)
612 if (scm_is_vector (v
))
613 scm_c_vector_set_x (v
, idx
, val
);
614 else if (scm_is_string (v
))
615 scm_c_string_set_x (v
, idx
, val
);
616 else if (scm_is_bitvector (v
))
617 scm_c_bitvector_set_x (v
, idx
, val
);
618 else if (scm_is_uniform_vector (v
))
619 scm_c_uniform_vector_set_x (v
, idx
, val
);
621 scm_wrong_type_arg_msg (NULL
, 0, v
, "generalized vector");
624 SCM_DEFINE (scm_generalized_vector_set_x
, "generalized-vector-set!", 3, 0, 0,
625 (SCM v
, SCM idx
, SCM val
),
626 "Set the element at index @var{idx} of the\n"
627 "generalized vector @var{v} to @var{val}.")
628 #define FUNC_NAME s_scm_generalized_vector_set_x
630 scm_c_generalized_vector_set_x (v
, scm_to_size_t (idx
), val
);
631 return SCM_UNSPECIFIED
;
635 SCM_DEFINE (scm_generalized_vector_to_list
, "generalized-vector->list", 1, 0, 0,
637 "Return a new list whose elements are the elements of the\n"
638 "generalized vector @var{v}.")
639 #define FUNC_NAME s_scm_generalized_vector_to_list
641 if (scm_is_vector (v
))
642 return scm_vector_to_list (v
);
643 else if (scm_is_string (v
))
644 return scm_string_to_list (v
);
645 else if (scm_is_bitvector (v
))
646 return scm_bitvector_to_list (v
);
647 else if (scm_is_uniform_vector (v
))
648 return scm_uniform_vector_to_list (v
);
650 scm_wrong_type_arg_msg (NULL
, 0, v
, "generalized vector");
658 scm_nullvect
= scm_c_make_vector (0, SCM_UNDEFINED
);
660 #include "libguile/vectors.x"