← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to libguile/vectors.c

  • Committer: Bazaar Package Importer
  • Author(s): Daniel Schepler
  • Date: 2006-11-09 03:11:16 UTC
  • Revision ID: james.westby@ubuntu.com-20061109031116-hu0q1jxqg12y6yeg
Tags: upstream-1.8.1+1
Import upstream version 1.8.1+1

Show diffs side-by-side

added added

removed removed

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