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