add generic array implementation facility
[bpt/guile.git] / libguile / vectors.c
1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
2 *
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.
7 *
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.
12 *
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
16 * 02110-1301 USA
17 */
18
19
20 \f
21 #ifdef HAVE_CONFIG_H
22 # include <config.h>
23 #endif
24
25 #include "libguile/_scm.h"
26 #include "libguile/eq.h"
27 #include "libguile/root.h"
28 #include "libguile/strings.h"
29 #include "libguile/lang.h"
30
31 #include "libguile/validate.h"
32 #include "libguile/vectors.h"
33 #include "libguile/arrays.h"
34 #include "libguile/bitvectors.h"
35 #include "libguile/bytevectors.h"
36 #include "libguile/array-map.h"
37 #include "libguile/srfi-4.h"
38 #include "libguile/strings.h"
39 #include "libguile/srfi-13.h"
40 #include "libguile/dynwind.h"
41 #include "libguile/deprecation.h"
42
43 \f
44
45 #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
46
47 int
48 scm_is_vector (SCM obj)
49 {
50 if (SCM_I_IS_VECTOR (obj))
51 return 1;
52 if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
53 {
54 SCM v = SCM_I_ARRAY_V (obj);
55 return SCM_I_IS_VECTOR (v);
56 }
57 return 0;
58 }
59
60 int
61 scm_is_simple_vector (SCM obj)
62 {
63 return SCM_I_IS_VECTOR (obj);
64 }
65
66 const SCM *
67 scm_vector_elements (SCM vec, scm_t_array_handle *h,
68 size_t *lenp, ssize_t *incp)
69 {
70 scm_generalized_vector_get_handle (vec, h);
71 if (lenp)
72 {
73 scm_t_array_dim *dim = scm_array_handle_dims (h);
74 *lenp = dim->ubnd - dim->lbnd + 1;
75 *incp = dim->inc;
76 }
77 return scm_array_handle_elements (h);
78 }
79
80 SCM *
81 scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
82 size_t *lenp, ssize_t *incp)
83 {
84 scm_generalized_vector_get_handle (vec, h);
85 if (lenp)
86 {
87 scm_t_array_dim *dim = scm_array_handle_dims (h);
88 *lenp = dim->ubnd - dim->lbnd + 1;
89 *incp = dim->inc;
90 }
91 return scm_array_handle_writable_elements (h);
92 }
93
94 SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0,
95 (SCM obj),
96 "Return @code{#t} if @var{obj} is a vector, otherwise return\n"
97 "@code{#f}.")
98 #define FUNC_NAME s_scm_vector_p
99 {
100 return scm_from_bool (scm_is_vector (obj));
101 }
102 #undef FUNC_NAME
103
104 SCM_GPROC (s_vector_length, "vector-length", 1, 0, 0, scm_vector_length, g_vector_length);
105 /* Returns the number of elements in @var{vector} as an exact integer. */
106 SCM
107 scm_vector_length (SCM v)
108 {
109 if (SCM_I_IS_VECTOR (v))
110 return scm_from_size_t (SCM_I_VECTOR_LENGTH (v));
111 else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
112 {
113 scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
114 return scm_from_size_t (dim->ubnd - dim->lbnd + 1);
115 }
116 else
117 SCM_WTA_DISPATCH_1 (g_vector_length, v, 1, NULL);
118 }
119
120 size_t
121 scm_c_vector_length (SCM v)
122 {
123 if (SCM_I_IS_VECTOR (v))
124 return SCM_I_VECTOR_LENGTH (v);
125 else
126 return scm_to_size_t (scm_vector_length (v));
127 }
128
129 SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
130 /*
131 "Return a newly created vector initialized to the elements of"
132 "the list @var{list}.\n\n"
133 "@lisp\n"
134 "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
135 "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
136 "@end lisp")
137 */
138 SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
139 (SCM l),
140 "@deffnx {Scheme Procedure} list->vector l\n"
141 "Return a newly allocated vector composed of the\n"
142 "given arguments. Analogous to @code{list}.\n"
143 "\n"
144 "@lisp\n"
145 "(vector 'a 'b 'c) @result{} #(a b c)\n"
146 "@end lisp")
147 #define FUNC_NAME s_scm_vector
148 {
149 SCM res;
150 SCM *data;
151 long i, len;
152 scm_t_array_handle handle;
153
154 SCM_VALIDATE_LIST_COPYLEN (1, l, len);
155
156 res = scm_c_make_vector (len, SCM_UNSPECIFIED);
157 data = scm_vector_writable_elements (res, &handle, NULL, NULL);
158 i = 0;
159 while (scm_is_pair (l) && i < len)
160 {
161 data[i] = SCM_CAR (l);
162 l = SCM_CDR (l);
163 i += 1;
164 }
165
166 scm_array_handle_release (&handle);
167
168 return res;
169 }
170 #undef FUNC_NAME
171
172 SCM_GPROC (s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref, g_vector_ref);
173
174 /*
175 "@var{k} must be a valid index of @var{vector}.\n"
176 "@samp{Vector-ref} returns the contents of element @var{k} of\n"
177 "@var{vector}.\n\n"
178 "@lisp\n"
179 "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n"
180 "(vector-ref '#(1 1 2 3 5 8 13 21)\n"
181 " (let ((i (round (* 2 (acos -1)))))\n"
182 " (if (inexact? i)\n"
183 " (inexact->exact i)\n"
184 " i))) @result{} 13\n"
185 "@end lisp"
186 */
187
188 SCM
189 scm_vector_ref (SCM v, SCM k)
190 #define FUNC_NAME s_vector_ref
191 {
192 return scm_c_vector_ref (v, scm_to_size_t (k));
193 }
194 #undef FUNC_NAME
195
196 SCM
197 scm_c_vector_ref (SCM v, size_t k)
198 {
199 if (SCM_I_IS_VECTOR (v))
200 {
201 if (k >= SCM_I_VECTOR_LENGTH (v))
202 scm_out_of_range (NULL, scm_from_size_t (k));
203 return (SCM_I_VECTOR_ELTS(v))[k];
204 }
205 else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
206 {
207 scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
208 SCM vv = SCM_I_ARRAY_V (v);
209 if (SCM_I_IS_VECTOR (vv))
210 {
211 if (k >= dim->ubnd - dim->lbnd + 1)
212 scm_out_of_range (NULL, scm_from_size_t (k));
213 k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
214 return (SCM_I_VECTOR_ELTS (vv))[k];
215 }
216 scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
217 }
218 else
219 SCM_WTA_DISPATCH_2 (g_vector_ref, v, scm_from_size_t (k), 2, NULL);
220 }
221
222 SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x);
223
224 /* "@var{k} must be a valid index of @var{vector}.\n"
225 "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
226 "The value returned by @samp{vector-set!} is unspecified.\n"
227 "@lisp\n"
228 "(let ((vec (vector 0 '(2 2 2 2) "Anna")))\n"
229 " (vector-set! vec 1 '("Sue" "Sue"))\n"
230 " vec) @result{} #(0 ("Sue" "Sue") "Anna")\n"
231 "(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector\n"
232 "@end lisp"
233 */
234
235 SCM
236 scm_vector_set_x (SCM v, SCM k, SCM obj)
237 #define FUNC_NAME s_vector_set_x
238 {
239 scm_c_vector_set_x (v, scm_to_size_t (k), obj);
240 return SCM_UNSPECIFIED;
241 }
242 #undef FUNC_NAME
243
244 void
245 scm_c_vector_set_x (SCM v, size_t k, SCM obj)
246 {
247 if (SCM_I_IS_VECTOR (v))
248 {
249 if (k >= SCM_I_VECTOR_LENGTH (v))
250 scm_out_of_range (NULL, scm_from_size_t (k));
251 (SCM_I_VECTOR_WELTS(v))[k] = obj;
252 }
253 else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
254 {
255 scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
256 SCM vv = SCM_I_ARRAY_V (v);
257 if (SCM_I_IS_VECTOR (vv))
258 {
259 if (k >= dim->ubnd - dim->lbnd + 1)
260 scm_out_of_range (NULL, scm_from_size_t (k));
261 k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
262 (SCM_I_VECTOR_WELTS (vv))[k] = obj;
263 }
264 else
265 scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
266 }
267 else
268 {
269 if (SCM_UNPACK (g_vector_set_x))
270 scm_apply_generic (g_vector_set_x,
271 scm_list_3 (v, scm_from_size_t (k), obj));
272 else
273 scm_wrong_type_arg_msg (NULL, 0, v, "vector");
274 }
275 }
276
277 SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0,
278 (SCM k, SCM fill),
279 "Return a newly allocated vector of @var{k} elements. If a\n"
280 "second argument is given, then each position is initialized to\n"
281 "@var{fill}. Otherwise the initial contents of each position is\n"
282 "unspecified.")
283 #define FUNC_NAME s_scm_make_vector
284 {
285 size_t l = scm_to_unsigned_integer (k, 0, VECTOR_MAX_LENGTH);
286
287 if (SCM_UNBNDP (fill))
288 fill = SCM_UNSPECIFIED;
289
290 return scm_c_make_vector (l, fill);
291 }
292 #undef FUNC_NAME
293
294
295 SCM
296 scm_c_make_vector (size_t k, SCM fill)
297 #define FUNC_NAME s_scm_make_vector
298 {
299 SCM v;
300 SCM *base;
301
302 if (k > 0)
303 {
304 unsigned long int j;
305
306 SCM_ASSERT_RANGE (1, scm_from_ulong (k), k <= VECTOR_MAX_LENGTH);
307
308 base = scm_gc_malloc (k * sizeof (SCM), "vector");
309 for (j = 0; j != k; ++j)
310 base[j] = fill;
311 }
312 else
313 base = NULL;
314
315 v = scm_cell ((k << 8) | scm_tc7_vector, (scm_t_bits) base);
316 scm_remember_upto_here_1 (fill);
317
318 return v;
319 }
320 #undef FUNC_NAME
321
322 SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
323 (SCM vec),
324 "Return a copy of @var{vec}.")
325 #define FUNC_NAME s_scm_vector_copy
326 {
327 scm_t_array_handle handle;
328 size_t i, len;
329 ssize_t inc;
330 const SCM *src;
331 SCM *dst;
332
333 src = scm_vector_elements (vec, &handle, &len, &inc);
334 dst = scm_gc_malloc (len * sizeof (SCM), "vector");
335 for (i = 0; i < len; i++, src += inc)
336 dst[i] = *src;
337 scm_array_handle_release (&handle);
338
339 return scm_cell ((len << 8) | scm_tc7_vector, (scm_t_bits) dst);
340 }
341 #undef FUNC_NAME
342
343 void
344 scm_i_vector_free (SCM vec)
345 {
346 scm_gc_free (SCM_I_VECTOR_WELTS (vec),
347 SCM_I_VECTOR_LENGTH (vec) * sizeof(SCM),
348 "vector");
349 }
350
351 /* Allocate memory for a weak vector on behalf of the caller. The allocated
352 * vector will be of the given weak vector subtype. It will contain size
353 * elements which are initialized with the 'fill' object, or, if 'fill' is
354 * undefined, with an unspecified object.
355 */
356 SCM
357 scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill)
358 {
359 size_t c_size;
360 SCM *base;
361 SCM v;
362
363 c_size = scm_to_unsigned_integer (size, 0, VECTOR_MAX_LENGTH);
364
365 if (c_size > 0)
366 {
367 size_t j;
368
369 if (SCM_UNBNDP (fill))
370 fill = SCM_UNSPECIFIED;
371
372 base = scm_gc_malloc (c_size * sizeof (SCM), "weak vector");
373 for (j = 0; j != c_size; ++j)
374 base[j] = fill;
375 }
376 else
377 base = NULL;
378
379 v = scm_double_cell ((c_size << 8) | scm_tc7_wvect,
380 (scm_t_bits) base,
381 type,
382 SCM_UNPACK (SCM_EOL));
383 scm_remember_upto_here_1 (fill);
384
385 return v;
386 }
387
388 SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
389 (SCM v),
390 "Return a newly allocated list composed of the elements of @var{v}.\n"
391 "\n"
392 "@lisp\n"
393 "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
394 "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
395 "@end lisp")
396 #define FUNC_NAME s_scm_vector_to_list
397 {
398 SCM res = SCM_EOL;
399 const SCM *data;
400 scm_t_array_handle handle;
401 size_t i, count, len;
402 ssize_t inc;
403
404 data = scm_vector_elements (v, &handle, &len, &inc);
405 for (i = (len - 1) * inc, count = 0;
406 count < len;
407 i -= inc, count++)
408 res = scm_cons (data[i], res);
409
410 scm_array_handle_release (&handle);
411 return res;
412 }
413 #undef FUNC_NAME
414
415
416 SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0,
417 (SCM v, SCM fill),
418 "Store @var{fill} in every position of @var{vector}. The value\n"
419 "returned by @code{vector-fill!} is unspecified.")
420 #define FUNC_NAME s_scm_vector_fill_x
421 {
422 scm_t_array_handle handle;
423 SCM *data;
424 size_t i, len;
425 ssize_t inc;
426
427 data = scm_vector_writable_elements (v, &handle, &len, &inc);
428 for (i = 0; i < len; i += inc)
429 data[i] = fill;
430 scm_array_handle_release (&handle);
431 return SCM_UNSPECIFIED;
432 }
433 #undef FUNC_NAME
434
435
436 SCM
437 scm_i_vector_equal_p (SCM x, SCM y)
438 {
439 long i;
440 for (i = SCM_I_VECTOR_LENGTH (x) - 1; i >= 0; i--)
441 if (scm_is_false (scm_equal_p (SCM_I_VECTOR_ELTS (x)[i],
442 SCM_I_VECTOR_ELTS (y)[i])))
443 return SCM_BOOL_F;
444 return SCM_BOOL_T;
445 }
446
447
448 SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0,
449 (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
450 "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
451 "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
452 "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
453 "@code{vector-move-left!} copies elements in leftmost order.\n"
454 "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
455 "same vector, @code{vector-move-left!} is usually appropriate when\n"
456 "@var{start1} is greater than @var{start2}.")
457 #define FUNC_NAME s_scm_vector_move_left_x
458 {
459 scm_t_array_handle handle1, handle2;
460 const SCM *elts1;
461 SCM *elts2;
462 size_t len1, len2;
463 ssize_t inc1, inc2;
464 size_t i, j, e;
465
466 elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
467 elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
468
469 i = scm_to_unsigned_integer (start1, 0, len1);
470 e = scm_to_unsigned_integer (end1, i, len1);
471 j = scm_to_unsigned_integer (start2, 0, len2 - (i-e));
472
473 i *= inc1;
474 e *= inc1;
475 j *= inc2;
476 for (; i < e; i += inc1, j += inc2)
477 elts2[j] = elts1[i];
478
479 scm_array_handle_release (&handle2);
480 scm_array_handle_release (&handle1);
481
482 return SCM_UNSPECIFIED;
483 }
484 #undef FUNC_NAME
485
486 SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
487 (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
488 "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
489 "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
490 "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
491 "@code{vector-move-right!} copies elements in rightmost order.\n"
492 "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
493 "same vector, @code{vector-move-right!} is usually appropriate when\n"
494 "@var{start1} is less than @var{start2}.")
495 #define FUNC_NAME s_scm_vector_move_right_x
496 {
497 scm_t_array_handle handle1, handle2;
498 const SCM *elts1;
499 SCM *elts2;
500 size_t len1, len2;
501 ssize_t inc1, inc2;
502 size_t i, j, e;
503
504 elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
505 elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
506
507 i = scm_to_unsigned_integer (start1, 0, len1);
508 e = scm_to_unsigned_integer (end1, i, len1);
509 j = scm_to_unsigned_integer (start2, 0, len2 - (i-e));
510
511 i *= inc1;
512 e *= inc1;
513 j *= inc2;
514 while (i < e)
515 {
516 e -= inc1;
517 j -= inc2;
518 elts2[j] = elts1[e];
519 }
520
521 scm_array_handle_release (&handle2);
522 scm_array_handle_release (&handle1);
523
524 return SCM_UNSPECIFIED;
525 }
526 #undef FUNC_NAME
527
528 \f
529 /* Generalized vectors. */
530
531 int
532 scm_is_generalized_vector (SCM obj)
533 {
534 return (scm_is_vector (obj)
535 || scm_is_string (obj)
536 || scm_is_bitvector (obj)
537 || scm_is_uniform_vector (obj)
538 || scm_is_bytevector (obj));
539 }
540
541 SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0,
542 (SCM obj),
543 "Return @code{#t} if @var{obj} is a vector, string,\n"
544 "bitvector, or uniform numeric vector.")
545 #define FUNC_NAME s_scm_generalized_vector_p
546 {
547 return scm_from_bool (scm_is_generalized_vector (obj));
548 }
549 #undef FUNC_NAME
550
551 void
552 scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
553 {
554 scm_array_get_handle (vec, h);
555 if (scm_array_handle_rank (h) != 1)
556 scm_wrong_type_arg_msg (NULL, 0, vec, "vector");
557 }
558
559 size_t
560 scm_c_generalized_vector_length (SCM v)
561 {
562 if (scm_is_vector (v))
563 return scm_c_vector_length (v);
564 else if (scm_is_string (v))
565 return scm_c_string_length (v);
566 else if (scm_is_bitvector (v))
567 return scm_c_bitvector_length (v);
568 else if (scm_is_uniform_vector (v))
569 return scm_c_uniform_vector_length (v);
570 else if (scm_is_bytevector (v))
571 return scm_c_bytevector_length (v);
572 else
573 scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
574 }
575
576 SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0,
577 (SCM v),
578 "Return the length of the generalized vector @var{v}.")
579 #define FUNC_NAME s_scm_generalized_vector_length
580 {
581 return scm_from_size_t (scm_c_generalized_vector_length (v));
582 }
583 #undef FUNC_NAME
584
585 SCM
586 scm_c_generalized_vector_ref (SCM v, size_t idx)
587 {
588 if (scm_is_vector (v))
589 return scm_c_vector_ref (v, idx);
590 else if (scm_is_string (v))
591 return scm_c_string_ref (v, idx);
592 else if (scm_is_bitvector (v))
593 return scm_c_bitvector_ref (v, idx);
594 else if (scm_is_uniform_vector (v))
595 return scm_c_uniform_vector_ref (v, idx);
596 else if (scm_is_bytevector (v))
597 return scm_from_uint8 (scm_c_bytevector_ref (v, idx));
598 else
599 scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
600 }
601
602 SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0,
603 (SCM v, SCM idx),
604 "Return the element at index @var{idx} of the\n"
605 "generalized vector @var{v}.")
606 #define FUNC_NAME s_scm_generalized_vector_ref
607 {
608 return scm_c_generalized_vector_ref (v, scm_to_size_t (idx));
609 }
610 #undef FUNC_NAME
611
612 void
613 scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
614 {
615 if (scm_is_vector (v))
616 scm_c_vector_set_x (v, idx, val);
617 else if (scm_is_string (v))
618 scm_c_string_set_x (v, idx, val);
619 else if (scm_is_bitvector (v))
620 scm_c_bitvector_set_x (v, idx, val);
621 else if (scm_is_uniform_vector (v))
622 scm_c_uniform_vector_set_x (v, idx, val);
623 else if (scm_is_bytevector (v))
624 scm_i_bytevector_generalized_set_x (v, idx, val);
625 else
626 scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
627 }
628
629 SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0,
630 (SCM v, SCM idx, SCM val),
631 "Set the element at index @var{idx} of the\n"
632 "generalized vector @var{v} to @var{val}.")
633 #define FUNC_NAME s_scm_generalized_vector_set_x
634 {
635 scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val);
636 return SCM_UNSPECIFIED;
637 }
638 #undef FUNC_NAME
639
640 SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0,
641 (SCM v),
642 "Return a new list whose elements are the elements of the\n"
643 "generalized vector @var{v}.")
644 #define FUNC_NAME s_scm_generalized_vector_to_list
645 {
646 if (scm_is_vector (v))
647 return scm_vector_to_list (v);
648 else if (scm_is_string (v))
649 return scm_string_to_list (v);
650 else if (scm_is_bitvector (v))
651 return scm_bitvector_to_list (v);
652 else if (scm_is_uniform_vector (v))
653 return scm_uniform_vector_to_list (v);
654 else
655 scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
656 }
657 #undef FUNC_NAME
658
659 static SCM
660 vector_handle_ref (scm_t_array_handle *h, size_t idx)
661 {
662 if (idx > h->dims[0].ubnd)
663 scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx));
664 return ((SCM*)h->elements)[idx];
665 }
666
667 static void
668 vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val)
669 {
670 if (idx > h->dims[0].ubnd)
671 scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx));
672 ((SCM*)h->writable_elements)[idx] = val;
673 }
674
675 static void
676 vector_get_handle (SCM v, scm_t_array_handle *h)
677 {
678 h->array = v;
679 h->ndims = 1;
680 h->dims = &h->dim0;
681 h->dim0.lbnd = 0;
682 h->dim0.ubnd = SCM_I_VECTOR_LENGTH (v) - 1;
683 h->dim0.inc = 1;
684 h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM;
685 h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v);
686 }
687
688 SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2,
689 vector_handle_ref, vector_handle_set,
690 vector_get_handle);
691 SCM_ARRAY_IMPLEMENTATION (scm_tc7_wvect, 0x7f & ~2,
692 vector_handle_ref, vector_handle_set,
693 vector_get_handle);
694
695 void
696 scm_init_vectors ()
697 {
698 scm_nullvect = scm_c_make_vector (0, SCM_UNDEFINED);
699
700 #include "libguile/vectors.x"
701 }
702
703
704 /*
705 Local Variables:
706 c-file-style: "gnu"
707 End:
708 */